From Hammer Require Import Hammer.

Require Import FunInd.
From compcert Require Import Coqlib.
Require Import FSets.
From compcert Require Import Ordered.

Local Unset Elimination Schemes.
Local Unset Case Analysis Schemes.

Module SplayHeapSet(E: OrderedType).

Module R.

Inductive heap: Type :=
| Empty
| Node (l: heap) (x: E.t) (r: heap).

Fixpoint partition (pivot: E.t) (h: heap) { struct h } : heap * heap :=
match h with
| Empty => (Empty, Empty)
| Node a x b =>
match E.compare x pivot with
| EQ _ => (a, b)
| LT _ =>
match b with
| Empty => (h, Empty)
| Node b1 y b2 =>
match E.compare y pivot with
| EQ _ => (Node a x b1, b2)
| LT _ =>
let (small, big) := partition pivot b2
in (Node (Node a x b1) y small, big)
| GT _ =>
let (small, big) := partition pivot b1
in (Node a x small, Node big y b2)
end
end
| GT _ =>
match a with
| Empty => (Empty, h)
| Node a1 y a2 =>
match E.compare y pivot with
| EQ _ => (a1, Node a2 x b)
| LT _ =>
let (small, big) := partition pivot a2
in (Node a1 y small, Node big x b)
| GT _ =>
let (small, big) := partition pivot a1
in (small, Node big y (Node a2 x b))
end
end
end
end.

Definition insert (x: E.t) (h: heap) : heap :=
let (a, b) := partition x h in Node a x b.

Fixpoint findMin (h: heap) : option E.t :=
match h with
| Empty => None
| Node Empty x b => Some x
| Node a x b => findMin a
end.

Fixpoint deleteMin (h: heap) : heap :=
match h with
| Empty => Empty
| Node Empty x b => b
| Node (Node Empty x b) y c => Node b y c
| Node (Node a x b) y c => Node (deleteMin a) x (Node b y c)
end.

Fixpoint findMax (h: heap) : option E.t :=
match h with
| Empty => None
| Node a x Empty => Some x
| Node a x b => findMax b
end.

Fixpoint deleteMax (h: heap) : heap :=
match h with
| Empty => Empty
| Node b x Empty => b
| Node b x (Node c y Empty) => Node b x c
| Node a x (Node b y c) => Node (Node a x b) y (deleteMax c)
end.

Scheme heap_ind := Induction for heap Sort Prop.
Functional Scheme partition_ind := Induction for partition Sort Prop.
Functional Scheme deleteMin_ind := Induction for deleteMin Sort Prop.
Functional Scheme deleteMax_ind := Induction for deleteMax Sort Prop.

Fixpoint In (x: E.t) (h: heap) : Prop :=
match h with
| Empty => False
| Node a y b => In x a \/ E.eq x y \/ In x b
end.

Fixpoint lt_heap (h: heap) (x: E.t) : Prop :=
match h with
| Empty => True
| Node a y b => lt_heap a x /\ E.lt y x /\ lt_heap b x
end.

Fixpoint gt_heap (h: heap) (x: E.t) : Prop :=
match h with
| Empty => True
| Node a y b => gt_heap a x /\ E.lt x y /\ gt_heap b x
end.

Fixpoint bst (h: heap) : Prop :=
match h with
| Empty => True
| Node a x b => bst a /\ bst b /\ lt_heap a x /\ gt_heap b x
end.

Definition le (x y: E.t) := E.eq x y \/ E.lt x y.

Lemma le_lt_trans:
forall x1 x2 x3, le x1 x2 -> E.lt x2 x3 -> E.lt x1 x3.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.le_lt_trans".
unfold le; intros; intuition.
destruct (E.compare x1 x3).
auto.
elim (@E.lt_not_eq x2 x3). auto. apply E.eq_trans with x1. apply E.eq_sym; auto. auto.
elim (@E.lt_not_eq x2 x1). eapply E.lt_trans; eauto. apply E.eq_sym; auto.
eapply E.lt_trans; eauto.
Qed.

Lemma lt_le_trans:
forall x1 x2 x3, E.lt x1 x2 -> le x2 x3 -> E.lt x1 x3.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.lt_le_trans".
unfold le; intros; intuition.
destruct (E.compare x1 x3).
auto.
elim (@E.lt_not_eq x1 x2). auto. apply E.eq_trans with x3. auto. apply E.eq_sym; auto.
elim (@E.lt_not_eq x3 x2). eapply E.lt_trans; eauto. apply E.eq_sym; auto.
eapply E.lt_trans; eauto.
Qed.

Lemma le_trans:
forall x1 x2 x3, le x1 x2 -> le x2 x3 -> le x1 x3.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.le_trans".
intros. destruct H. destruct H0. red; left; eapply E.eq_trans; eauto.
red. right. eapply le_lt_trans; eauto. red; auto.
red. right. eapply lt_le_trans; eauto.
Qed.

Lemma lt_heap_trans:
forall x y, le x y ->
forall h, lt_heap h x -> lt_heap h y.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.lt_heap_trans".
induction h; simpl; intros.
auto.
intuition. eapply lt_le_trans; eauto.
Qed.

Lemma gt_heap_trans:
forall x y, le y x ->
forall h, gt_heap h x -> gt_heap h y.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.gt_heap_trans".
induction h; simpl; intros.
auto.
intuition. eapply le_lt_trans; eauto.
Qed.

Lemma In_partition:
forall x pivot, ~E.eq x pivot ->
forall h, bst h -> (In x h <-> In x (fst (partition pivot h)) \/ In x (snd (partition pivot h))).
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.In_partition".
intros x pivot NEQ h0. functional induction (partition pivot h0); simpl; intros.
- tauto.
- tauto.
- rewrite e3 in *; simpl in *; intuition.
- intuition. elim NEQ. eapply E.eq_trans; eauto.
- rewrite e3 in *; simpl in *; intuition.
- intuition. elim NEQ. eapply E.eq_trans; eauto.
- intuition.
- rewrite e3 in *; simpl in *; intuition.
- intuition. elim NEQ. eapply E.eq_trans; eauto.
- rewrite e3 in *; simpl in *; intuition.
Qed.

Lemma partition_lt:
forall x pivot h,
lt_heap h x -> lt_heap (fst (partition pivot h)) x /\ lt_heap (snd (partition pivot h)) x.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.partition_lt".
intros x pivot h0. functional induction (partition pivot h0); simpl; try tauto.
- rewrite e3 in *; simpl in *; tauto.
- rewrite e3 in *; simpl in *; tauto.
- rewrite e3 in *; simpl in *; tauto.
- rewrite e3 in *; simpl in *; tauto.
Qed.

Lemma partition_gt:
forall x pivot h,
gt_heap h x -> gt_heap (fst (partition pivot h)) x /\ gt_heap (snd (partition pivot h)) x.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.partition_gt".
intros x pivot h0. functional induction (partition pivot h0); simpl; try tauto.
- rewrite e3 in *; simpl in *; tauto.
- rewrite e3 in *; simpl in *; tauto.
- rewrite e3 in *; simpl in *; tauto.
- rewrite e3 in *; simpl in *; tauto.
Qed.

Lemma partition_split:
forall pivot h,
bst h -> lt_heap (fst (partition pivot h)) pivot /\ gt_heap (snd (partition pivot h)) pivot.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.partition_split".
intros pivot h0. functional induction (partition pivot h0); simpl.
- tauto.
- intuition. eapply lt_heap_trans; eauto. red; auto.
- rewrite e3 in *; simpl in *. intuition.
eapply lt_heap_trans; eauto. red; auto.
eapply lt_heap_trans; eauto. red; auto.
- intuition.
eapply lt_heap_trans; eauto. red; auto.
eapply lt_heap_trans; eauto. red; auto.
eapply gt_heap_trans with y; eauto. red. left. apply E.eq_sym; auto.
- rewrite e3 in *; simpl in *; intuition.
eapply lt_heap_trans; eauto. red; auto.
eapply gt_heap_trans with y; eauto. red; auto.
- intuition.
eapply lt_heap_trans; eauto. red; auto.
eapply gt_heap_trans; eauto. red; auto.
- intuition. eapply gt_heap_trans; eauto. red; auto.
- rewrite e3 in *; simpl in *. intuition.
eapply lt_heap_trans with y; eauto. red; auto.
eapply gt_heap_trans; eauto. red; auto.
- intuition.
eapply lt_heap_trans with y; eauto. red; auto.
eapply gt_heap_trans; eauto. red; auto.
eapply gt_heap_trans with x; eauto. red; auto.
- rewrite e3 in *; simpl in *; intuition.
eapply gt_heap_trans; eauto. red; auto.
eapply gt_heap_trans; eauto. red; auto.
Qed.

Lemma partition_bst:
forall pivot h,
bst h ->
bst (fst (partition pivot h)) /\ bst (snd (partition pivot h)).
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.partition_bst".
intros pivot h0. functional induction (partition pivot h0); simpl; try tauto.
- rewrite e3 in *; simpl in *. intuition.
apply lt_heap_trans with x; auto. red; auto.
generalize (partition_gt y pivot b2 H7). rewrite e3; simpl. tauto.
- rewrite e3 in *; simpl in *. intuition.
generalize (partition_gt x pivot b1 H3). rewrite e3; simpl. tauto.
generalize (partition_lt y pivot b1 H4). rewrite e3; simpl. tauto.
- rewrite e3 in *; simpl in *. intuition.
generalize (partition_gt y pivot a2 H6). rewrite e3; simpl. tauto.
generalize (partition_lt x pivot a2 H8). rewrite e3; simpl. tauto.
- rewrite e3 in *; simpl in *. intuition.
generalize (partition_lt y pivot a1 H3). rewrite e3; simpl. tauto.
apply gt_heap_trans with x; auto. red; auto.
Qed.

Lemma insert_bst:
forall x h, bst h -> bst (insert x h).
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.insert_bst".
intros.
unfold insert. case_eq (partition x h). intros a b EQ; simpl.
generalize (partition_bst x h H).
generalize (partition_split x h H).
rewrite EQ; simpl. tauto.
Qed.

Lemma In_insert:
forall x h y, bst h -> (In y (insert x h) <-> E.eq y x \/ In y h).
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.In_insert".
intros. unfold insert.
case_eq (partition x h). intros a b EQ; simpl.
assert (E.eq y x \/ ~E.eq y x).
destruct (E.compare y x); auto.
right; red; intros. elim (E.lt_not_eq l). apply E.eq_sym; auto.
destruct H0.
tauto.
generalize (In_partition y x H0 h H). rewrite EQ; simpl. tauto.
Qed.

Lemma deleteMin_lt:
forall x h, lt_heap h x -> lt_heap (deleteMin h) x.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.deleteMin_lt".
Opaque deleteMin.
intros x h0. functional induction (deleteMin h0) ; simpl; intros.
auto.
tauto.
tauto.
intuition. apply IHh. simpl. tauto.
Qed.

Lemma deleteMin_bst:
forall h, bst h -> bst (deleteMin h).
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.deleteMin_bst".
intros h0. functional induction (deleteMin h0); simpl; intros.
auto.
tauto.
tauto.
intuition.
apply IHh. simpl; auto.
apply deleteMin_lt; auto. simpl; auto.
apply gt_heap_trans with y; auto. red; auto.
Qed.

Lemma In_deleteMin:
forall y x h,
findMin h = Some x ->
(In y h <-> E.eq y x \/ In y (deleteMin h)).
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.In_deleteMin".
Transparent deleteMin.
intros y x h0. functional induction (deleteMin h0); simpl; intros.
discriminate.
inv H. tauto.
inv H. tauto.
destruct _x. inv H. simpl. tauto. generalize (IHh H). simpl. tauto.
Qed.

Lemma gt_heap_In:
forall x y h, gt_heap h x -> In y h -> E.lt x y.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.gt_heap_In".
induction h; simpl; intros.
contradiction.
intuition. apply lt_le_trans with x0; auto. red. left. apply E.eq_sym; auto.
Qed.

Lemma findMin_min:
forall x h, findMin h = Some x -> bst h -> forall y, In y h -> le x y.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.findMin_min".
induction h; simpl; intros.
contradiction.
destruct h1.
inv H. simpl in *. intuition.
red; left; apply E.eq_sym; auto.
red; right. eapply gt_heap_In; eauto.
assert (le x x1).
apply IHh1; auto. tauto. simpl. right; left; apply E.eq_refl.
intuition.
apply le_trans with x1. auto.  apply le_trans with x0. simpl in H4. red; tauto.
red; left; apply E.eq_sym; auto.
apply le_trans with x1. auto. apply le_trans with x0. simpl in H4. red; tauto.
red; right. eapply gt_heap_In; eauto.
Qed.

Lemma findMin_empty:
forall h, h <> Empty -> findMin h <> None.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.findMin_empty".
induction h; simpl; intros.
congruence.
destruct h1. congruence. apply IHh1. congruence.
Qed.

Lemma deleteMax_gt:
forall x h, gt_heap h x -> gt_heap (deleteMax h) x.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.deleteMax_gt".
Opaque deleteMax.
intros x h0. functional induction (deleteMax h0); simpl; intros.
auto.
tauto.
tauto.
intuition. apply IHh. simpl. tauto.
Qed.

Lemma deleteMax_bst:
forall h, bst h -> bst (deleteMax h).
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.deleteMax_bst".
intros h0. functional induction (deleteMax h0); simpl; intros.
auto.
tauto.
tauto.
intuition.
apply IHh. simpl; auto.
apply lt_heap_trans with x; auto. red; auto.
apply deleteMax_gt; auto. simpl; auto.
Qed.

Lemma In_deleteMax:
forall y x h,
findMax h = Some x ->
(In y h <-> E.eq y x \/ In y (deleteMax h)).
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.In_deleteMax".
Transparent deleteMax.
intros y x h0. functional induction (deleteMax h0); simpl; intros.
congruence.
inv H. tauto.
inv H. tauto.
destruct _x1. inv H. simpl. tauto. generalize (IHh H). simpl. tauto.
Qed.

Lemma lt_heap_In:
forall x y h, lt_heap h x -> In y h -> E.lt y x.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.lt_heap_In".
induction h; simpl; intros.
contradiction.
intuition. apply le_lt_trans with x0; auto. red. left. assumption.
Qed.

Lemma findMax_max:
forall x h, findMax h = Some x -> bst h -> forall y, In y h -> le y x.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.findMax_max".
induction h; simpl; intros.
contradiction.
destruct h2.
inv H. simpl in *. intuition.
red; right. eapply lt_heap_In; eauto.
red; left. auto.
assert (le x1 x).
apply IHh2; auto. tauto. simpl. right; left; apply E.eq_refl.
intuition.
apply le_trans with x1; auto.  apply le_trans with x0.
red; right. eapply lt_heap_In; eauto.
simpl in H6. red; tauto.
apply le_trans with x1; auto. apply le_trans with x0.
red; auto.
simpl in H6. red; tauto.
Qed.

Lemma findMax_empty:
forall h, h <> Empty -> findMax h <> None.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.R.findMax_empty".
induction h; simpl; intros.
congruence.
destruct h2. congruence. apply IHh2. congruence.
Qed.

End R.

Definition t := { h: R.heap | R.bst h }.

Program Definition empty : t := R.Empty.

Program Definition insert (x: E.t) (h: t) : t := R.insert x h.
Next Obligation. apply R.insert_bst. apply proj2_sig. Qed.

Program Definition findMin (h: t) : option E.t := R.findMin h.

Program Definition deleteMin (h: t) : t := R.deleteMin h.
Next Obligation. apply R.deleteMin_bst. apply proj2_sig. Qed.

Program Definition findMax (h: t) : option E.t := R.findMax h.

Program Definition deleteMax (h: t) : t := R.deleteMax h.
Next Obligation. apply R.deleteMax_bst. apply proj2_sig. Qed.

Program Definition In (x: E.t) (h: t) : Prop := R.In x h.

Lemma In_empty: forall x, ~In x empty.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.In_empty".
intros; red; intros.
red in H. simpl in H. tauto.
Qed.

Lemma In_insert:
forall x h y,
In y (insert x h) <-> E.eq y x \/ In y h.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.In_insert".
intros. unfold In, insert; simpl. apply R.In_insert. apply proj2_sig.
Qed.

Lemma findMin_empty:
forall h y, findMin h = None -> ~In y h.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.findMin_empty".
unfold findMin, In; intros; simpl.
destruct (proj1_sig h).
simpl. tauto.
exploit R.findMin_empty; eauto. congruence.
Qed.

Lemma findMin_min:
forall h x y, findMin h = Some x -> In y h -> E.eq x y \/ E.lt x y.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.findMin_min".
unfold findMin, In; simpl. intros.
change (R.le x y). eapply R.findMin_min; eauto. apply proj2_sig.
Qed.

Lemma In_deleteMin:
forall h x y,
findMin h = Some x ->
(In y h <-> E.eq y x \/ In y (deleteMin h)).
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.In_deleteMin".
unfold findMin, In; simpl; intros.
apply R.In_deleteMin. auto.
Qed.

Lemma findMax_empty:
forall h y, findMax h = None -> ~In y h.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.findMax_empty".
unfold findMax, In; intros; simpl.
destruct (proj1_sig h).
simpl. tauto.
exploit R.findMax_empty; eauto. congruence.
Qed.

Lemma findMax_max:
forall h x y, findMax h = Some x -> In y h -> E.eq y x \/ E.lt y x.
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.findMax_max".
unfold findMax, In; simpl. intros.
change (R.le y x). eapply R.findMax_max; eauto. apply proj2_sig.
Qed.

Lemma In_deleteMax:
forall h x y,
findMax h = Some x ->
(In y h <-> E.eq y x \/ In y (deleteMax h)).
Proof. hammer_hook "Heaps" "Heaps.SplayHeapSet.In_deleteMax".
unfold findMax, In; simpl; intros.
apply R.In_deleteMax. auto.
Qed.

End SplayHeapSet.

Module PHeap := SplayHeapSet(OrderedPositive).


Require Export P04.

Lemma merge_sorted fuel l1 l2
      (FUEL: fuel >= length l1 + length l2)
      (SORTED1: sorted l1) (SORTED2: sorted l2):
  sorted (merge' fuel l1 l2).
Proof. exact FILL_IN_HERE. Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Compare_dec.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import Le.
Require Import Lt.
Require Import Gt.
Require Import Decidable.

Open Local Scope nat_scope.

Implicit Types m n x y : nat.

Definition zerop n : {n = 0} + {0 < n}.
Proof.
  destruct n; auto with arith.
Defined.

Definition lt_eq_lt_dec : forall n m, {n < m} + {n = m} + {m < n}.
Proof.
  induction n; destruct m; auto with arith.
  destruct (IHn m) as [H|H]; auto with arith.
  destruct H; auto with arith.
Defined.

Definition gt_eq_gt_dec : forall n m, {m > n} + {n = m} + {n > m}.
Proof.
  intros; apply lt_eq_lt_dec; assumption.
Defined.

Definition le_lt_dec : forall n m, {n <= m} + {m < n}.
Proof.
  induction n.
  auto with arith.
  destruct m.
  auto with arith.
  elim (IHn m); auto with arith.
Defined.

Definition le_le_S_dec n m : {n <= m} + {S m <= n}.
Proof.
  intros; exact (le_lt_dec n m).
Defined.

Definition le_ge_dec n m : {n <= m} + {n >= m}.
Proof.
  intros; elim (le_lt_dec n m); auto with arith.
Defined.

Definition le_gt_dec n m : {n <= m} + {n > m}.
Proof.
  intros; exact (le_lt_dec n m).
Defined.

Definition le_lt_eq_dec n m : n <= m -> {n < m} + {n = m}.
Proof.
  intros; destruct (lt_eq_lt_dec n m); auto with arith.
  intros; absurd (m < n); auto with arith.
Defined.

Theorem le_dec : forall n m, {n <= m} + {~ n <= m}.
Proof.
  intros n m. destruct (le_gt_dec n m).
   auto with arith.
   right. apply gt_not_le. assumption.
Defined.

Theorem lt_dec : forall n m, {n < m} + {~ n < m}.
Proof.
  intros; apply le_dec.
Defined.

Theorem gt_dec : forall n m, {n > m} + {~ n > m}.
Proof.
  intros; apply lt_dec.
Defined.

Theorem ge_dec : forall n m, {n >= m} + {~ n >= m}.
Proof.
  intros; apply le_dec.
Defined.

(** Proofs of decidability *)

Theorem dec_le : forall n m, decidable (n <= m).
Proof.
  intros n m; destruct (le_dec n m); unfold decidable; auto.
Qed.

Theorem dec_lt : forall n m, decidable (n < m).
Proof.
  intros; apply dec_le.
Qed.

Theorem dec_gt : forall n m, decidable (n > m).
Proof.
  intros; apply dec_lt.
Qed.

Theorem dec_ge : forall n m, decidable (n >= m).
Proof.
  intros; apply dec_le.
Qed.

Theorem not_eq : forall n m, n <> m -> n < m \/ m < n.
Proof.
  intros x y H; elim (lt_eq_lt_dec x y);
    [ intros H1; elim H1;
      [ auto with arith | intros H2; absurd (x = y); assumption ]
      | auto with arith ].
Qed.

Theorem not_le : forall n m, ~ n <= m -> n > m.
Proof.
  intros x y H; elim (le_gt_dec x y);
    [ intros H1; absurd (x <= y); assumption | trivial with arith ].
Qed.

Theorem not_gt : forall n m, ~ n > m -> n <= m.
Proof.
  intros x y H; elim (le_gt_dec x y);
    [ trivial with arith | intros H1; absurd (x > y); assumption ].
Qed.

Theorem not_ge : forall n m, ~ n >= m -> n < m.
Proof.
  intros x y H; exact (not_le y x H).
Qed.

Theorem not_lt : forall n m, ~ n < m -> n >= m.
Proof.
  intros x y H; exact (not_gt y x H).
Qed.

(** A ternary comparison function in the spirit of [Zcompare]. *)

Fixpoint nat_compare n m :=
  match n, m with
   | O, O => Eq
   | O, S _ => Lt
   | S _, O => Gt
   | S n', S m' => nat_compare n' m'
  end.

Lemma nat_compare_S : forall n m, nat_compare (S n) (S m) = nat_compare n m.
Proof.
 reflexivity.
Qed.

Lemma nat_compare_eq_iff : forall n m, nat_compare n m = Eq <-> n = m.
Proof.
  induction n; destruct m; simpl; split; auto; try discriminate;
   destruct (IHn m); auto.
Qed.

Lemma nat_compare_eq : forall n m, nat_compare n m = Eq -> n = m.
Proof.
  intros; apply -> nat_compare_eq_iff; auto.
Qed.

Lemma nat_compare_lt : forall n m, n<m <-> nat_compare n m = Lt.
Proof.
  induction n; destruct m; simpl; split; auto with arith;
   try solve [inversion 1].
  destruct (IHn m); auto with arith.
  destruct (IHn m); auto with arith.
Qed.

Lemma nat_compare_gt : forall n m, n>m <-> nat_compare n m = Gt.
Proof.
  induction n; destruct m; simpl; split; auto with arith;
   try solve [inversion 1].
  destruct (IHn m); auto with arith.
  destruct (IHn m); auto with arith.
Qed.

Lemma nat_compare_le : forall n m, n<=m <-> nat_compare n m <> Gt.
Proof.
  split.
  intros LE; contradict LE.
   apply lt_not_le. apply <- nat_compare_gt; auto.
  intros NGT. apply not_lt. contradict NGT.
   apply -> nat_compare_gt; auto.
Qed.

Lemma nat_compare_ge : forall n m, n>=m <-> nat_compare n m <> Lt.
Proof.
  split.
  intros GE; contradict GE.
   apply lt_not_le. apply <- nat_compare_lt; auto.
  intros NLT. apply not_lt. contradict NLT.
   apply -> nat_compare_lt; auto.
Qed.

Lemma nat_compare_spec : forall x y, CompSpec eq lt x y (nat_compare x y).
Proof.
 intros.
 destruct (nat_compare x y) as [ ]_eqn; constructor.
 apply nat_compare_eq; auto.
 apply <- nat_compare_lt; auto.
 apply <- nat_compare_gt; auto.
Qed.

(** Some projections of the above equivalences. *)

Lemma nat_compare_Lt_lt : forall n m, nat_compare n m = Lt -> n<m.
Proof.
  intros; apply <- nat_compare_lt; auto.
Qed.

Lemma nat_compare_Gt_gt : forall n m, nat_compare n m = Gt -> n>m.
Proof.
  intros; apply <- nat_compare_gt; auto.
Qed.

(** A previous definition of [nat_compare] in terms of [lt_eq_lt_dec].
    The new version avoids the creation of proof parts. *)

Definition nat_compare_alt (n m:nat) :=
  match lt_eq_lt_dec n m with
    | inleft (left _) => Lt
    | inleft (right _) => Eq
    | inright _ => Gt
  end.

Lemma nat_compare_equiv: forall n m,
 nat_compare n m = nat_compare_alt n m.
Proof.
  intros; unfold nat_compare_alt; destruct lt_eq_lt_dec as [[LT|EQ]|GT].
  apply -> nat_compare_lt; auto.
  apply <- nat_compare_eq_iff; auto.
  apply -> nat_compare_gt; auto.
Qed.

(** A boolean version of [le] over [nat]. *)

Fixpoint leb (m:nat) : nat -> bool :=
  match m with
    | O => fun _:nat => true
    | S m' =>
      fun n:nat => match n with
                     | O => false
                     | S n' => leb m' n'
                   end
  end.

Lemma leb_correct : forall m n, m <= n -> leb m n = true.
Proof.
  induction m as [| m IHm]. trivial.
  destruct n. intro H. elim (le_Sn_O _ H).
  intros. simpl in |- *. apply IHm. apply le_S_n. assumption.
Qed.

Lemma leb_complete : forall m n, leb m n = true -> m <= n.
Proof.
  induction m. trivial with arith.
  destruct n. intro H. discriminate H.
  auto with arith.
Qed.

Lemma leb_iff : forall m n, leb m n = true <-> m <= n.
Proof.
  split; auto using leb_correct, leb_complete.
Qed.

Lemma leb_correct_conv : forall m n, m < n -> leb n m = false.
Proof.
  intros.
  generalize (leb_complete n m).
  destruct (leb n m); auto.
  intros; elim (lt_not_le m n); auto.
Qed.

Lemma leb_complete_conv : forall m n, leb n m = false -> m < n.
Proof.
  intros m n EQ. apply not_le.
  intro LE. apply leb_correct in LE. rewrite LE in EQ; discriminate.
Qed.

Lemma leb_iff_conv : forall m n, leb n m = false <-> m < n.
Proof.
  split; auto using leb_complete_conv, leb_correct_conv.
Qed.

Lemma leb_compare : forall n m, leb n m = true <-> nat_compare n m <> Gt.
Proof.
 split; intros.
 apply -> nat_compare_le. auto using leb_complete.
 apply leb_correct. apply <- nat_compare_le; auto.
Qed.


Require Import ssreflect ssrbool eqtype ssrnat.

Section HilbertSaxiom.

Variables A B C : Prop.

Lemma HilbertS : (A -> B -> C) -> (A -> B) -> A -> C.
Proof.
  intros.
  apply H.
    exact H1.
  apply H0.
  exact H1.
Qed.

End HilbertSaxiom.


(* * Machine for comparing two [positive] binary numbers *)

From Undecidability.TM Require Import ProgrammingTools.
From Undecidability Require Import EncodeBinNumbers PosDefinitions PosPointers PosHelperMachines.

(* Declare discreteness of [comparison] *)
Global Instance comparison_eq_dec : eq_dec comparison.
Proof.
  intros. hnf. decide equality.
Defined. (* because definition *)

(* Declare finiteness of [comparison] *)
Global Instance comparison_finC : finTypeC (EqType comparison).
Proof.
  apply (FinTypeC (enum := [Eq; Lt; Gt])).
  intros []; now cbv.
Qed.

Global Instance comparison_inhabited : inhabitedC comparison.
Proof. repeat constructor. Qed.

(* Thankfully, [Pos.compare] is already defined tail-recursively. We store the acku [r:comparison] in the state using [StateWhile]. *)

Definition Compare_Step_Rel (r : comparison) : pRel sigPos^+ (comparison+comparison) 2 :=
  fun tin '(yout, tout) =>
    (forall (p0 : positive) (b0 : bool) (bits0 : list bool) (p1 : positive) (b1 : bool) (bits1 : list bool),
        atBit tin[@Fin0] p0 b0 bits0 ->
        atBit tin[@Fin1] p1 b1 bits1 ->
        match yout, b0, b1 with
        | inl r',  true,  true =>
          movedToLeft tout[@Fin0] p0 b0 bits0 /\
          movedToLeft tout[@Fin1] p1 b1 bits1 /\
          r' = r
        | inl Gt, true,  false =>
          movedToLeft tout[@Fin0] p0 b0 bits0 /\
          movedToLeft tout[@Fin1] p1 b1 bits1
        | inl Lt, false, true =>
          movedToLeft tout[@Fin0] p0 b0 bits0 /\
          movedToLeft tout[@Fin1] p1 b1 bits1
        | inl r',  false, false =>
          movedToLeft tout[@Fin0] p0 b0 bits0 /\
          movedToLeft tout[@Fin1] p1 b1 bits1 /\
          r' = r
        | _, _, _ => False
        end) /\
    (forall (p0 : positive) (b0 : bool) (bits0 : list bool) (p1 : positive),
        atBit tin[@Fin0] p0 b0 bits0 ->
        atHSB tin[@Fin1] p1 ->
        yout = inr Gt /\
        atHSB tout[@Fin0] (append_bits p0 (b0 :: bits0)) /\
        atHSB tout[@Fin1] p1) /\
    (forall (p0 : positive) (p1 : positive) (b1 : bool) (bits1 : list bool),
        atHSB tin[@Fin0] p0 ->
        atBit tin[@Fin1] p1 b1 bits1 ->
        yout = inr Lt /\
        atHSB tout[@Fin0] p0 /\
        atHSB tout[@Fin1] (append_bits p1 (b1 :: bits1))) /\
    (forall (p0 p1 : positive),
        atHSB tin[@Fin0] p0 ->
        atHSB tin[@Fin1] p1 ->
        tout = tin /\ yout = inr r).

Definition Compare_Step (r : comparison) : pTM sigPos^+ (comparison+comparison) 2 :=
  Switch ReadPosSym2
         (fun '(s0, s1) =>
            match s0, s1 with
            | Some true,  Some  true => Return (SetBitAndMoveLeft true  @[|Fin0|];; SetBitAndMoveLeft  true @[|Fin1|]) (inl r)
            | Some true,  Some false => Return (SetBitAndMoveLeft true  @[|Fin0|];; SetBitAndMoveLeft false @[|Fin1|]) (inl Gt)
            | Some false, Some  true => Return (SetBitAndMoveLeft false @[|Fin0|];; SetBitAndMoveLeft  true @[|Fin1|]) (inl Lt)
            | Some false, Some false => Return (SetBitAndMoveLeft false @[|Fin0|];; SetBitAndMoveLeft false @[|Fin1|]) (inl r)
            | Some _,     None       => Return (GoToHSB @[|Fin0|]) (inr Gt)
            | None  ,     Some b     => Return (GoToHSB @[|Fin1|]) (inr Lt)
            | None  ,     None       => Return Nop (inr r)
            end).

Lemma Compare_Step_Realise (r : comparison) : Compare_Step r ⊨ Compare_Step_Rel r.
Proof.
  eapply Realise_monotone.
  { unfold Compare_Step. cbn.
    (* [TM_Correct] actually should do this automatically *)
    eapply Switch_Realise
      with (R2 := fun '(s0, s1) => match s0, s1 with
                                | Some b0, Some b1 => match b0, b1 with
                                                     | true, true => _
                                                     | true, false => _
                                                     | false, true => _
                                                     | false, false => _
                                                     end
                                | Some b0, None => _ | None, Some b1 => _ | None, None => _ end).
    - eapply RealiseIn_Realise. apply ReadPosSym2_Sem.
    - intros [s0 s1]. cbn. destruct s0 as [ b0 | ], s1 as [ b1 | ]; cbn; TM_Correct.
      + destruct b0, b1; TM_Correct; eapply RealiseIn_Realise, SetBitAndMoveLeft_Sem.
      + destruct b0; TM_Correct; apply GoToHSB_Realise.
      + destruct b1; TM_Correct; apply GoToHSB_Realise. }
  {
    intros tin (yout, tout) H. TMSimp.
    rename H into HReadSym1, H1 into HReadSym2, H2 into HReadSym3, H3 into HReadSym4. rename H0 into HSwitch. rename o into s0, o0 into s1.
    split; [ | split; [ | split ] ]; auto.
    - intros. modpon HReadSym1. clear HReadSym2 HReadSym3 HReadSym4.
      destruct s0 as [ b0' | ], s1 as [ b1' | ]; cbn in *; auto.
      + destruct b0' eqn:Eb0', b1' eqn:Eb1', b0, b1; TMSimp; eauto.
        all: destruct r; cbn; eauto.
      + destruct b0'; auto.
    - intros. modpon HReadSym2. clear HReadSym1 HReadSym3 HReadSym4.
      destruct s0 as [ b0' | ], s1 as [ b1' | ]; cbn in *; auto.
      + destruct b0' eqn:Eb0', b1' eqn:Eb1', b0; TMSimp; eauto.
      + TMSimp. destruct b0'; auto.
        * destruct b0; auto. split; eauto. TMSimp. modpon H2. auto.
        * destruct b0; auto. split; eauto. TMSimp. modpon H2. auto.
    - intros. modpon HReadSym3. clear HReadSym1 HReadSym2 HReadSym4.
      destruct s0 as [ b0' | ], s1 as [ b1' | ]; cbn in *; auto.
      TMSimp. destruct b1' eqn:Eb1', b1; TMSimp; eauto.
      * modpon H2. repeat split; eauto.
      * modpon H2. repeat split; eauto.
    - intros. modpon HReadSym4. clear HReadSym1 HReadSym2 HReadSym3.
      destruct s0 as [ b0' | ]; eauto; try inv_pair. TMSimp. auto.
  }
Qed.

Definition Compare_Loop : comparison -> pTM sigPos^+ comparison 2 := StateWhile Compare_Step.

Definition Compare_Loop_Rel (r : comparison) : pRel sigPos^+ comparison 2 :=
  fun tin '(yout, tout) =>
    (forall (p0 : positive) (b0 : bool) (bits0 : list bool) (p1 : positive) (b1 : bool) (bits1 : list bool),
        atBit tin[@Fin0] p0 b0 bits0 ->
        atBit tin[@Fin1] p1 b1 bits1 ->
        atHSB tout[@Fin0] (append_bits p0 (b0 :: bits0)) /\
        atHSB tout[@Fin1] (append_bits p1 (b1 :: bits1)) /\
        yout = Pos.compare_cont r (p0 ~~ b0) (p1 ~~ b1)) /\
    (forall (p0 : positive) (b0 : bool) (bits0 : list bool) (p1 : positive),
        atBit tin[@Fin0] p0 b0 bits0 ->
        atHSB tin[@Fin1] p1 ->
        atHSB tout[@Fin0] (append_bits p0 (b0 :: bits0)) /\
        atHSB tout[@Fin1] p1 /\
        yout = Gt) /\
    (forall (p0 : positive) (p1 : positive) (b1 : bool) (bits1 : list bool),
        atHSB tin[@Fin0] p0 ->
        atBit tin[@Fin1] p1 b1 bits1 ->
        atHSB tout[@Fin0] p0 /\
        atHSB tout[@Fin1] (append_bits p1 (b1 :: bits1)) /\
        yout = Lt) /\
    (forall (p0 p1 : positive),
        atHSB tin[@Fin0] p0 ->
        atHSB tin[@Fin1] p1 ->
        tout = tin /\ yout = r).

Lemma Compare_Loop_Realise (r : comparison) : Compare_Loop r ⊨ Compare_Loop_Rel r.
Proof.
  eapply Realise_monotone.
  { unfold Compare_Loop. TM_Correct. exact Compare_Step_Realise. }
  {
    apply StateWhileInduction; intros.
    {
      cbn in *. destruct HLastStep as (HLastStepA&HLastStepB&HLastStepC&HLastStepD). split; [ | split; [ | split ]].
      - intros. modpon HLastStepA. auto.
      - intros. modpon HLastStepB. inv HLastStepB. repeat split; eauto.
      - intros. modpon HLastStepC. inv HLastStepC. repeat split; eauto.
      - intros. modpon HLastStepD. inv HLastStepD0. repeat split; eauto.
    }
    {
      cbn in *. destruct HLastStep as (HLastStepA&HLastStepB&HLastStepC&HLastStepD). destruct HStar as (HStarA&HStarB&HStarC&HStarD). split; [ | split; [ | split ]].
      - intros. modpon HStarA.
        destruct l'; cbn in *; eauto.
        + destruct b0, b1; cbn in *; eauto.
          * modpon HStarA; TMSimp.
            destruct p0, p1; cbn in *; eauto.
            all: solve [modpon HLastStepA; [ TMSimp; auto ] | modpon HLastStepB; [ TMSimp; auto ]
                        | modpon HLastStepC; [ TMSimp; auto ] | modpon HLastStepD; [ TMSimp; auto ]].
          * modpon HStarA; TMSimp.
            destruct p0, p1; cbn in *; eauto.
            all: solve [ modpon HLastStepA; [ TMSimp; auto ] | modpon HLastStepB; [ TMSimp; auto ]
                       | modpon HLastStepC; [ TMSimp; auto ] | modpon HLastStepD; [ TMSimp; auto ]].
        + destruct b0, b1; cbn in *; eauto.
          * modpon HStarA; TMSimp.
            destruct p0, p1; cbn in *; eauto.
            all: solve [ modpon HLastStepA; [ TMSimp; auto ] | modpon HLastStepB; [ TMSimp; auto ]
                       | modpon HLastStepC; [ TMSimp; auto ] | modpon HLastStepD; [ TMSimp; auto ]].
          * modpon HStarA; TMSimp.
            destruct p0, p1; cbn in *; eauto.
            all: solve [ modpon HLastStepA; [ TMSimp; auto ] | modpon HLastStepB; [ TMSimp; auto ]
                       | modpon HLastStepC; [ TMSimp; auto ] | modpon HLastStepD; [ TMSimp; auto ]].
          * modpon HStarA; TMSimp.
            destruct p0, p1; cbn in *; eauto.
            all: solve [ modpon HLastStepA; [ TMSimp; auto ] | modpon HLastStepB; [ TMSimp; auto ]
                       | modpon HLastStepC; [ TMSimp; auto ] | modpon HLastStepD; [ TMSimp; auto ]].
        + destruct b0, b1; cbn in *; eauto.
          * modpon HStarA; TMSimp.
            destruct p0, p1; cbn in *; eauto.
            all: solve [ modpon HLastStepA; [ TMSimp; auto ] | modpon HLastStepB; [ TMSimp; auto ]
                       | modpon HLastStepC; [ TMSimp; auto ] | modpon HLastStepD; [ TMSimp; auto ]].
          * modpon HStarA; TMSimp.
            destruct p0, p1; cbn in *; eauto.
            all: solve [ modpon HLastStepA; [ TMSimp; auto ] | modpon HLastStepB; [ TMSimp; auto ]
                       | modpon HLastStepC; [ TMSimp; auto ] | modpon HLastStepD; [ TMSimp; auto ]].
          * modpon HStarA; TMSimp.
            destruct p0, p1; cbn in *; eauto.
            all: solve [ modpon HLastStepA; [ TMSimp; auto ] | modpon HLastStepB; [ TMSimp; auto ]
                       | modpon HLastStepC; [ TMSimp; auto ] | modpon HLastStepD; [ TMSimp; auto ]].
      - intros. modpon HStarB. congruence.
      - intros. modpon HStarC. congruence.
      - intros. modpon HStarD. congruence.
    }
  }
Qed.

Definition Compare := GoToLSB_start@[|Fin0|];; GoToLSB_start@[|Fin1|];;
                       Switch (Compare_Loop Eq) (fun (r : comparison) => Return ((Move Lmove)@[|Fin0|];; (Move Lmove)@[|Fin1|]) r).

Definition Compare_Rel : pRel sigPos^+ comparison 2 :=
  fun tin '(yout, tout) =>
    forall (p0 p1 : positive),
      tin[@Fin0] ≃ p0 ->
      tin[@Fin1] ≃ p1 ->
      tout[@Fin0] ≃ p0 /\
      tout[@Fin1] ≃ p1 /\
      yout = Pos.compare p0 p1.

Lemma Compare_Realise : Compare ⊨ Compare_Rel.
Proof.
  eapply Realise_monotone.
  { unfold Compare. TM_Correct.
    - apply GoToLSB_start_Realise.
    - apply GoToLSB_start_Realise.
    - apply Compare_Loop_Realise. }
  {
    intros tin (yout, tout) H. TMSimp. intros.
    rename H2 into HLoopA, H5 into HLoopB, H6 into HLoopC, H7 into HLoopD.
    rename H4 into HSwitch. rename H into HGoToHSB', H0 into HGoToHSB.
    modpon HGoToHSB. modpon HGoToHSB'.
    destruct p0, p1.
    - modpon HLoopA. TMSimp. unfold Pos.compare. destruct (Pos.compare_cont Eq p0 p1); TMSimp; (repeat split; eauto; now apply atHSB_moveLeft_contains).
    - modpon HLoopA. TMSimp. unfold Pos.compare. destruct (Pos.compare_cont Gt p0 p1); TMSimp; (repeat split; eauto; now apply atHSB_moveLeft_contains).
    - modpon HLoopB. TMSimp. unfold Pos.compare. (repeat split; eauto; now apply atHSB_moveLeft_contains).
    - modpon HLoopA. TMSimp. unfold Pos.compare. destruct (Pos.compare_cont Lt p0 p1); TMSimp; (repeat split; eauto; now apply atHSB_moveLeft_contains).
    - modpon HLoopA. TMSimp. unfold Pos.compare. destruct (Pos.compare_cont Eq p0 p1); TMSimp; (repeat split; eauto; now apply atHSB_moveLeft_contains).
    - modpon HLoopB. TMSimp. unfold Pos.compare. (repeat split; eauto; now apply atHSB_moveLeft_contains).
    - modpon HLoopC. TMSimp. unfold Pos.compare. (repeat split; eauto; now apply atHSB_moveLeft_contains).
    - modpon HLoopC. TMSimp. unfold Pos.compare. (repeat split; eauto; now apply atHSB_moveLeft_contains).
    - modpon HLoopD. TMSimp. unfold Pos.compare. (repeat split; eauto; now apply atHSB_moveLeft_contains).
  }
Qed.

(* ** Maximum *)

(* Call [Compare] and copy the maximum to the third tape. *)

Definition Max_Rel : pRel sigPos^+ comparison 3 :=
  fun tin '(yout, tout) =>
    forall (p0 p1 : positive),
      tin[@Fin0] ≃ p0 ->
      tin[@Fin1] ≃ p1 ->
      isVoid tin[@Fin2] ->
      tout[@Fin0] ≃ p0 /\
      tout[@Fin1] ≃ p1 /\
      tout[@Fin2] ≃ Pos.max p0 p1 /\
      yout = Pos.compare p0 p1.

Definition Max : pTM sigPos^+ comparison 3 :=
  Switch (Compare @[|Fin0; Fin1|])
         (fun (c : comparison) =>
            match c with
            | Gt => Return (CopyValue _ @[|Fin0; Fin2|]) c
            | _ =>  Return (CopyValue _ @[|Fin1; Fin2|]) c
            end).

Lemma Max_Realise : Max ⊨ Max_Rel.
Proof.
  eapply Realise_monotone.
  { unfold Max. TM_Correct.
    - apply Compare_Realise.
  }
  {
    intros tin (yout, tout) H. cbn in *. intros p0 p1 Hp0 Hp1 HRight. TMSimp.
    modpon H. destruct ymid.
    - TMSimp. modpon H3. repeat split; eauto. unfold Pos.max. rewrite <- H2. auto.
    - TMSimp. modpon H3. repeat split; eauto. unfold Pos.max. rewrite <- H2. auto.
    - TMSimp. modpon H3. repeat split; eauto. unfold Pos.max. rewrite <- H2. auto.
  }
Qed.


From FA Require Import String DFA NFA NFA2DFA eNFA eNFA2NFA.
From mathcomp Require Import all_ssreflect.

Lemma enfa_dfa_lang_eqi: forall n, enfa_language n =i dfa_language (nfa_dfa (enfa_nfa n)).
Proof. intros.
       unfold enfa_language, nfa_language, dfa_language.
       move => y. apply/idP/idP => /=.
         intro Ha.
         rewrite inE in Ha.
         rewrite inE.
         rewrite <- enfa_nfa_acc_eq in Ha.
         rewrite nfa_dfa_acc_eq in Ha.
         easy.

         intro Ha.
         rewrite inE in Ha.
         rewrite inE.
         rewrite <- enfa_nfa_acc_eq.
         rewrite nfa_dfa_acc_eq.
         easy.
Qed.


Require Import provable.

(* f is a decider for p                                                         *)
Definition Decider (a:Type) (f:a -> bool) (p:a -> Prop) : Prop :=
    forall (x:a), p x <-> f x = true.

Arguments Decider {a}.

Definition Decidable (a:Type) (p:a -> Prop) : Prop :=
    exists (f:a -> bool), Decider f p.

Arguments Decidable {a}.

Definition Decider_ (b:bool) (X:Prop) : Prop :=
    X <-> b = true.

Definition Decidable_ (X:Prop) : Prop :=
    exists (b:bool), Decider_ b X.

Lemma L1 : forall (a:Type) (p:a -> Prop) (f:a -> bool),
    Decider f p <-> forall (x:a), Decider_ (f x) (p x).
Proof.
    unfold Decider, Decider_. intros a p f. split; auto.
Qed.

Lemma L2 : forall (a:Type) (p:a -> Prop),
    Decidable p -> forall (x:a), Decidable_ (p x).
Proof.
    unfold Decidable, Decidable_, Decider, Decider_.
    intros a p [f H1] x. exists (f x). apply H1.
Qed.

Lemma L3 : forall (X:Prop),
    Decidable_ X <-> exists (q:{X} + {~X}), True.
Proof.
    unfold Decidable_, Decider_. intros X. split.
    - intros [b H1]. destruct H1 as [H1 H2]. destruct b.
        + assert X as H3. { apply H2. reflexivity. } exists (left H3). trivial.
        + assert (~X) as H3. { intros H3. apply H1 in H3. inversion H3. }
          exists (right H3). trivial.
    - intros [q _]. destruct q as [H1|H1].
        + exists true. split; intros H2.
            { reflexivity. }
            { assumption. }
        + exists false. split; intros H2.
            { exfalso. apply H1. assumption. }
            { inversion H2. }
Qed.

Definition L4 (X:Prop) (b:bool) (p:X <-> b = true) : { X } + {~ X}.
Proof.
    destruct p as [H1 H2]. destruct b.
    - left. apply H2. reflexivity.
    - right.  intros H3. apply H1 in H3. inversion H3.
Defined.

Arguments L4 {X} {b}.

Lemma L5 : forall (a:Type) (p:a -> Prop),
    Decidable p <-> exists (q:forall (x:a), {p x} + {~p x}), True.
Proof.
    unfold Decidable, Decider. intros a p. split.
    - intros [f H1]. exists (fun (x:a) => L4 (H1 x)). trivial.
    - intros [q _ ]. exists (fun (x:a) =>
        match q x with
        | left _  => true
        | right _ => false
        end).
      intros x. destruct (q x) as [H1|H1].
        + split.
            { intros. reflexivity. }
            { intros. assumption. }
        + split.
            { intros H2. exfalso. apply H1. assumption. }
            { intros H2. inversion H2. }
Qed.

Lemma L6 : forall (a:Type) (p:a -> Prop),
    Decidable p -> Decidable (fun x => ~p x).
Proof.
    intros a p. unfold Decidable, Decider. intros [f H1].
    exists (fun x => negb (f x)). intros x. unfold negb. split; intros H2.
    - destruct (f x) eqn:E.
        + apply H1 in E. apply H2 in E. contradiction.
        + reflexivity.
    - destruct (f x) eqn:E.
        + inversion H2.
        + intros H3. apply H1 in H3. rewrite H3 in E. inversion E.
Qed.

Lemma L7 : forall (a:Type) (p q:a -> Prop),
    Decidable p -> Decidable q -> Decidable (fun x => p x -> q x).
Proof.
    intros a p q. unfold Decidable, Decider. intros [f1 H1] [f2 H2].
    exists (fun x => orb (negb (f1 x)) (f2 x)). intros x. unfold negb, orb.
    split; intros H3.
    - destruct (f1 x) eqn:E1; destruct (f2 x) eqn:E2.
        + reflexivity.
        + apply H1 in E1. apply H3 in E1. apply H2 in E1. rewrite E1 in E2.
          inversion E2.
        + reflexivity.
        + reflexivity.
    - destruct (f1 x) eqn:E1; destruct (f2 x) eqn:E2; intros H4; apply H2.
        + assumption.
        + inversion H3.
        + assumption.
        + apply H1 in H4. rewrite E1 in H4. inversion H4.
Qed.

Lemma L8 : forall (a:Type) (p q:a -> Prop),
    Decidable p -> Decidable q -> Decidable (fun x => p x /\ q x).
Proof.
    intros a p q. unfold Decidable, Decider. intros [f1 H1] [f2 H2].
    exists (fun x => andb (f1 x) (f2 x)). intros x. unfold andb.
    split; intros H3.
    - destruct (f1 x) eqn:E1; destruct (f2 x) eqn:E2.
        + reflexivity.
        + destruct H3 as [H3 H4]. apply H2 in H4. rewrite E2 in H4. inversion H4.
        + destruct H3 as [H3 H4]. apply H1 in H3. rewrite E1 in H3. inversion H3.
        + destruct H3 as [H3 H4]. apply H1 in H3. rewrite E1 in H3. inversion H3.
    - destruct (f1 x) eqn:E1; destruct (f2 x) eqn:E2; split.
        + apply H1. assumption.
        + apply H2. assumption.
        + inversion H3.
        + inversion H3.
        + inversion H3.
        + apply H2. assumption.
        + inversion H3.
        + inversion H3.
Qed.

Lemma L9 : forall (a:Type) (p q:a -> Prop),
    Decidable p -> Decidable q -> Decidable (fun x => p x \/ q x).
Proof.
    intros a p q. unfold Decidable, Decider. intros [f1 H1] [f2 H2].
    exists (fun x => orb (f1 x) (f2 x)). intros x. unfold orb.
    split; intros H3.
    - destruct (f1 x) eqn:E1; destruct (f2 x) eqn:E2.
        + reflexivity.
        + reflexivity.
        + reflexivity.
        + destruct H3 as [H3|H3].
            { apply H1 in H3. rewrite E1 in H3. inversion H3. }
            { apply H2 in H3. rewrite E2 in H3. inversion H3. }
    - destruct (f1 x) eqn:E1; destruct (f2 x) eqn:E2.
        + left. apply H1. assumption.
        + left. apply H1. assumption.
        + right. apply H2. assumption.
        + inversion H3.
Qed.

Lemma L10 : forall (a:Type) (p q:a -> Prop) (f:a -> bool),
    (forall (x:a), p x <-> q x) -> Decider f p -> Decider f q.
Proof.
    unfold Decider. intros a p q f H1 H2 x. split; intros H3.
    - apply H2, H1. assumption.
    - apply H1, H2. assumption.
Qed.

Lemma L11 : forall (a:Type) (p:a -> Prop),
    Decidable p -> forall (x:a), p x \/ ~p x.
Proof.
    intros a p. unfold Decidable, Decider. intros [f H1] x. destruct (f x) eqn:E.
    - left. apply H1. assumption.
    - right. intros H2. apply H1 in H2. rewrite E in H2. inversion H2.
Qed.

Lemma L12 : forall (a:Type) (p q:a -> Prop) (f:a -> bool),
    Decider f p -> Decider f q -> forall (x:a), p x <-> q x.
Proof.
    unfold Decider. intros a p q f H1 H2 x. split; intros H3.
    - apply H2, H1. assumption.
    - apply H1, H2. assumption.
Qed.

Definition Satisfiable (f:nat -> bool) : Prop :=
    exists (n:nat), f n = true.

(* Computational omni science                                                   *)

Definition CO : Prop := Decidable (Satisfiable).

Lemma L13 : CO <-> exists (g:(nat -> bool) -> bool), Decider g Satisfiable.
Proof.
    unfold CO, Decidable. split; auto.
Qed.

Lemma L14 : LPO <-> forall (f:nat -> bool), Satisfiable f \/ ~ Satisfiable f.
Proof.
    unfold LPO, Satisfiable. split; auto.
Qed.

Lemma L15 : Markov <-> forall (f:nat -> bool), ~~Satisfiable f -> Satisfiable f.
Proof.
    unfold Markov, Satisfiable. split; intros H1 f H2;
    apply H1; intros H3; apply H2.
    - intros [n H4].
      rewrite (H3 n) in H4. inversion H4.
    - intros n. destruct (f n) eqn:E.
        + exfalso. apply H3. exists n. assumption.
        + reflexivity.
Qed.


Add LoadPath "../general".

Require Import GLS_PSGLS_calcs.
Require Import List.
Export ListNotations.

Require Import genT.
Require Import ddT.
Require Import gen_tacs.
Require Import existsT.
Require Import univ_gen_ext.
Require Import dd_fc.
Require Import PeanoNat.
Require Import Lia.
Require Import GLS_PSGLS_remove_list.
Require Import GLS_PSGLS_list_lems.
Require Import List_lemmasT.

Delimit Scope My_scope with M.
Open Scope My_scope.
Set Implicit Arguments.

Hypothesis eq_dec_propvar : forall x y : V, {x = y}+{x <> y}.

Lemma eq_dec_nat : forall (n m : nat), (n = m) + (n <> m).
Proof.
induction n.
- destruct m.
  * auto.
  * auto.
- intro m. destruct m.
  * auto.
  * destruct IHn with (m:=m).
    + left. lia.
    + right. lia.
Qed.

Lemma NoDup_incl_lengthT : forall (l l' : list (MPropF V)), NoDup l -> incl l l' ->
          ((length l < length l') + (length l = length l')).
Proof.
induction l.
- intros. destruct l'.
  * right. auto.
  * left. simpl. lia.
- induction l' ; intros.
  * exfalso. assert (In a (a :: l)). apply in_eq. pose (H0 a H1). inversion i.
  * simpl. destruct (eq_dec_form a a0).
    + subst. assert (NoDup l). inversion H. assumption. assert (incl l l').
      unfold incl. intros. assert (In a (a0 :: l)). apply in_cons. assumption.
      apply H0 in H3. inversion H3. subst. exfalso. inversion H. apply H6. assumption. assumption.
      pose (IHl _ H1 H2). destruct s. left. lia. right. lia.
    + destruct (In_dec l a0).
      { destruct (In_dec l' a0).
        - assert (NoDup l). inversion H. assumption. assert (incl l l'). unfold incl.
          intros. assert (In a1 (a :: l)). apply in_cons. assumption. apply H0 in H3.
          inversion H3. subst. assumption. assumption. pose (IHl _ H1 H2). destruct s.
          left. lia. right. lia.
        - assert (NoDup l). inversion H. assumption. assert (incl l (a0 :: l')).
          unfold incl. intros. assert (In a1 (a :: l)). apply in_cons. assumption.
          apply H0 in H3. assumption. assert (In a l'). assert (In a (a :: l)).
          apply in_eq. apply H0 in H3. inversion H3. subst. exfalso. apply n. reflexivity.
          assumption. apply in_split in H3. destruct (eq_dec_nat (length l) (length l')).
          * subst. right. auto.
          * left. destruct H3. destruct H3. subst.
            rewrite app_length. simpl. assert (incl l (a0 :: x ++ x0)). unfold incl.
            intros. assert (In a1 (a :: l)). apply in_cons. assumption. apply H0 in H4.
            inversion H4. subst. apply in_eq. apply in_app_or in H5. destruct H5.
            apply in_cons. apply in_or_app. auto. inversion H5. subst. exfalso. inversion H.
            apply H8. assumption. apply in_cons. apply in_or_app. auto.
            rewrite app_length in n0. simpl in n0.
            pose (IHl _ H1 H3). destruct s.
            + simpl in l0. rewrite app_length in l0. lia.
            + exfalso. apply n0. simpl in e. rewrite app_length in e. lia.  }
      { assert (incl l l'). unfold incl. intros. assert (In a1 (a :: l)). apply in_cons. assumption.
        apply H0 in H2. inversion H2. subst. exfalso. apply f. assumption. assumption.
        assert (NoDup l). inversion H. assumption. pose (IHl _ H2 H1). destruct s.
        - left. lia.
        - right. lia. }
Qed.

(* First, let us define a the second part of our measure. This number is simply
   the number of implication symbols in a sequent.

   To define it, we need to define the number of implications in a formula. *)

Fixpoint n_imp_subformF (A : MPropF V) : nat :=
match A with
 | # P => 0
 | Bot _ => 0
 | Imp B C => 1 + (n_imp_subformF B) + (n_imp_subformF C)
 | Box B => (n_imp_subformF B)
end.

(* With this definition in hand, we can then straightforwardly define the number
   of implications in a list of formulae. *)

Fixpoint n_imp_subformLF (l : list (MPropF V)) : nat :=
match l with
  | [] => 0
  | h :: t => (n_imp_subformF h) + (n_imp_subformLF t)
end.

(* The the definition we were initially looking for can be reached: *)

Definition n_imp_subformS (s : rel (list (MPropF V))) : nat :=
    (n_imp_subformLF (fst s)) + (n_imp_subformLF (snd s)).

(* It is clear that n_imp_subformS counts the occurrences of implications in a
   sequent s. As a consequence, if that number is 0 we know for sure that the
   rules for implication on the left or right cannot be applied upwards on s.
   This is the meaning of the lemma n_imp_subformS_is_0.

   But first we need a preliminary lemma which claims that if an implication is
   in a list, then n_imp_subformLF of that list is higher than one.*)

Lemma In_n_imp_subformLF_is_non_0 (l : list (MPropF V)) :
    forall A B, (In (Imp A B) l) -> (le 1 (n_imp_subformLF l)).
Proof.
intros A B Hin. induction l.
- inversion Hin.
- inversion Hin.
  * subst. simpl. apply Le.le_n_S. apply le_0_n.
  * pose (IHl H). simpl. destruct l0.
    + rewrite Nat.add_1_r. apply Le.le_n_S. apply le_0_n.
    + rewrite <- plus_n_Sm. apply Le.le_n_S. apply le_0_n.
Qed.

Theorem n_imp_subformS_is_0 (s : rel (list (MPropF V))) :
    (n_imp_subformS s) = 0 -> (existsT2 ps, (ImpRRule ps s) + (ImpLRule ps s)) -> False.
Proof.
intros is0 RA. destruct RA. destruct s0.
- inversion i. subst. unfold n_imp_subformS in is0. simpl in is0.
  assert (n_imp_subformLF (Δ0 ++ A → B :: Δ1) = 0). lia.
  assert (In (A → B) (Δ0 ++ A → B :: Δ1)). apply in_or_app. right. apply in_eq.
  pose (In_n_imp_subformLF_is_non_0 (Δ0 ++ A → B :: Δ1) A B H0). lia.
- inversion i. subst.
  assert (In (A → B) (Γ0 ++ A → B :: Γ1)). apply in_or_app. right. apply in_eq.
  pose (In_n_imp_subformLF_is_non_0 (Γ0 ++ A → B :: Γ1) A B H). unfold n_imp_subformS in is0.
  simpl in is0. assert (n_imp_subformLF (Δ0 ++ Δ1) = 0). lia. lia.
Qed.

Lemma n_imp_subformLF_dist_app : forall l1 l2, n_imp_subformLF (l1 ++ l2) =
                                               plus (n_imp_subformLF l1) (n_imp_subformLF l2).
Proof.
induction l1.
- intros. auto.
- intros. simpl. rewrite IHl1. lia.
Qed.

(* Second, we intend to define the notion of usable boxed formulae in a sequent. We also
   prove that if this measure is 0 then no GLR rule can be applied to this sequent.

   In the next definitions our aim is to define the list of all boxed subformulae (not
   occurrences) of all the formulae in a sequent. *)

Fixpoint subform_boxesF (A : MPropF V) : list (MPropF V) :=
match A with
 | # P => nil
 | Bot _ => nil
 | Imp B C => (subform_boxesF B) ++ (remove_list (subform_boxesF B) (subform_boxesF C))
 | Box B => (Box B) :: (subform_boxesF B)
end.

Fixpoint subform_boxesLF (l : list (MPropF V)) : list (MPropF V) :=
match l with
  | nil => nil
  | h :: t => (subform_boxesF h) ++ (remove_list (subform_boxesF h) (subform_boxesLF t))
end.

Definition subform_boxesS (s : rel (list (MPropF V))) : list (MPropF V) :=
  (subform_boxesLF (fst s)) ++ (remove_list (subform_boxesLF (fst s)) (subform_boxesLF (snd s))).

Lemma In_subform_boxesF_box : forall (A B : MPropF V), In A (subform_boxesF B) -> is_boxedT A.
Proof.
unfold is_boxedT. intros A B. generalize dependent A. induction B ; intros.
- simpl in H. destruct H.
- simpl in H. destruct H.
- simpl in H. apply in_app_or in H. destruct H.
  * apply IHB1 in H. assumption.
  * assert (In A (subform_boxesF B2)). apply In_remove_list_In_list in H. assumption.
    apply IHB2 in H0. assumption.
- simpl in H. destruct H. exists B. auto. apply IHB in H. assumption.
Qed.

Lemma In_subform_boxesLF_box : forall (A : MPropF V) l, In A (subform_boxesLF l) -> is_boxedT A.
Proof.
unfold is_boxedT. intros A l. generalize dependent A. induction l ; intros.
- simpl in H. destruct H.
- simpl in H. apply in_app_or in H. destruct H. apply In_subform_boxesF_box in H. assumption.
  apply In_remove_list_In_list in H. apply IHl. assumption.
Qed.

(* Then next lemmas help us reach our goal. *)

Fixpoint length_form (a: MPropF V) : nat :=
match a with
  | # v => 1
  | Bot _ => 1
  | Imp a0 a1 => S (length_form a0 + length_form a1)
  | Box a0 => S (length_form a0)
end.

Lemma S_le_False : forall (n : nat), S n <= n -> False.
Proof.
induction n.
- intro. inversion H.
- intro. apply Le.le_S_n in H. apply IHn. assumption.
Qed.

Lemma in_subform_boxesF_smaller_length_form : forall (A B : MPropF V), In A (subform_boxesF B) ->
                (length_form A <= length_form B).
Proof.
intros A B. generalize dependent A. induction B; intros .
- simpl. inversion H.
- simpl. inversion H.
- simpl. simpl in H. apply in_app_or in H. destruct H.
  * apply IHB1 in H. lia.
  * assert (In A (subform_boxesF B2)). apply In_remove_list_In_list in H. assumption.
    apply IHB2 in H0. lia.
- simpl in H. destruct H. subst. auto. apply IHB in H. simpl. apply le_S. assumption.
Qed.

Lemma contradic_subform_boxesF: forall A l, (l = (subform_boxesF A)) -> (In (Box A) l)  -> False.
Proof.
intros. subst. pose (in_subform_boxesF_smaller_length_form (Box A) A H0).
inversion l.
- apply eq_S_F in H1. assumption.
- simpl in l. apply S_le_False in l. assumption.
Qed.

Lemma NoDup_subform_boxesF : forall A, NoDup (subform_boxesF A).
Proof.
induction A.
- simpl. apply NoDup_nil.
- simpl. apply NoDup_nil.
- simpl. apply add_remove_list_preserve_NoDup. apply IHA1. apply IHA2.
- simpl. apply NoDup_cons. intro. apply contradic_subform_boxesF in H. assumption.
  reflexivity. apply IHA.
Qed.

Lemma subform_boxesLF_dist_app : forall l1 l2,
        (subform_boxesLF (l1 ++ l2)) =
        (subform_boxesLF l1) ++ (remove_list (subform_boxesLF l1) (subform_boxesLF l2)).
Proof.
induction l1.
- intros l2. simpl. reflexivity.
- intros l2. simpl. rewrite IHl1. repeat rewrite <- app_assoc.
  assert (E: remove_list (subform_boxesF a) (subform_boxesLF l1 ++
             remove_list (subform_boxesLF l1) (subform_boxesLF l2)) =
             remove_list (subform_boxesF a) (subform_boxesLF l1) ++
             remove_list (subform_boxesF a ++ remove_list (subform_boxesF a)
             (subform_boxesLF l1)) (subform_boxesLF l2)).
  { rewrite app_remove_list. rewrite redund_remove_list. rewrite <- remove_list_dist_app. reflexivity. }
  rewrite E. reflexivity.
Qed.

Lemma NoDup_subform_boxesLF : forall l, NoDup (subform_boxesLF l).
Proof.
induction l.
- intros. simpl. apply NoDup_nil.
- intros. simpl. apply add_remove_list_preserve_NoDup. apply NoDup_subform_boxesF.
  apply IHl.
Qed.

Lemma NoDup_subform_boxesS : forall s, NoDup (subform_boxesS s).
Proof.
intro s. unfold subform_boxesS. apply add_remove_list_preserve_NoDup ;
apply NoDup_subform_boxesLF.
Qed.

Lemma univ_gen_ext_incl_subform_boxes : forall l1 l2 P, (univ_gen_ext P l1 l2) ->
                                          incl (subform_boxesLF l1) (subform_boxesLF l2).
Proof.
intros. induction X.
- unfold incl. intros. auto.
- unfold incl. intros. simpl in H. simpl. apply in_app_or in H. destruct H.
  * apply in_or_app. left. assumption.
  * apply In_remove_list_In_list_not_In_remove_list in H. destruct H.
    apply in_or_app. right. apply not_removed_remove_list. apply IHX. assumption.
    assumption.
- unfold incl. intros. simpl. destruct (In_dec (subform_boxesF x) a).
  * apply in_or_app. left. assumption.
  * apply in_or_app. right. apply not_removed_remove_list. apply IHX. assumption.
    assumption.
Qed.

Lemma XBoxed_list_same_subform_boxes : forall l,
          incl (subform_boxesLF (XBoxed_list l)) (subform_boxesLF l) /\
          incl (subform_boxesLF l) (subform_boxesLF (XBoxed_list l)).
Proof.
induction l.
- split.
  * unfold incl. intros. simpl in H. inversion H.
  * unfold incl. intros. simpl in H. inversion H.
- split.
  * unfold incl. intros. simpl. simpl in H. apply in_app_or in H. destruct H.
    apply in_or_app. left. destruct a ; simpl in H ; try contradiction.
    simpl. assumption. simpl. right. assumption. apply In_remove_list_In_list in H.
    apply in_app_or in H. destruct H. apply in_or_app. left. assumption. apply in_or_app.
    right. apply In_remove_list_In_list_not_In_remove_list in H. destruct H. destruct IHl.
    apply H1 in H. apply not_removed_remove_list ; assumption.
  * destruct IHl. unfold incl. intros. simpl in H1. apply in_app_or in H1. destruct H1.
    destruct a ; simpl in H1 ; try contradiction. apply in_app_or in H1. destruct H1.
    simpl. apply in_or_app. left. apply in_or_app. left. assumption. apply
    In_remove_list_In_list_not_In_remove_list in H1. destruct H1. simpl. apply in_or_app.
    left. apply in_or_app. right. apply not_removed_remove_list ; assumption. destruct H1.
    subst. simpl. apply in_or_app. right. apply not_removed_remove_list. apply in_eq.
    intros. apply contradic_subform_boxesF in H1. assumption. auto. simpl. apply in_or_app.
    left. assumption. simpl. apply in_or_app. right. rewrite remove_list_dist_app.
    apply in_or_app. right. apply not_removed_remove_list. apply
    In_remove_list_In_list_not_In_remove_list in H1. destruct H1. apply H0 in H1.
    apply not_removed_remove_list ; assumption. intro. apply
    In_remove_list_In_list_not_In_remove_list in H1. destruct H1. destruct a ; simpl ; try assumption.
    simpl (unBox_formula (a1 → a2)) in H2. firstorder. simpl (unBox_formula (Box a)) in H2.
    apply H3. simpl. right. assumption.
Qed.

Lemma In_incl_subform_boxes : forall l A, In A l ->
                  (forall B, In B (subform_boxesF A) -> In B (subform_boxesLF l)).
Proof.
induction l.
- intros. inversion H.
- intros. simpl. inversion H.
  * subst. apply in_or_app. left. assumption.
  * pose (IHl A H1). destruct (In_dec (subform_boxesF a) B).
    + apply in_or_app. left. assumption.
    + apply in_or_app. right. apply not_removed_remove_list. apply i. assumption.
      assumption.
Qed.

(* Now we can define the notion of usable boxed formulae: it is a positive one such that
   it does not appear as a top formula in the LHS of the sequent. To do so, we need to
   define the list of such formulae: *)

Fixpoint top_boxes (l : list (MPropF V)) : list (MPropF V) :=
match l with
  | nil => nil
  | h :: t => match h with
                | Box A => (Box A) :: top_boxes t
                | _ => top_boxes t
              end
end.

Lemma top_boxes_distr_app : forall (l1 l2 : list (MPropF V)),
      top_boxes (l1 ++ l2) = (top_boxes l1) ++ (top_boxes l2).
Proof.
induction l1.
- intro l2. rewrite app_nil_l. simpl. reflexivity.
- intro l2. simpl. destruct a ; try apply IHl1.
  simpl. rewrite IHl1. reflexivity.
Qed.

Lemma top_boxes_incl_list : forall l, incl (top_boxes l) l.
Proof.
induction l.
- simpl. unfold incl. intros. inversion H.
- unfold incl. intros. destruct a.
  * simpl in H. apply in_cons. apply IHl. assumption.
  * simpl in H. apply in_cons. apply IHl. assumption.
  * simpl in H. apply in_cons. apply IHl. assumption.
  * simpl in H. destruct H.
    + subst. apply in_eq.
    + apply in_cons. apply IHl. assumption.
Qed.

Lemma in_top_boxes : forall l A, (In A (top_boxes l)) -> (existsT2 B l1 l2, (A = Box B) * (l = l1 ++ A :: l2)).
Proof.
induction l.
- intros. simpl in H. inversion H.
- intros. destruct a.
  * simpl in H. apply IHl in H. destruct H. destruct s. destruct s. destruct p. subst.
    exists x. exists ([# v] ++ x0). exists x1. auto.
  * simpl in H. apply IHl in H. destruct H. destruct s. destruct s. destruct p. subst.
    exists x. exists ([⊥ V] ++ x0). exists x1. auto.
  * simpl in H. apply IHl in H. destruct H. destruct s. destruct s. destruct p. subst.
    exists x. exists ([a1 → a2] ++ x0). exists x1. auto.
  * simpl (top_boxes (Box a :: l)) in H. destruct (eq_dec_form (Box a) A).
    + subst. exists a. exists []. exists l. auto.
    + subst. assert (H0 : In A (top_boxes l)). inversion H. exfalso. apply n. assumption.
      assumption. apply IHl in H0. destruct H0. destruct s. destruct s. destruct p.
      subst. exists x. exists ([Box a] ++ x0). exists x1. auto.
Qed.

Lemma box_in_top_boxes : forall l1 l2 A, existsT2 l3 l4, top_boxes (l1 ++ Box A :: l2) = l3 ++ Box A :: l4.
Proof.
intros. exists (top_boxes l1). exists (top_boxes l2). rewrite top_boxes_distr_app. auto.
Qed.

Lemma box_preserv_top_boxes : forall l1 l2 l3 A, top_boxes l1 = l2 ++ Box A :: l3 ->
                                existsT2 l4 l5, l1 = l4 ++ Box A :: l5.
Proof.
induction l1.
- intros. simpl in H. destruct l2 ; inversion H.
- induction l2.
  * intros. rewrite app_nil_l in H. destruct a.
    + pose (IHl1 [] l3 A). simpl in s. apply s in H. destruct H. destruct s0. exists ([# v] ++ x).
      exists x0. subst. auto.
    + pose (IHl1 [] l3 A). simpl in s. apply s in H. destruct H. destruct s0. exists ([⊥ V] ++ x).
      exists x0. subst. auto.
    + pose (IHl1 [] l3 A). simpl in s. apply s in H. destruct H. destruct s0. exists ([a1 → a2] ++ x).
      exists x0. subst. auto.
    + inversion H. exists []. exists l1. auto.
  * intros. destruct a.
    + simpl in H. pose (IHl1 (a0 :: l2) l3 A). simpl in s. apply s in H. destruct H. destruct s0. exists ([# v] ++ x).
      exists x0. subst. auto.
    + simpl in H. pose (IHl1 (a0 :: l2) l3 A). simpl in s. apply s in H. destruct H. destruct s0. exists ([⊥ V] ++ x).
      exists x0. subst. auto.
    + simpl in H. pose (IHl1 (a0 :: l2) l3 A). simpl in s. apply s in H. destruct H. destruct s0. exists ([a1 → a2] ++ x).
      exists x0. subst. auto.
    + inversion H. apply IHl1 in H2. destruct H2. destruct s. subst. exists (Box a :: x). exists x0. auto.
Qed.

Lemma removed_box_exists : forall l1 l2 l3 A,
    (remove_list (top_boxes l1) (top_boxes (l2 ++ Box A :: l3))) = nil ->
    (existsT2 l4 l5, l1 = l4 ++ Box A :: l5).
Proof.
intros. pose (box_in_top_boxes l2 l3 A). repeat destruct s. rewrite e in H.
remember (top_boxes l1) as l. apply remove_list_in_nil in H. destruct H.
destruct s. subst. apply box_preserv_top_boxes in e0. assumption.
Qed.

Lemma is_box_in_top_boxes : forall l A, In A l -> is_boxedT A -> In A (top_boxes l).
Proof.
induction l.
- intros. inversion H.
- intros. inversion H.
  * subst. inversion X. subst. simpl. left. reflexivity.
  * pose (IHl A H0 X). destruct a ; simpl ; try assumption.
    right. assumption.
Qed.

(* Some more 'macro' lemmas dealing with subform_boxes and top_boxes. *)

Lemma RHS_top_box_is_subformLF : forall (s : rel (list (MPropF V))) (A : MPropF V),
        (In A (top_boxes (snd s))) -> (In A (subform_boxesLF (snd s))).
Proof.
intros s A H. apply in_top_boxes in H. destruct H. repeat destruct s0. destruct p. subst. rewrite e0.
rewrite subform_boxesLF_dist_app. apply in_or_app. pose (In_dec (subform_boxesLF x0) (Box x)).
destruct s0.
- left. assumption.
- right. apply not_removed_remove_list.
  * simpl. left. reflexivity.
  * assumption.
Qed.

Lemma RHS_top_box_is_subform : forall s A, (In A (top_boxes (snd s))) -> (In A (subform_boxesS s)).
Proof.
intros s A H. unfold subform_boxesS. apply RHS_top_box_is_subformLF in H.
apply remove_list_is_in with (l2:=subform_boxesLF (fst s)) in H. assumption.
Qed.

(* Finally, we can define the list of usable boxed formulae. The length of that list is
   the first component of our measure. *)

Definition usable_boxes (s : rel (list (MPropF V))) : list (MPropF V) :=
   remove_list (top_boxes (fst s)) (subform_boxesS s).

(* We can show that our notion of usable box effectively captures what it is intended to:
   an upper bound on how many GLR rules can be applied to a sequent. To check this, we can
   show that if the number of usable boxes is effectively 0 then no GLR is applicable. This
   is the content of the lemma length_usable_boxes_is_0. *)

Lemma no_RHS_box_no_GLR (s : rel (list (MPropF V))) :
    (top_boxes (snd s)) = nil -> (existsT2 ps, GLRRule ps s) -> False.
Proof.
intros isnil RA. destruct RA. inversion g. subst. simpl in isnil.
rewrite top_boxes_distr_app in isnil. apply app_eq_nil in isnil. destruct isnil.
simpl in H1. inversion H1.
Qed.

Lemma all_RHS_boxes_are_LHS_boxes_no_GLR (s : rel (list (MPropF V))) :
    (IdBRule [] s -> False) ->  (* This line makes sure that we do PS: no IdB can happen. *)
    (remove_list (top_boxes (fst s)) (top_boxes (snd s))) = nil ->
    (existsT2 ps, GLRRule ps s) -> False.
Proof.
intros noId isnil RA. destruct RA. inversion g. subst. simpl in isnil.
apply noId. apply removed_box_exists in isnil. destruct isnil. destruct s.
subst. apply IdBRule_I.
Qed.

Lemma no_usable_boxes_all_RHS_are_LHS (s : rel (list (MPropF V))) :
    length (usable_boxes s) = 0 -> (remove_list (top_boxes (fst s)) (top_boxes (snd s))) = nil.
Proof.
intro is0. remember (usable_boxes s) as l. destruct l.
- unfold usable_boxes in Heql. symmetry in Heql. rewrite remove_list_is_nil in Heql.
  rewrite remove_list_is_nil. intros. apply RHS_top_box_is_subform in H. apply Heql. assumption.
- inversion is0.
Qed.

Theorem length_usable_boxes_is_0 (s : rel (list (MPropF V))) :
    length (usable_boxes s) = 0 ->
    (IdBRule [] s -> False) ->
    (existsT2 ps, GLRRule ps s) -> False.
Proof.
intros H0 H1. pose (no_usable_boxes_all_RHS_are_LHS s H0).
pose (all_RHS_boxes_are_LHS_boxes_no_GLR H1 e). assumption.
Qed.

Lemma NoDup_usable_boxes : forall s, NoDup (usable_boxes s).
Proof.
intro s. unfold usable_boxes. destruct s. simpl. unfold subform_boxesS.
simpl. pose (NoDup_subform_boxesLF l0). pose (NoDup_subform_boxesLF l).
pose (add_remove_list_preserve_NoDup n0 n). apply remove_list_preserv_NoDup.
assumption.
Qed.

(* We can consequently define our measure on sequents: *)

Definition term_meas (s : rel (list (MPropF V))) : nat * nat :=
  pair (length (usable_boxes s)) (n_imp_subformS s).

(* Third, we need to prove that if no PSGLS rule is applicable to a sequent s,
   then its derivations have a height equal to 0. *)

Theorem no_PSGLS_rule_applic : forall s, (forall ps, (PSGLS_rules ps s) -> False) ->
                                 forall (D : derrec (@PSGLS_rules V) (fun _ => True) s), derrec_height D = 0.
Proof.
intros s noRA D. induction D.
- auto.
- exfalso. apply noRA with (ps:=ps). assumption.
Qed.

(* Fourth, we show that the number of usable boxes decreases upwards in the application
   of a GLR rule. To do so we need to prove some lemmas beforehand. *)

Lemma GLR_applic_more_top_boxes : forall prem concl, GLRRule [prem] concl ->
                                                     (IdBRule [] concl -> False) ->
                                    incl (top_boxes (fst concl)) (top_boxes (fst prem)).
Proof.
intros prem concl RA noIdB. inversion RA. subst. simpl. rewrite top_boxes_distr_app.
simpl. unfold incl. intros. apply in_or_app. left. assert (In a Γ0). apply in_top_boxes in H.
destruct H. repeat destruct s. destruct p. subst. apply in_or_app. right. apply in_eq.
assert (InT a Γ0). apply in_splitT in H1. destruct H1. destruct s. rewrite e.
apply InT_or_app. right. apply InT_eq. pose (InT_univ_gen_ext H2 X). destruct s.
exfalso. apply f. apply in_top_boxes in H. destruct H. repeat destruct s.
destruct p. exists x. assumption. apply top_boxes_incl_list in H.
pose (list_preserv_XBoxed_list BΓ). pose (InT_In i). apply i0 in i1.
apply is_box_in_top_boxes. apply i0. apply InT_In. assumption.
apply H0. apply InT_In. assumption.
Qed.

Lemma GLR_applic_le_subform_boxes : forall prem concl, GLRRule [prem] concl ->
                                                        (IdBRule [] concl -> False) ->
                        (length (subform_boxesS prem) <= length (subform_boxesS concl) /\
                         forall B, (In B (subform_boxesS prem)) -> (In B (subform_boxesS concl))).
Proof.
intros prem concl RA noIdB. inversion RA. subst. split.
- apply NoDup_incl_length.
  * apply NoDup_subform_boxesS.
  * intro. intros. unfold subform_boxesS in H. unfold subform_boxesS. simpl. simpl in H.
    repeat rewrite app_length.  repeat rewrite app_length in H. repeat rewrite remove_list_of_nil.
    repeat rewrite remove_list_of_nil in H. rewrite app_nil_r in H. apply in_app_or in H.
    destruct H. rewrite subform_boxesLF_dist_app in H. apply in_app_or in H. destruct H.
    apply in_or_app. left. apply univ_gen_ext_incl_subform_boxes in X. apply X. pose (XBoxed_list_same_subform_boxes BΓ).
    destruct a0. apply H1. assumption. apply In_remove_list_In_list in H.
    apply remove_list_is_in. rewrite subform_boxesLF_dist_app. apply remove_list_is_in.
    simpl. simpl in H. destruct H. left. assumption. right. repeat rewrite remove_list_of_nil in H.
    apply in_app_or in H. destruct H. apply in_or_app. auto. simpl in H. destruct H.
    apply remove_list_is_in. apply In_remove_list_In_list in H. rewrite subform_boxesLF_dist_app.
    apply remove_list_is_in. simpl. right. apply in_or_app. auto.
- intro. intros. unfold subform_boxesS in H. unfold subform_boxesS. simpl. simpl in H.
  repeat rewrite app_length.  repeat rewrite app_length in H. repeat rewrite remove_list_of_nil.
  repeat rewrite remove_list_of_nil in H. rewrite app_nil_r in H. apply in_app_or in H.
  destruct H. rewrite subform_boxesLF_dist_app in H. apply in_app_or in H. destruct H.
  apply in_or_app. left. apply univ_gen_ext_incl_subform_boxes in X. apply X. pose (XBoxed_list_same_subform_boxes BΓ).
  destruct a. apply H1. assumption. apply In_remove_list_In_list in H.
  apply remove_list_is_in. rewrite subform_boxesLF_dist_app. apply remove_list_is_in.
  simpl. simpl in H. destruct H. left. assumption. right. repeat rewrite remove_list_of_nil in H.
  apply in_app_or in H. destruct H. apply in_or_app. auto. simpl in H. destruct H.
  apply remove_list_is_in. apply In_remove_list_In_list in H. rewrite subform_boxesLF_dist_app.
  apply remove_list_is_in. simpl. right. apply in_or_app. auto.
Qed.

Theorem GLR_applic_less_usable_boxes : forall prem concl, GLRRule [prem] concl ->
                                                          (IdBRule [] concl -> False) ->
                                         length (usable_boxes prem) < length (usable_boxes concl).
Proof.
intros prem concl RA noIdB. inversion RA. unfold usable_boxes. simpl.
apply remove_list_incr_decr.
- apply NoDup_subform_boxesS.
- apply NoDup_subform_boxesS.
- exists (Box A). repeat split. simpl. rewrite top_boxes_distr_app. apply in_or_app. right. simpl.
  left. reflexivity. unfold subform_boxesS. simpl.
  destruct (In_dec (subform_boxesLF Γ0) (Box A)). apply in_or_app. left. assumption.
  apply in_or_app. right. apply not_removed_remove_list. rewrite subform_boxesLF_dist_app.
  destruct (In_dec (subform_boxesLF Δ0) (Box A)). apply in_or_app. left. assumption.
  apply in_or_app. right. apply not_removed_remove_list. simpl. auto. assumption. assumption.
  intro. simpl in H2. apply noIdB. subst. pose (in_top_boxes Γ0 (Box A) H2). repeat destruct s.
  destruct p. subst. apply IdBRule_I.
- intro A0. pose (@GLR_applic_more_top_boxes prem concl). subst. pose (i RA). pose (i0 noIdB).
  apply i1.
- intro A0. subst. pose (GLR_applic_le_subform_boxes RA noIdB). destruct a. apply H1.
Qed.

Theorem ImpR_applic_less_Imp_same_usable_boxes : forall prem concl, ImpRRule [prem] concl ->
                   prod (sum (length (usable_boxes prem) < length(usable_boxes concl))
                    (length (usable_boxes prem) = length(usable_boxes concl)))
                   (n_imp_subformS (prem) < n_imp_subformS (concl)).
Proof.
intros prem concl RA. inversion RA. subst. split.
- pose (NoDup_usable_boxes (Γ0 ++ A :: Γ1, Δ0 ++ B :: Δ1)).
  pose (NoDup_usable_boxes (Γ0 ++ Γ1, Δ0 ++ A → B :: Δ1)).
  apply NoDup_incl_lengthT. assumption. unfold incl. intros. unfold usable_boxes in H. simpl in H.
  unfold usable_boxes. simpl. apply In_remove_list_In_list_not_In_remove_list in H.
  destruct H. apply not_removed_remove_list. unfold subform_boxesS. unfold subform_boxesS in H.
  simpl. simpl in H. apply in_app_or in H. destruct H. rewrite subform_boxesLF_dist_app in H.
  apply in_app_or in H. destruct H. apply in_or_app. left. rewrite subform_boxesLF_dist_app.
  apply in_or_app. left. assumption. apply In_remove_list_In_list_not_In_remove_list in H.
  destruct H. simpl in H. apply in_app_or in H. destruct H. destruct (In_dec (subform_boxesLF (Γ0 ++ Γ1)) a).
  apply in_or_app. left. assumption. apply in_or_app. right. apply not_removed_remove_list.
  2: assumption. apply In_incl_subform_boxes with (A:=A → B). apply in_or_app. right. apply in_eq.
  simpl. apply in_or_app. left.
  assumption. apply In_remove_list_In_list_not_In_remove_list in H. destruct H. apply in_or_app. left.
  rewrite subform_boxesLF_dist_app. apply in_or_app. right. apply not_removed_remove_list. assumption.
  assumption. apply In_remove_list_In_list_not_In_remove_list in H. destruct H. rewrite subform_boxesLF_dist_app in H.
  apply in_app_or in H. destruct H. apply in_or_app. right. apply not_removed_remove_list.
  rewrite subform_boxesLF_dist_app. apply in_or_app. left. assumption. intro.
  apply H1. rewrite subform_boxesLF_dist_app. apply in_or_app.
  rewrite subform_boxesLF_dist_app in H2. apply in_app_or in H2.
  destruct H2. auto. apply In_remove_list_In_list_not_In_remove_list in H2. destruct H2.
  right. apply not_removed_remove_list. simpl. apply in_or_app. right. apply not_removed_remove_list.
  assumption. intro. apply H1. rewrite subform_boxesLF_dist_app. apply in_or_app. right.
  apply not_removed_remove_list. simpl. apply in_or_app. left. assumption. assumption. assumption.
  apply in_or_app. right. apply not_removed_remove_list. apply In_remove_list_In_list_not_In_remove_list in H.
  destruct H. simpl in H. apply in_app_or in H. destruct H. apply In_incl_subform_boxes with (A:=A → B).
  apply in_or_app. right. apply in_eq. simpl. apply in_or_app. right. apply not_removed_remove_list. assumption.
  intro. apply H1. rewrite subform_boxesLF_dist_app. apply in_or_app. right. apply not_removed_remove_list.
  simpl. apply in_or_app. left. assumption. intro. apply H1. rewrite subform_boxesLF_dist_app. apply in_or_app.
  auto. apply In_remove_list_In_list_not_In_remove_list in H. destruct H.
  rewrite subform_boxesLF_dist_app.
  apply in_or_app. right. apply not_removed_remove_list. simpl. apply in_or_app. right.
  apply not_removed_remove_list. assumption. intro. apply in_app_or in H4. destruct H4.
  apply H1. rewrite subform_boxesLF_dist_app. apply in_or_app. right. apply not_removed_remove_list.
  simpl. apply in_or_app. left. assumption. intro. apply H1. rewrite subform_boxesLF_dist_app.
  apply in_or_app. auto. apply H3. apply In_remove_list_In_list_not_In_remove_list in H4. destruct H4.
  assumption. assumption. intro. apply H1. rewrite subform_boxesLF_dist_app.
  apply in_or_app. rewrite subform_boxesLF_dist_app in H2. apply in_app_or in H2.
  destruct H2. auto. apply In_remove_list_In_list_not_In_remove_list in H2.
  destruct H2. right. apply not_removed_remove_list. simpl. apply in_or_app. right.
  apply not_removed_remove_list. assumption. intro. apply H1. rewrite subform_boxesLF_dist_app.
  apply in_or_app. right. apply not_removed_remove_list. simpl. apply in_or_app. auto.
  assumption. assumption. intro. apply H0. rewrite top_boxes_distr_app. rewrite top_boxes_distr_app in H1.
  apply in_app_or in H1. destruct H1. apply in_or_app. auto. apply in_or_app. right.
  assert (A :: Γ1 = [A] ++ Γ1). auto. rewrite H2. rewrite top_boxes_distr_app. apply in_or_app. right.
  auto.
- unfold n_imp_subformS. simpl. repeat rewrite n_imp_subformLF_dist_app. simpl. lia.
Qed.

Theorem ImpL_applic_less_Imp_same_usable_boxes : forall prem1 prem2 concl, ImpLRule [prem1 ; prem2] concl ->
                   prod (prod (sum (length (usable_boxes prem1) < length(usable_boxes concl))
                    (length (usable_boxes prem1) = length(usable_boxes concl)))
                   (n_imp_subformS (prem1) < n_imp_subformS (concl)))
                   (prod (sum (length (usable_boxes prem2) < length(usable_boxes concl))
                    (length (usable_boxes prem2) = length(usable_boxes concl)))
                   (n_imp_subformS (prem2) < n_imp_subformS (concl))).
Proof.
intros prem1 prem2 concl RA. inversion RA. subst. split.
- split.
  * pose (NoDup_usable_boxes (Γ0 ++ Γ1, Δ0 ++ A :: Δ1)).
    pose (NoDup_usable_boxes (Γ0 ++ A → B :: Γ1, Δ0 ++ Δ1)).
    apply NoDup_incl_lengthT. assumption. unfold incl. intros. unfold usable_boxes in H. simpl in H.
    unfold usable_boxes. simpl. apply In_remove_list_In_list_not_In_remove_list in H.
    destruct H. apply not_removed_remove_list. unfold subform_boxesS. unfold subform_boxesS in H.
    simpl. simpl in H. apply in_app_or in H. destruct H. rewrite subform_boxesLF_dist_app in H.
    apply in_app_or in H. destruct H. apply in_or_app. left. rewrite subform_boxesLF_dist_app.
    apply in_or_app. auto. apply in_or_app.
    apply In_remove_list_In_list_not_In_remove_list in H. destruct H. left.
    rewrite subform_boxesLF_dist_app. apply in_or_app. right.
    apply not_removed_remove_list. simpl. apply in_or_app.
    destruct (In_dec (subform_boxesF A ++ remove_list (subform_boxesF A) (subform_boxesF B)) a).
    auto. right. apply not_removed_remove_list.
    assumption. assumption. assumption. apply In_remove_list_In_list_not_In_remove_list in H.
    destruct H. rewrite subform_boxesLF_dist_app in H. apply in_app_or in H. destruct H. apply in_or_app.
    destruct (In_dec (subform_boxesLF (Γ0 ++ A → B :: Γ1)) a). auto. right. apply not_removed_remove_list.
    2: assumption. rewrite subform_boxesLF_dist_app. apply in_or_app. auto.
    apply in_or_app. apply In_remove_list_In_list_not_In_remove_list in H. destruct H. simpl in H. apply in_app_or in H.
    destruct H. left. assert (In a (subform_boxesF (A → B))). simpl. apply in_or_app. auto.
    apply In_incl_subform_boxes with (A:=A → B). apply in_or_app. right. apply in_eq. assumption.
    apply In_remove_list_In_list_not_In_remove_list in H. destruct H.
    destruct (In_dec (subform_boxesLF (Γ0 ++ A → B :: Γ1)) a). auto. right.
    apply not_removed_remove_list. rewrite subform_boxesLF_dist_app. apply in_or_app. right. apply not_removed_remove_list.
    assumption. assumption. assumption. intro. apply H0. rewrite top_boxes_distr_app in H1. rewrite top_boxes_distr_app.
    apply in_or_app. apply in_app_or in H1. destruct H1. auto. simpl in H1. auto.
  * unfold n_imp_subformS. simpl. repeat rewrite n_imp_subformLF_dist_app. simpl. lia.
- split.
  * pose (NoDup_usable_boxes (Γ0 ++ B :: Γ1, Δ0 ++ Δ1)).
    pose (NoDup_usable_boxes (Γ0 ++ A → B :: Γ1, Δ0 ++ Δ1)).
    apply NoDup_incl_lengthT. assumption. unfold incl. intros. unfold usable_boxes in H. simpl in H.
    unfold usable_boxes. simpl. apply In_remove_list_In_list_not_In_remove_list in H.
    destruct H. apply not_removed_remove_list. unfold subform_boxesS. unfold subform_boxesS in H.
    simpl. simpl in H. apply in_app_or in H. destruct H.
    apply in_or_app. left. rewrite subform_boxesLF_dist_app in H.
    apply in_app_or in H. destruct H. rewrite subform_boxesLF_dist_app. apply in_or_app. auto.
    apply In_remove_list_In_list_not_In_remove_list in H. destruct H. simpl in H. apply in_app_or in H.
    destruct H. simpl. rewrite subform_boxesLF_dist_app. apply in_or_app. right.
    apply not_removed_remove_list. simpl. apply in_or_app. destruct (In_dec (subform_boxesF A) a).
    left. apply in_or_app. auto. left.
    apply in_or_app. right. apply not_removed_remove_list. assumption. assumption. assumption.
    apply In_remove_list_In_list_not_In_remove_list in H. destruct H. rewrite subform_boxesLF_dist_app.
    apply in_or_app. right. apply not_removed_remove_list. simpl. destruct (In_dec (subform_boxesF A) a).
    apply in_or_app. left. apply in_or_app. auto. apply in_or_app. right.
    apply not_removed_remove_list. assumption. intro. apply in_app_or in H3. destruct H3.
    apply f. auto. apply In_remove_list_In_list_not_In_remove_list in H3. destruct H3. auto.
    assumption. apply In_remove_list_In_list_not_In_remove_list in H. destruct H.
    destruct (In_dec (subform_boxesLF (Γ0 ++ A → B :: Γ1)) a). apply in_or_app. auto.
    apply in_or_app. right. apply not_removed_remove_list. assumption. assumption.
    intro. apply H0. rewrite top_boxes_distr_app. rewrite top_boxes_distr_app in H1.
    apply in_app_or in H1. destruct H1. apply in_or_app. auto. simpl in H1.
    apply in_or_app. right. assert (B :: Γ1 = [B] ++ Γ1). reflexivity. rewrite H2.
    rewrite top_boxes_distr_app. apply in_or_app. auto.
  * unfold n_imp_subformS. simpl. repeat rewrite n_imp_subformLF_dist_app. simpl. lia.
Qed.


Require Import Orders.
Require Import OrdersEx.
Require Import OrdersAlt.
Require Import ZArith.
Require Import QArith.
Require Import Qpower.
Require Import MSets.
Require Import List.
Import ListNotations.

Definition INC : Z := 1.

Record D := Dmake {Dmantissa : Z; Dexponent : Z }.

Definition D_from_Z (a : Z) := Dmake a 0.
Coercion D_from_Z : Z >-> D.

Definition inject_D (a : D) := (inject_Z (Dmantissa a) * 2 ^ Dexponent a)%Q.
Coercion inject_D : D >-> Q.

Fixpoint DredH (p : positive) (z : Z) : positive*Z :=
match p with
| xO x => DredH x (Z.succ z)
| _ => (p, z)
end.

Definition Dred (a : D) : D :=
let (m, e) := a in
match m with
| Z0 => 0%Z
| Zpos p => let (p', e') := DredH p e in Dmake (Zpos p') e'
| Zneg p => let (p', e') := DredH p e in Dmake (Zneg p') e'
end.

Definition Dalign (a b : D) : Z * Z * Z :=
match (Dexponent a - Dexponent b)%Z with
| Zpos d => (Z.shiftl (Dmantissa a) (Zpos d), Dmantissa b, Dexponent b)
| Z0 => (Dmantissa a, Dmantissa b, Dexponent b)
| Zneg d => (Dmantissa a, Z.shiftl (Dmantissa b) (Zpos d), Dexponent a)%Z
end.

Lemma Dalign_lr : forall x y, let '(xm', ym', e') := Dalign x y in
  inject_D (Dmake xm' e') == inject_D x /\
  inject_D (Dmake ym' e') == inject_D y.
Proof.
intros [xm xe] [ym ye].
cbv beta iota delta [Dalign Dexponent Dmantissa inject_D].
case (xe - ye)%Z as [|p|p] eqn:He; [rewrite (Zminus_eq _ _ He); split; reflexivity| |];
split;try reflexivity;
rewrite Z.shiftl_mul_pow2, inject_Z_mult, Zpower_Qpower; auto with *;
rewrite <- Qmult_assoc, <- Qpower_plus; try discriminate.
* rewrite <- He, Z_as_OT.sub_add; reflexivity.
* rewrite <- (Pos2Z.opp_neg p), <- He.
  replace (-(xe - ye) + xe)%Z with ye by ring.
  reflexivity.
Qed.

Definition Dadd (a b : D) : D :=
let '(a',b',e') := Dalign a b in Dmake (a' + b') e'.

Definition Dsub (a b : D) : D :=
let '(a',b',e') := Dalign a b in Dmake (a' - b') e'.

Definition Dmult (a b : D) : D :=
 Dmake (Dmantissa a * Dmantissa b) (Dexponent a + Dexponent b).

Definition Dhalf (a : D) : D :=
 Dmake (Dmantissa a) (Z.pred (Dexponent a)).

Definition Dcompare (a b : D) : comparison :=
let '(a',b',_) := Dalign a b in (a' ?= b')%Z.

Lemma Dcompare_Q : forall x y, Dcompare x y = (x ?= y)%Q.
Proof.
intros x y.
unfold Dcompare.
assert (Hxy := Dalign_lr x y).
destruct (Dalign x y) as [[xm' ym'] e'].
destruct Hxy as [<- <-].
unfold Qcompare.
simpl.
rewrite <- !Zmult_assoc.
apply Zmult_compare_compat_r.
apply Z.lt_gt.
assert (Hp : forall p, (0 < Z.pow_pos 2 p)%Z).
 intros p;
 apply Zpow_facts.Zpower_pos_pos; auto with *.
apply Zmult_lt_0_compat;
destruct e'; simpl; auto with *;
rewrite Qpower_decomp; simpl; auto with *.
unfold Qinv; simpl.
specialize (Hp p).
destruct (Z.pow_pos 2 p)%Z; try discriminate; auto with *.
Qed.

Lemma Dcompare_antisym : forall x y, Dcompare y x = CompOpp (Dcompare x y).
Proof.
intros x y.
rewrite !Dcompare_Q, Qcompare_antisym.
reflexivity.
Qed.

Lemma Dcompare_trans : forall c x y z,
 Dcompare x y = c -> Dcompare y z = c -> Dcompare x z = c.
Proof.
intros c x y z <-.
rewrite !Dcompare_Q.
destruct (Qcompare_spec x y).
* rewrite H; auto.
* rewrite <- !Qlt_alt.
  eauto using Qlt_trans.
* rewrite <- !Qgt_alt.
  eauto using Qlt_trans.
Qed.

Module D_as_OrderedTypeAlt <: OrderedTypeAlt.
 Definition t := D.
 Definition compare := Dcompare.
 Definition compare_sym := Dcompare_antisym.
 Definition compare_trans := Dcompare_trans.
End D_as_OrderedTypeAlt.

Module D_as_OT <: OrderedType := OT_from_Alt D_as_OrderedTypeAlt.
Module D_as_OTF <: OrderedTypeFull := OT_to_Full D_as_OT.
Module D_as_TTLT <: TotalTransitiveLeBool := OTF_to_TTLB D_as_OTF.

Definition Dltb (a b : D) := negb (D_as_TTLT.leb b a).

Module DDOrder <: OrderedType := PairOrderedType D_as_OT D_as_OT.

Definition DD := DDOrder.t.

(* | x1 y1 1 |
 * | x2 y2 1 | ?= 0
 * | x3 y3 1 |
 *)
Definition orientation (p1 p2 p3 : DD) : comparison :=
let (x1, y1) := p1 in
let (x2, y2) := p2 in
let (x3, y3) := p3 in
(* (x1*y2 - y1*x2) + (x2*y3 - y2*x3) ?= x1*y3-y1*x3. *)
Dcompare (Dmult (Dsub x1  x3) (Dsub y2 y3)) (Dmult (Dsub y1 y3) (Dsub x2 x3)).

Fixpoint addLowerPoint (p : DD) (l : list DD) : list DD :=
match l with
| [] => [p]
| q :: l0 => match l0 with
   | [] => match DDOrder.compare p q with
           | Eq => [p]
           | _ => [p; q]
           end
   | r :: _ => match orientation p q r with
                 | Lt => p :: l
                 | _ => addLowerPoint p l0
                 end
   end
end.

Fixpoint addUpperPoint (p : DD) (l : list DD) : list DD :=
match l with
| [] => [p]
| q :: l0 => match l0 with
   | [] => match DDOrder.compare p q with
           | Eq => [p]
           | _ => [p; q]
           end
   | r :: _ => match orientation p q r with
                 | Gt => p :: l
                 | _ => addUpperPoint p l0
                 end
   end
end.

Module DDSet := MSetAVL.Make DDOrder.
Definition DDSet_fromList (l : list DD) :=
 fold_left (fun s a => DDSet.add a s) l DDSet.empty.
Definition DDSet_map (f : DD -> DD) (s : DDSet.t) :=
 DDSet.fold (fun a s => DDSet.add (f a) s) s DDSet.empty.

Definition convexHull (s : DDSet.t) : DDSet.t :=
 DDSet_fromList
   ((DDSet.fold addUpperPoint s []) ++ (DDSet.fold addLowerPoint s [])).

Definition narrow (M : Z) (s : DDSet.t) : bool :=
match (DDSet.min_elt s, DDSet.max_elt s) with
| (Some (l, _), Some (h, _)) => andb (Dltb (-1)%Z (Dmult M l)) (Dltb (Dmult M h) 1%Z)
| _ => true
end.

Definition odd_pos_trans (p : DD) : DD :=
let (g, f) := p in
 (Dred (Dhalf (Dsub g f)), g) (* ((g - f) / 2), g) *).
Definition odd_nonpos_trans (p : DD) : DD :=
let (g, f) := p in
 (Dred (Dhalf (Dadd g f)), f) (* ((g + f) / 2), f) *).
Definition even_trans (p : DD) : DD :=
let (g, f) := p in
 (Dhalf g, f) (* (g / 2), f) *).

Definition even_map (kv : Z * DDSet.t) : Z * DDSet.t :=
let (k, v) := kv in ((INC + k)%Z, DDSet_map even_trans v).
Definition odd_map (kv : Z * DDSet.t) : Z * DDSet.t :=
let (k, v) := kv in
if (0 <? k)%Z
 then ((INC - k)%Z, DDSet_map odd_pos_trans v)
 else ((INC + k)%Z, DDSet_map odd_nonpos_trans v).

Require FMapAVL.

Module ZMap := FMapAVL.Make OrderedTypeEx.Z_as_OT.

Definition State := ZMap.t DDSet.t.
Definition empty : State := ZMap.empty DDSet.t.
Definition State_join (k : Z) (v : DDSet.t) (m : State) : State :=
  ZMap.add k (match ZMap.find k m with
              | None =>  v
              | Some v0 => DDSet.union v v0
              end)
           m.
Definition State_fromList (l : list (Z * DDSet.t)) :=
 fold_left (fun s kv => State_join (fst kv) (snd kv) s) l empty.

Definition processDivstep (M : Z) (s : State) : State :=
 let f kv := [even_map kv; odd_map kv] in
 let s1 := (State_fromList (flat_map f (ZMap.elements s))) in
 let g kv := let (k, v) := kv : Z * DDSet.t in
             if narrow M v then [] else [(k, convexHull v)]
 in State_fromList (flat_map g (ZMap.elements s1)).

Definition set0 : DDSet.t := DDSet_fromList [(0:D,1:D); (1:D,1:D)]%Z.
Definition state0 : State := ZMap.add 1%Z set0 empty.

Lemma example_0x34688_50 : ZMap.Empty (N.iter 50 (processDivstep 0x34688) state0).
Proof.
apply ZMap.is_empty_2.
Time vm_compute.
auto.
Qed.

Lemma example_0x34689_50 : ~ZMap.Empty (N.iter 50 (processDivstep 0x34689) state0).
Proof.
intros H.
apply ZMap.is_empty_1 in H.
Time vm_compute in H.
discriminate.
Qed.

Lemma example_0x34688_49 : ~ZMap.Empty (N.iter 49 (processDivstep 0x34688) state0).
Proof.
intros H.
apply ZMap.is_empty_1 in H.
Time vm_compute in H.
discriminate.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_8_2.
Require Export GeoCoq.Elements.OriginalProofs.lemma_8_3.

Section Euclid.
Context `{Ax:euclidean_neutral_ruler_compass}.
Lemma lemma_altitudebisectsbase :
   forall A B M P,
   BetS A M B -> Cong A P B P -> Per A M P ->
   Midpoint A M B.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists C, (BetS A M C /\ Cong A M C M /\ Cong A P C P /\ neq M P)) by (conclude_def Per );destruct Tf as [C];spliter.
assert (BetS C M A) by (conclude axiom_betweennesssymmetry).
assert (Cong C M A M) by (conclude lemma_congruencesymmetric).
assert (Cong C P A P) by (conclude lemma_congruencesymmetric).
assert (Per C M P) by (conclude_def Per ).
assert (Per P M A) by (conclude lemma_8_2).
let Tf:=fresh in
assert (Tf:exists Q, (BetS P M Q /\ Cong P M Q M /\ Cong P A Q A /\ neq M A)) by (conclude_def Per );destruct Tf as [Q];spliter.
assert (Cong Q M P M) by (conclude lemma_congruencesymmetric).
assert (Per P M C) by (conclude lemma_8_2).
assert (Out M C B) by (conclude_def Out ).
assert (Per P M B) by (conclude lemma_8_3).
let Tf:=fresh in
assert (Tf:exists E, (BetS P M E /\ Cong P M E M /\ Cong P B E B /\ neq M B)) by (conclude_def Per );destruct Tf as [E];spliter.
assert (Cong P A P B) by (forward_using lemma_congruenceflip).
assert (Cong M Q P M) by (forward_using lemma_congruenceflip).
assert (Cong P M M Q) by (conclude lemma_congruencesymmetric).
assert (Cong E M P M) by (conclude lemma_congruencesymmetric).
assert (Cong E M M Q) by (conclude lemma_congruencetransitive).
assert (Cong M E M Q) by (forward_using lemma_congruenceflip).
assert (Cong M Q M E) by (conclude lemma_congruencesymmetric).
assert (neq P M) by (forward_using lemma_betweennotequal).
assert (eq Q E) by (conclude lemma_extensionunique).
assert (Cong P B Q B) by (conclude cn_equalitysub).
assert (Cong A P P B) by (forward_using lemma_congruenceflip).
assert (Cong A P Q B) by (conclude lemma_congruencetransitive).
assert (Cong A Q A P) by (forward_using lemma_doublereverse).
assert (Cong A Q Q B) by (conclude lemma_congruencetransitive).
assert (Cong A Q B Q) by (forward_using lemma_congruenceflip).
assert (Cong P Q P Q) by (conclude cn_congruencereflexive).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (eq B B) by (conclude cn_equalityreflexive).
assert (nCol A M P) by (conclude lemma_rightangleNC).
assert (~ Col A P M).
 {
 intro.
 assert (Col A M P) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (~ eq A P).
 {
 intro.
 assert (Col A P M) by (conclude_def Col ).
 contradict.
 }
assert (neq P A) by (conclude lemma_inequalitysymmetric).
assert (Out P A A) by (conclude lemma_ray4).
assert (~ eq P B).
 {
 intro.
 assert (Cong A P B B) by (conclude cn_equalitysub).
 assert (~ neq A P).
  {
  intro.
  assert (neq B B) by (conclude axiom_nocollapse).
  assert (eq B B) by (conclude cn_equalityreflexive).
  contradict.
  }
 contradict.
 }
assert (Out P B B) by (conclude lemma_ray4).
assert (Out P M Q) by (conclude lemma_ray4).
assert (CongA A P M B P M) by (conclude_def CongA ).
assert (Cong P M P M) by (conclude cn_congruencereflexive).
assert ((Cong A M B M /\ CongA P A M P B M /\ CongA P M A P M B)) by (conclude proposition_04).
assert (Cong A M M B) by (forward_using lemma_congruenceflip).
assert (Midpoint A M B) by (conclude_def Midpoint ).
close.
Qed.

End Euclid.


Theorem left_and_elimination : forall X Y : Prop, (and X Y) -> X.

Proof.

intros.
destruct H.
assumption.
Show Proof.

Qed.

Theorem left_and_elimination_2 : forall X Y : Prop, (and X Y) -> X.

Proof.

exact (fun X Y and_data => (proj1 and_data)).

Qed.

Require Import Arith.

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

Proof.
intros.
assumption.
Qed.

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

(** intros X Y A B
gives us A of type X and B of type Y,
then we just return A **)

Proof.
  intros X Y A B. exact A.
Qed.

Goal forall X : Prop, X -> X.
Proof.
  intros X. exact (fun A : X => A).
Qed.

(**
(fun A : X => Q).
means lambda (A:X).Q

**)

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

(** intros X Y A B
gives us A of type X and B of type Y,
then we just return A **)

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

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

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

(** above is shorthand for **)

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

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

Definition minustwo (n : nat) : nat :=
  match n with
    | O => O
    | S O => O
    | S (S n') => n'
  end.

Eval compute in (minustwo 4).

Goal forall X Y Z : Prop, (X -> Y) -> (Y -> Z) -> (X -> Z).

Proof.
  exact (fun X Y Z f g v => (g (f v))).
Qed.

(**
https://coq.inria.fr/library/Coq.Init.Logic.html
**)

Goal forall X Y : Prop, (and X Y) -> X.

Proof.
  exact (fun X Y k => (proj1 k)).
Qed.

(** modus tollens **)
Goal forall X Y : Prop, (X -> Y) -> (not Y) -> (X -> False).

Proof.
  Definition m : (forall X Y : Prop, (X -> Y) -> (not Y) -> (X -> False)) := fun X Y imp Yto0 xval => (Yto0 (imp xval)).
  exact (m).
Qed.

(** inductive definitions, disjunction,
forall, exists, pi type, sigma type,
LST, HoTT, proof general, number theory etc.
**)

Goal 41 + 1 = 42.

Proof.
reflexivity.
Show Proof.
Qed.

Check eq_refl.

Check (7 = 7).

Goal exists n:nat, n + 1 = 42.

Proof.
  apply ex_intro with (x:=41).
   reflexivity.
Show Proof.
Qed.

(** if there exists a proof x of A such that P(x) then A is true **)

(** Goal forall R : Prop -> Prop, ((exists V : Prop, (R V)) -> ).
Proof.
  exact (fun R v =>
**)

(**

Goal forall (A:Type), (forall R : A -> Prop, ( ((exists a : A, True)) -> ((forall a : A, R a)) -> (exists a : A, R a))).

Proof.
exact (fun A R elem forallfn => (Yto0 (imp xval))).
   reflexivity.
Qed.

**)

(** forall n, n + 2 == n + 1 **)

(** forall X -> X -> exists X

sigma and pi types

inductive definitions

LST

hott

**)

Definition add7 (n : nat) : nat := n + 7.

Eval compute in (add7 4).

Fixpoint times7 (n : nat) : nat :=
 match n with
    | O => O
    | S n' => (times7 n') + 7
  end.

Eval compute in (times7 4).

Require Import List.

Check 1::2::3::nil.

(**

Inductive or (A B:Prop) : Prop :=
  | or_introl : A -> A \/ B
  | or_intror : B -> A \/ B

**)

Goal forall X Y Z : Prop, (X -> Z) -> (Y -> Z) -> ((or X Y) -> Z).

Proof.
  Definition peicewise : (forall X Y Z : Prop, (X -> Z) -> (Y -> Z) -> ((or X Y) -> Z)) := fun X Y Z f g n =>
  match n with
    | (or_introl x) => (f x)
    | (or_intror y) => (g y)
  end.
  exact (peicewise).
Qed.

Theorem modusPonens (p : Prop) (q : Prop) :
  (and p (p -> q)) -> q.
Proof.
exact (fun data => (proj2 data) (proj1 data)).
Qed.

Theorem modusPonens2 (p : Prop) (q : Prop) :
  (and p (p -> q)) -> q.
Proof.
intros.
destruct H.
exact (H0 H).
Qed.

Theorem modusPonens3 (p : Prop) (q : Prop) :
  (and p (p -> q)) -> q.
Proof.
intros.
destruct H.
apply H0 in H as newthing.
assumption.
Qed.

Theorem modusPonens4 (p : Prop) (q : Prop) :
  (and p (p -> q)) -> q.
Proof.
exact (modusPonens3 p q).
Qed.

Theorem ex_falso_quodlibet : forall (X : Prop), False -> X.
Proof.
  intros X contra.
  inversion contra.
Show Proof.
Qed.

(** the above defines our void function **)

Theorem onlyone : forall P Q : Prop, (and (or P Q) (P -> False)) -> Q.
Proof.
  intros.
  destruct H.
  Definition f : (forall P Q : Prop, P \/ Q -> (P -> False) -> Q) := fun P Q orish H0 =>
  match orish with
    | (or_introl x) => (ex_falso_quodlibet Q (H0 x))
    | (or_intror y) => y
  end.
  exact (f P Q H H0).
Show Proof.
Qed.

Theorem anything_implies_true : forall P : Prop, (P -> True).
Proof.
  exact (fun P x => I).
Qed.

Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

Definition next_weekday (d:day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Check conj.

Theorem producty_pair : forall X Y H : Prop, (H -> X) -> (H -> Y) -> (H -> (and X Y)).

Proof.
exact ( fun X Y H f g h => (conj (f h) (g h))).
Show Proof.
Qed.

Inductive my_nat : Type :=
  | Zero
  | Suc (n : my_nat).

(**
Theorem frobenius (A : Set) (p : A -> Prop) (q : Prop) :
  (exists x : A, q /\ p x) <-> (q /\ exists x :A, p x).
Proof.
**)

Theorem and_implies : forall X Y H : Prop, (X -> H) -> ((and X Y) -> H).

Proof.
exact ( fun X Y H f p => f (proj1 p)).
Qed.

Definition addThem (n: nat) (m: nat) : nat := n + m.

Fixpoint addThem2 (n: nat) (m: nat) : nat :=
  match m with
    | 0 => n
    | S m' => S (addThem2 n m')
  end.

Eval compute in (addThem2 4 7).


Section Equality.
  Variable eq : forall X, X -> X -> Prop.
  Variable Q : forall X x, eq X x x.
  Variable R : forall X x y (p: X -> Prop), eq X x y -> p x -> p y.

  Arguments eq {X}.
  Arguments Q {X}.
  Arguments R {X x y}.
  Notation "s = t" := (eq s t) : type_scope.
  Notation "s <> t" := (~ s = t) : type_scope.

Goal True <> False.
Proof.
  intros H.
  change ((fun X => X) False).
  apply (R _ H).
  exact I.
  Show Proof.
Qed.

Goal True <> False.
Proof.
  intros H.
  apply (R (fun X => X) H).
  exact I.
  Show Proof.
Qed.

Goal true <> false.
Proof.
  intros H.
  change ((fun x:bool => if x then True else False) false).
  apply (R _ H).
  exact I.
  Show Proof.
Qed.

Goal forall x y, S x = S y -> x = y.
Proof.
  intros x y H.
  change ((fun z => x = match z with 0 => 0 | S z' => z' end) (S y)).
  apply (R _ H).
  exact (Q x).
  Show Proof.
Qed.

Goal forall x y, S x = S y -> x = y.
Proof.
 intros x y H.
  apply (R (fun z => x = match z with 0 => 0 | S z' => z' end) H).
  exact (Q _).
  Show Proof.
Qed.

Fact eq_sym X (x y: X) :
  x = y -> y = x.
Proof.
  intros H.
  change ((fun z => z = x) y).
  apply (R _ H).
  exact (Q x).
  Show Proof.
Qed.

Fact eq_trans X (x y z: X) :
  x = y -> y = z -> x = z.
Proof.
  intros e.
  change ((fun y => y = z -> x = z) y).
  apply (R _ e).
  exact (fun e => e).
  Show Proof.
Qed.

Fact eq_trans' X (x y z: X) :
  x = y -> y = z -> x = z.
Proof.
  intros e1 e2.
  exact (R _ e2 e1).
  Show Proof.
Qed.

Fact f_eq {X Y} (f: X -> Y) {x x'} :
    x = x' -> f x = f x'.
Proof.
  intros H.
  change ((fun z => f x = f z) x').
  apply (R _ H).
  exact (Q (f x)).
  Show Proof.
Qed.

Definition pred (x: nat) : nat :=
  match x with 0 => 0 | S x' => x' end.

Goal forall x y, S x = S y -> x = y.
Proof.
  intros x y H.
  exact (f_eq pred H).
Qed.

Goal true <> false.
Proof.
  intros H.
  enough (True = False) as H1.
  - exact (R (fun a => a) H1 I).
  - exact (f_eq (fun x:bool => if x then True else False) H).
  Show Proof.
Qed.

Goal forall X x y, x = y <-> forall p: X -> Prop, p x -> p y.
Proof.
  intros X x y.
  split.
  - intros H p H1.
    apply (R _ H H1).
  - intros H.
    change ((fun z => x = z) y).
    apply H.
    apply Q.
  Show Proof.
Qed.

End Equality.

(** Automation for predefined equality **)

Goal true <> false.
Proof.
  discriminate.
Qed.

Goal forall x, S x <> 0.
Proof.
  discriminate.
Qed.

Goal forall x y, S x = S y -> x = y.
Proof.
  congruence.
Qed.

Goal forall x y, S x = S y -> x = y.
Proof.
  intros x y [= H]. exact H.
Qed.

Goal forall x y, S x = S y -> x = y.
Proof.
  intros x y [= <-]. reflexivity.
Qed.

(** Leibniz definition of equality *)

Module Type EQ.
  Parameter eq : forall X, X -> X -> Prop.
  Parameter Q : forall X x, eq X x x.
  Parameter R : forall X x y (p: X -> Prop), eq X x y -> p x -> p y.
End EQ.

Module EqLeibniz : EQ.
  Definition eq X x y := forall p: X -> Prop, p x -> p y.
  Definition Q X x : eq X x x := fun p a => a.
  Definition R X x y p (f: eq X x y) := f p.
End EqLeibniz.

Fail Print R.
Print EqLeibniz.R.

Import EqLeibniz.
Print R.