Require Import List.
Open Scope list_scope.
Import ListNotations.
Require Import PeanoNat.

(* Inductive option (A : Type) := *)
(* | Just : A -> option A *)
(* | Nothing : option A. *)

(* Arguments Just [A] _. *)
(* Arguments Nothing [A]. *)

Inductive queue {X:Type} : Type :=
| fun_queue (F : list X) (R : list X).

Definition queue_empty {X: Type} (q: @queue X) :=
  match q with
  | fun_queue nil nil => true
  | fun_queue _ _ => false
  end.

(* Inductive list_reversed : forall X , list X -> list X -> Prop := *)
(*   | reversed X (a b : list X): (a = List.rev b) -> list_reversed X a b. *)

Inductive eq_queue : forall X : Type , @queue X -> @queue X -> Prop :=
| eq_q X (F1 R1 F2 R2 : @list X) (e: F1 ++ (rev R1) = F2 ++ (rev R2)): eq_queue X (fun_queue F1 R1) (fun_queue F2 R2).

Check pair.
Print option.
Locate pair.
Locate "[ ]".
Print list.
Check nil.
Check [1;2].
Check @fun_queue nat.
Definition myqueue := @fun_queue nat [1;2] [4;3].

(* Theorem a : forall a b c d e f, *)
(*     a + b + c + d + e = f. *)
(* Proof. *)
(*   intros. *)
  (* rewrite <- (PeanoNat.Nat.add_assoc a (b + c) d). *)
  (* Check PeanoNat.Nat.add_assoc a (b + c) d. *)
  (* Check PeanoNat.Nat.add_assoc a b (c + d). *)
(* Abort. *)

Fixpoint dequeue {X : Type} (q : @queue X) : option (X * (@queue X)) :=
  match q with
  | fun_queue F R =>
    match F with
    | nil => match R with
             | nil => None
             | cons h t => Some (let reverse := (rev R) in (pair
                                      (hd h reverse)
                                      (fun_queue (tl reverse) nil)))
             end
    | cons h t => Some (pair h (fun_queue t R))
    end
  end.

Fixpoint enqueue {X : Type} (a : X) (q : queue) : queue :=
  match q with
  | fun_queue F R =>
    fun_queue F (cons a R)
  end.

Theorem queue_empty_reflection (X : Type): forall q:@queue X,
    queue_empty q = true <-> q = fun_queue nil nil.
Proof.
  intros. split.
  - intros H. destruct q eqn:E. destruct F eqn:EF, R eqn:ER;try (simpl in H; discriminate).
    + reflexivity.
  - intros H. rewrite -> H. simpl. reflexivity.
Qed.

Theorem dequeue_for_empty_q_gives_none (X : Type): forall q:@queue X,
    dequeue q = None <-> q = fun_queue nil nil.
Proof.
  intros. split.
  - intros H. destruct q eqn:E. destruct F eqn:EF, R eqn:ER.
    + reflexivity.
    + simpl in H. discriminate H.
    + simpl in H. discriminate H.
    + simpl in H. discriminate H.
  - intros H. rewrite H. simpl. reflexivity.
Qed.

(* Fixpoint dequeue {X : Type} (q : queue X) : option (X * (queue X)) *)
(* Fixpoint enqueue {X : Type} (a : X) (q : queue X) : queue X *)
Theorem dequeue_enqueue (X : Type): forall x:X, forall q:@queue X,
      queue_empty q = true -> dequeue (enqueue x q) = Some (x, fun_queue nil nil).
Proof.
  intros. apply queue_empty_reflection in H. rewrite -> H. simpl. reflexivity.
Qed.

Inductive eq_dequeue: forall (X: Type)
                      (r1: option (X * (@queue X)))
                      (r2: option (X * (@queue X))),
            Prop :=
  | queues_empty (X: Type) : eq_dequeue X None None
  | queues_nonempty (X: Type)
                    (h: X)
                    (q1 : @queue X)
                    (q2 : @queue X)
                    (e: eq_queue X q1 q2) : eq_dequeue X (Some (h, q1)) (Some (h, q2)).

Notation "X '||' x '~==~' y" := (eq_dequeue X x y)
                                  (at level 50, left associativity).
Check nat || None ~==~ None.
Lemma eq_correct {X: Type} (q1 : @queue X) (q2: @queue X) :
      eq_queue X q1 q2 -> eq_dequeue X (dequeue q1) (dequeue q2).
Proof.
   destruct q1, q2.
   destruct F, F0 ; simpl.
   - destruct R, R0 ; simpl.
     + intro.
       apply (queues_empty X).
     + intro.
       remember (fun_queue [] []) as EQ.
       remember (fun_queue [] (x :: R0)) as NQ.
       destruct H.
       inversion HeqEQ ; subst.
       inversion HeqNQ ; subst.
       simpl in e.
       destruct (rev R0) ; simpl in e ; inversion e.
     + intro.
       remember (fun_queue [] []) as EQ.
       remember (fun_queue [] (x :: R)) as NQ.
       destruct H.
       inversion HeqEQ ; subst.
       inversion HeqNQ ; subst.
       simpl in e.
       destruct (rev R) ; simpl in e ; inversion e.
     + intro.
       remember (fun_queue [] (x :: R)) as Q1.
       remember (fun_queue [] (x0 :: R0)) as Q2.
       destruct H.
       inversion HeqQ1 ; subst.
       inversion HeqQ2 ; subst.
       Search "app_nil".
       rewrite app_nil_l in e.
       rewrite app_nil_l in e.
       Search "rev_".
       Search "f_equal".
       apply (f_equal (@rev X)) in e.
       rewrite rev_involutive in e.
       rewrite rev_involutive in e.
       inversion e ; subst.
       apply queues_nonempty.
       apply eq_q.
       reflexivity.
   - destruct R, R0 ; simpl.
     + intro.
       remember (fun_queue [] []) as EQ.
       remember (fun_queue (x :: F0) []) as NQ.
       destruct H.
       inversion HeqEQ ; subst.
       inversion HeqNQ ; subst.
       simpl in e. discriminate e.
     + intro.
       remember (fun_queue [] []) as EQ.
       remember (fun_queue (x :: F0) (x0 :: R0)) as NQ.
       destruct H.
       inversion HeqEQ ; subst.
       inversion HeqNQ ; subst.
       simpl in e. discriminate e.
     + intro.
       remember (fun_queue [] (x0 :: R)) as EQ.
       remember (fun_queue (x :: F0) []) as NQ.
       destruct H.
       inversion HeqEQ ; subst.
       inversion HeqNQ ; subst.
       simpl in e.
       rewrite app_nil_r in e.
       rewrite -> e.
       simpl.
       apply queues_nonempty.
       apply eq_q.
       reflexivity.
     + intro.
       remember (fun_queue [] (x0 :: R)) as EQ.
       remember (fun_queue (x :: F0) (x1 :: R0)) as NQ.
       destruct H.
       inversion HeqEQ ; subst.
       inversion HeqNQ ; subst.
       simpl in e.
       rewrite -> e.
       simpl.
       apply queues_nonempty.
       apply eq_q.
       simpl.
       rewrite app_nil_r.
       reflexivity.
   - destruct R, R0 ; simpl.
     + intro.
       remember (fun_queue [] []) as EQ.
       remember (fun_queue (x :: F) []) as NQ.
       destruct H.
       inversion HeqEQ ; subst.
       inversion HeqNQ ; subst.
       simpl in e. discriminate e.
     + intro.
       remember (fun_queue (x :: F) []) as EQ.
       remember (fun_queue [] (x0 :: R0)) as NQ.
       destruct H.
       inversion HeqEQ ; subst.
       inversion HeqNQ ; subst.
       simpl in e.
       rewrite <- e.
       simpl.
       apply queues_nonempty.
       rewrite app_nil_r.
       apply eq_q.
       reflexivity.
     + intro.
       remember (fun_queue (x :: F) (x0 :: R)) as EQ.
       remember (fun_queue [] []) as NQ.
       destruct H.
       inversion HeqEQ ; subst.
       inversion HeqNQ ; subst.
       simpl in e.
       discriminate e.
     + intro.
       remember (fun_queue (x :: F) (x0 :: R)) as EQ.
       remember (fun_queue [] (x1 :: R0)) as NQ.
       destruct H.
       inversion HeqEQ ; subst.
       inversion HeqNQ ; subst.
       simpl in e.
       rewrite <- e.
       simpl.
       apply queues_nonempty.
       apply eq_q.
       simpl.
       rewrite app_nil_r.
       reflexivity.
   - destruct R, R0 ; simpl.
     + intro.
       remember (fun_queue (x :: F) []) as EQ.
       remember (fun_queue (x0 :: F0) []) as NQ.
       destruct H.
       inversion HeqEQ ; subst.
       inversion HeqNQ ; subst.
       simpl in e.
       rewrite app_nil_r in e.
       rewrite app_nil_r in e.
       inversion e ; subst.
       apply queues_nonempty.
       apply eq_q.
       reflexivity.
     + intro.
       remember (fun_queue (x :: F) []) as EQ.
       remember (fun_queue (x0 :: F0) (x1 :: R0)) as NQ.
       destruct H.
       inversion HeqEQ ; subst.
       inversion HeqNQ ; subst.
       simpl in e.
       rewrite app_nil_r in e.
       inversion e ; subst.
       apply queues_nonempty.
       apply eq_q.
       simpl.
       rewrite app_nil_r.
       reflexivity.
     + intro.
       remember (fun_queue (x :: F) (x1 :: R)) as EQ.
       remember (fun_queue (x0 :: F0) []) as NQ.
       destruct H.
       inversion HeqEQ ; subst.
       inversion HeqNQ ; subst.
       simpl in e.
       inversion e ; subst.
       rewrite app_nil_r in e.
       rewrite app_nil_r in H1.
       apply queues_nonempty.
       apply eq_q.
       simpl.
       rewrite app_nil_r.
       rewrite <- H1.
       reflexivity.
     + intro.
       remember (fun_queue (x :: F) (x1 :: R)) as EQ.
       remember (fun_queue (x0 :: F0) (x2 :: R0)) as NQ.
       destruct H.
       inversion HeqEQ ; subst.
       inversion HeqNQ ; subst.
       simpl in e.
       inversion e ; subst.
       apply queues_nonempty.
       apply eq_q.
       simpl.
       rewrite <- H1.
       reflexivity.
Qed.

Lemma eq_correct_enqueue {X: Type} (q1 : @queue X) (q2: @queue X) :
      forall (x : X), eq_queue X q1 q2 -> eq_queue X (enqueue x q1) (enqueue x q2).
Proof.
  intros.
  destruct q1, q2.
  destruct F, F0 ; simpl.
  - destruct R, R0 ; simpl.
    + apply eq_q. reflexivity.
    + remember (fun_queue [] []) as EQ.
      remember (fun_queue [] (x0 :: R0)) as NQ.
      destruct H.
      inversion HeqEQ ; subst.
      inversion HeqNQ ; subst.
      simpl in e.
      destruct (rev R0).
      ++ rewrite app_nil_l in e.
         discriminate e.
      ++ simpl in e. discriminate e.
    + remember (fun_queue [] (x0 :: R)) as EQ.
      remember (fun_queue [] []) as NQ.
      destruct H.
      inversion HeqEQ ; subst.
      inversion HeqNQ ; subst.
      simpl in e.
      destruct (rev R).
      ++ rewrite app_nil_l in e.
         discriminate e.
      ++ simpl in e. discriminate e.
    + remember (fun_queue [] (x0 :: R)) as EQ.
      remember (fun_queue [] (x1 :: R0)) as NQ.
      destruct H.
      inversion HeqEQ ; subst.
      inversion HeqNQ ; subst.
      rewrite app_nil_l in e.
      rewrite app_nil_l in e.
      apply (f_equal (@rev X)) in e.
      rewrite rev_involutive in e.
      rewrite rev_involutive in e.
      inversion e ; subst.
      apply eq_q.
      reflexivity.
  - destruct R, R0 ; simpl.
    + remember (fun_queue [] []) as EQ.
      remember (fun_queue (x0 :: F0) []) as NQ.
      destruct H.
      inversion HeqEQ ; subst.
      inversion HeqNQ ; subst.
      simpl in e.
      rewrite app_nil_r in e.
      discriminate e.
    + remember (fun_queue [] []) as EQ.
      remember (fun_queue (x0 :: F0) (x1 :: R0)) as NQ.
      destruct H.
      inversion HeqEQ ; subst.
      inversion HeqNQ ; subst.
      simpl in e.
      discriminate e.
    + remember (fun_queue [] (x1 :: R)) as EQ.
      remember (fun_queue (x0 :: F0) []) as NQ.
      destruct H.
      inversion HeqEQ ; subst.
      inversion HeqNQ ; subst.
      simpl in e.
      rewrite app_nil_r in e.
      destruct (rev R) eqn:ER.
      ++ rewrite app_nil_l in e.
         intros.
         apply eq_q.
         rewrite app_nil_l.
         simpl.
         rewrite ER.
         rewrite app_nil_l.
         rewrite e.
         reflexivity.
      ++ injection e.
         intros.
         apply eq_q.
         rewrite app_nil_l.
         simpl.
         rewrite ER.
         rewrite -> e.
         reflexivity.
    + remember (fun_queue [] (x1 :: R)) as EQ.
      remember (fun_queue (x0 :: F0) (x2 :: R0)) as NQ.
      destruct H.
      inversion HeqEQ ; subst.
      inversion HeqNQ ; subst.
      simpl in e.
      apply eq_q.
      simpl.
      rewrite -> e.
      simpl.
      rewrite <- app_assoc.
      reflexivity.
  - destruct R, R0 ; simpl.
    + remember (fun_queue (x0 :: F) []) as EQ.
      remember (fun_queue [] []) as NQ.
      destruct H.
      inversion HeqEQ ; subst.
      inversion HeqNQ ; subst.
      simpl in e.
      rewrite app_nil_r in e.
      discriminate e.
    + remember (fun_queue (x0 :: F) []) as EQ.
      remember (fun_queue [] (x1 :: R0)) as NQ.
      destruct H.
      inversion HeqEQ ; subst.
      inversion HeqNQ ; subst.
      simpl in e.
      rewrite app_nil_r in e.
      apply eq_q.
      rewrite app_nil_l.
      rewrite e.
      simpl.
      reflexivity.
    + remember (fun_queue (x0 :: F) (x1 :: R)) as EQ.
      remember (fun_queue [] []) as NQ.
      destruct H.
      inversion HeqEQ ; subst.
      inversion HeqNQ ; subst.
      simpl in e.
      discriminate e.
    + remember (fun_queue (x0 :: F) (x1 :: R)) as EQ.
      remember (fun_queue [] (x2 :: R0)) as NQ.
      destruct H.
      inversion HeqEQ ; subst.
      inversion HeqNQ ; subst.
      rewrite app_nil_l in e.
      simpl in e.
      apply eq_q.
      simpl.
      rewrite <- e.
      (* rewrite <- app_assoc. *)
      rewrite app_assoc.
      simpl.
      reflexivity.
  - destruct R, R0 ; simpl.
    + remember (fun_queue (x0 :: F) []) as EQ.
      remember (fun_queue (x1 :: F0) []) as NQ.
      destruct H.
      inversion HeqEQ ; subst.
      inversion HeqNQ ; subst.
      simpl in e.
      rewrite app_nil_r in e.
      rewrite app_nil_r in e.
      rewrite e.
      apply eq_q.
       reflexivity.
    + remember (fun_queue (x0 :: F) []) as EQ.
      remember (fun_queue (x1 :: F0) (x2 :: R0)) as NQ.
      destruct H.
      inversion HeqEQ ; subst.
      inversion HeqNQ ; subst.
      simpl in e.
      rewrite app_nil_r in e.
      rewrite e.
      apply eq_q.
      simpl.
      rewrite <- app_assoc.
      reflexivity.
    + remember (fun_queue (x0 :: F) (x2 :: R)) as EQ.
      remember (fun_queue (x1 :: F0) []) as NQ.
      destruct H.
      inversion HeqEQ ; subst.
      inversion HeqNQ ; subst.
      simpl in e.
      rewrite app_nil_r in e.
      apply eq_q.
      rewrite <- e.
      simpl.
      rewrite app_assoc.
      reflexivity.
    + remember (fun_queue (x0 :: F) (x2 :: R)) as EQ.
      remember (fun_queue (x1 :: F0) (x3 :: R0)) as NQ.
      destruct H.
      inversion HeqEQ ; subst.
      inversion HeqNQ ; subst.
      simpl in e.
      inversion e ; subst.
      apply eq_q.
      simpl.
      rewrite <- app_assoc.
      assert (myH: x1 :: F ++ rev R ++ [x2] ++ [x] = (x1 :: F ++ rev R ++ [x2]) ++ [x]).
      ++ simpl. rewrite <- app_assoc. rewrite <- app_assoc. reflexivity.
      ++ rewrite -> myH. rewrite -> e.

      (* autorewrite *)
      repeat ( rewrite app_assoc ; simpl).
      repeat ( rewrite app_assoc in e ; simpl in e).
      reflexivity.

      (* Our attempts *)
      (* Check app_inv_tail [x] (x0 :: F ++ rev R ++ [x2]) (x1 :: F0 ++ (rev R0 ++ [x3])). *)
     (*  rewrite <- app_assoc. *)
     (*  Check (app_assoc (x0 :: F ++ rev R) [x2]). *)
     (*  rewrite -> (app_inv_tail [x] (x0 :: F ++ rev R ++ [x2]) (x1 :: F0 ++ (rev R0 ++ [x3]))). *)
     (*  apply Ha. *)
     (*  rewrite -> (app_inv_tail [x] _ (x1 :: F0 ++ (rev R0 ++ [x3]))). *)
     (*  rewrite -> (app_inv_tail [x] (x0 :: F ++ (rev R ++ [x2])) (F0 ++ (rev R0 ++ [x3]))). *)

     (*  rewrite e. *)
     (*  (* rewrite -> 2? app_assoc. *) *)
     (*  rewrite -> app_assoc with _ (x0 :: F ++ rev R) _ _. *)
     (*  remember (x0 :: F ++ rev R ++ [x2]) as A. *)
     (*  rewrite <- HeqA. *)
     (* (*  app_assoc *) *)
     (* (* : forall (A : Type) (l m n : list A), l ++ m ++ n = (l ++ m) ++ n *) *)

     (*  rewrite -> (app_assoc ) *)
      (*  rewrite -> e. *)
Qed.
(* Inductive eq_queue *)
(* Inductive eq_dequeue *)
(*
Inductive eq_dequeue: forall (X: Type)
                      (r1: option (X * (@queue X)))
                      (r2: option (X * (@queue X))),
            Prop :=
  | queues_empty (X: Type) : eq_dequeue X None None
  | queues_nonempty (X: Type)
                    (h: X)
                    (q1 : @queue X)
                    (q2 : @queue X)
                    (e: eq_queue X q1 q2) : eq_dequeue X (Some (h, q1)) (Some (h, q2)).
 *)
Lemma head_equal: forall (X : Type), forall (l: list X) (x:X) (x0:X),
      hd x ((rev l) ++ [x0]) = hd x (((rev l) ++ [x0]) ++ [x]).
Proof.
  intros. destruct ((rev l) ++ [x0]).
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Lemma tail_equal: forall (X : Type), forall (l: list X) (x:X),
      l <> [] -> tl (l ++ [x]) = tl (l) ++ [x].
Proof.
  destruct l as [|h t] eqn:E.
  - unfold not. simpl. intros. exfalso. apply H. reflexivity.
  - intros. simpl. reflexivity.
Qed.

Theorem dequeue_enqueue2 : forall (X : Type) (x:X), forall q:(@queue X),
      queue_empty q = false ->
      exists y:X, exists (q':@queue X), dequeue q = Some (y, q')
      -> X || (dequeue (enqueue x q)) ~==~ (Some (y, enqueue x q')).
Proof.
  intros X x q H. destruct q eqn:E. destruct F eqn:EF, R eqn:ER.
  - simpl in H. discriminate H.
  - clear H. exists (hd x (rev R)). exists (fun_queue (tl (rev R)) nil).
    intros H.
    rewrite -> ER.
    simpl. rewrite <- head_equal.
    (* hd x ((rev l ++ [x0]) ++ [x]) *)
    (* hd x (rev R) *)
    apply (queues_nonempty X). apply eq_q. simpl. rewrite app_nil_r. apply tail_equal.
    destruct l as [|h t].
    + simpl. unfold not. intros H1. discriminate H1.
    + simpl. unfold not. intros H1. destruct (rev t ++ [h]) as [|h1 t1].
      ++ simpl in H1. discriminate H1.
      ++ simpl in H1. discriminate H1.
  - clear H. exists (hd x F). exists (fun_queue (tl F) nil).
    intros H. rewrite -> EF.
    simpl. apply (queues_nonempty X). apply eq_q. reflexivity.
  - clear H. exists (hd x F). exists (fun_queue (tl F) R). intros H.
    rewrite -> EF. rewrite -> ER. simpl.
    apply (queues_nonempty X). apply eq_q. reflexivity.
Qed.

(* Unit tests *)

Example test_dequeue1 :
  dequeue (fun_queue nat nil nil) = None.
Proof. reflexivity. Qed.

Example test_dequeue2 :
  dequeue (fun_queue nat [1] nil) = Some (1, (fun_queue nat [] nil)).
Proof. reflexivity. Qed.

Example test_dequeue3 :
  dequeue (fun_queue nat [1;2;3] [5;4]) = Some (1, (fun_queue nat [2;3] [5;4])).
Proof. reflexivity. Qed.

Compute dequeue (fun_queue nat nil [2;1]).

Example test_dequeue4 :
  dequeue (fun_queue nat nil [3;2;1]) = Some (1, (fun_queue nat [2;3] nil)).
Proof. reflexivity. Qed.

Example test_dequeue5 :
  dequeue (fun_queue nat nil [1]) = Some (1, (fun_queue nat nil nil)).
Proof. reflexivity. Qed.

Compute dequeue myqueue.
Compute enqueue 1 (fun_queue nat nil nil).

Example test_enque1 :
  enqueue 1 (fun_queue nat nil nil) = fun_queue nat nil [1].
Proof. reflexivity. Qed.

Example test_enque2 :
  enqueue 5 (fun_queue nat [1;2] [4;3]) = fun_queue nat [1;2] [5;4;3].
Proof. reflexivity. Qed.


(* this is the exercise/follow-along file *)
Require Import EqNat.
Require Import List.
Require Import Bool.
Require Export PropLogic.

(* Wanna write some exercies for the students in a way that they can use the definitions *)

(* function that return true if F is a well-formed formula *)

(* How can we generate the truth table? *)

Definition some_assignments : assignment := ((A 1), false)::((A 2), true)::nil.

Example suitable_ex : suitable (Negation (Atom (A 1))) some_assignments.
Proof. compute; intros H; inversion H. Qed.

Example models_ex : models (Negation (Atom (A 1))) some_assignments.
Proof. compute; reflexivity. Qed.

Example sat_ex : satisfiable (Negation (Atom (A 1))).
Proof. unfold satisfiable; exists some_assignments; compute; reflexivity. Qed.

Example unsat_ex : unsatisfiable (Negation (Disjunction (Atom (A 1)) (Negation (Atom (A 1))))).
Proof.
  unfold unsatisfiable.
  unfold suitable.
  intros.
  simpl. simpl in H.
  destruct (find_assignment (A 1) a).
  destruct b; simpl; reflexivity.
  unfold not in H.
  assert (H1 : False -> None = Some false).
  + intros. inversion H0.
  + apply H1. apply H. reflexivity.
Qed.

Example valid_ex: valid (Disjunction (Atom (A 1)) (Negation (Atom (A 1)))).
Proof. rewrite -> tautology. apply unsat_ex. Qed.

(* Can't forget to check the Admitted proofs *)
Theorem suitable_subformula: forall F G a, ((subformula G F) = true) /\ (suitable F a) -> (suitable G a).
Admitted.

Lemma beq_atomic_refl: forall A, beq_atomic A A = true.
Proof.
  intros.
  destruct A.
  simpl. rewrite <- beq_nat_refl. reflexivity.
Qed.

Lemma beq_formula_refl: forall F, (beq_formula F F)=true.
Proof.
  intros.
  induction F.
  simpl. rewrite beq_atomic_refl. reflexivity.
  simpl. rewrite -> IHF. reflexivity.
  simpl. rewrite -> IHF1. rewrite -> IHF2. simpl. reflexivity.
Qed.

(*Lemma sub_ex: forall G F, subformula G (Negation (Disjunction (Negation F) (Negation G))) = true.
Proof.
  intro G.
  induction G.
  simpl.
  rewrite beq_atomic_refl.
  intro F.
  rewrite orb_true_r.
  reflexivity.
  intro F.
  induction F.
  assert (beq_formula G (Disjunction (Negation F) (Negation (Negation G)))=false).
  apply
  rewrite beq_formula_refl. simpl. rewrite -> orb_true_r. reflexivity.
  simpl.
  rewrite IHG.
  assert (beq_formula (Atom a) (Disjunction (Negation F) (Negation (Atom a)))=false).
  simpl. reflexivity.
  rewrite H0.
  assert (beq_formula (Atom a) (Negation F)=false).
  simpl. reflexivity.
  rewrite H1.
  destruct (subformula (Atom a) F).
  simpl. reflexivity.
  simpl.
  assert (beq_atomic a a=true).
  destruct a.
  simpl. SearchAbout nat. rewrite <- beq_nat_refl. reflexivity.
  rewrite H2.
  reflexivity.
  simpl.
  assert (beq_formula G G=true).
  destruct G. simpl. reflexivity.*)

(* Show that F -> G is valid and F is valid, then G is valid *)

Theorem q21_h1: forall F G, valid(Negation (Disjunction (Negation F) (Negation G))) /\ valid(F) -> valid(G).
Proof.
  intros.
  inversion H.
  unfold valid in H1.
  unfold valid in H0.
  unfold valid.
  intros.
  assert (sub1: (subformula G (Negation (Disjunction (Negation F) (Negation G)))) = true).
    simpl.
    induction G.
    simpl. destruct (subformula (Atom a0)).
    simpl. reflexivity. simpl. unfold beq_atomic. destruct a0. assert ((beq_nat n n)=true). destruct n. reflexivity. simpl. reflexivity.
    destruct (beq_formula G (Negation (Disjunction (Negation F) (Negation G)))).
    reflexivity.
    destruct (beq_formula G (Disjunction (Negation F) (Negation G))).
    reflexivity.
    destruct (beq_formula G (Negation G)). destruct (beq_formula G (Negation F)).
    simpl. reflexivity.
    destruct (subformula G F). simpl. reflexivity. reflexivity.
    destruct (subformula G G). destruct (beq_formula G (Negation F)).
    reflexivity.
    destruct (subformula G F).
    reflexivity. reflexivity.
    destruct (beq_formula G (Negation F)).
    reflexivity.
    destruct (subformula G F).
    reflexivity.
    simpl.
    induction G. simpl. destruct (subformula (Atom a0) F).
    simpl. reflexivity. simpl.

(* F -> G is satisfiable and F is satisfiable, then G is satisfiable *)
(* Not true. Can find a counterexample*)

Theorem q22_h1: forall F G, satisfiable(Negation (Disjunction (Negation F) (Negation G))) /\ satisfiable(F) -> satisfiable(G).

(* F -> G is valid and F is satisfiable, then G is satisfiable *)

Theorem q23_h1: forall F G, valid(Negation (Disjunction (Negation F) (Negation G))) /\ satisfiable(F) -> satisfiable(G).
Proof.
  intros.
  inversion H.
  unfold valid in H0.
  unfold satisfiable.
  unfold satisfiable in H1.
  inversion H1.
  exists (x).
  intros.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Permutation Arith Omega.

Require Import utils.

Set Implicit Arguments.

(** * Intuionistic Linear Logic *)

Definition ill_vars := nat.

Inductive ill_conn := ll_with | ll_limp | ll_rimp | ll_times | ll_plus.
Inductive ill_cst := ll_one | ll_bot | ll_top.

Inductive ill_form : Set :=
  | ill_var  : ill_vars -> ill_form
  | ill_zero : ill_cst  -> ill_form
  | ill_bang : ill_form -> ill_form
  | ill_bin  : ill_conn -> ill_form -> ill_form -> ill_form.

Fact ill_form_eq_dec (f g : ill_form) : { f = g } + { f <> g }.
Proof.
  decide equality.
  + apply eq_nat_dec.
  + decide equality.
  + decide equality.
Qed.

(* Symbols for cut&paste ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  ❗   ‼  ∅  ⊢ *)

Notation "⟙" := (ill_zero ll_top).
Notation "⟘" := (ill_zero ll_bot).
Notation 𝝐 := (ill_zero ll_one).

Infix "&" := (ill_bin ll_with) (at level 50, only parsing).
Infix "﹠" := (ill_bin ll_with) (at level 50).

Infix "⊗" := (ill_bin ll_times) (at level 50).
Infix "⊕" := (ill_bin ll_plus) (at level 50).

Infix "-o" := (ill_bin ll_limp) (at level 51, right associativity).
Infix "o-" := (ill_bin ll_rimp) (at level 52, left associativity).

Notation "'!' x" := (ill_bang x) (at level 52).

Definition ill_lbang := map (fun x => !x).

Notation "'!l' x" := (ill_lbang x) (at level 60, only parsing).

Notation "‼ x" := (ill_lbang x) (at level 52).

Notation "£" := ill_var.

Notation "∅" := nil (only parsing).

Infix "~!" := (perm_bang_t ill_bang) (at level 70).
Infix "~p" := (@perm_t _) (at level 70).

Hint Resolve perm_bang_t_refl perm_bang_t_cons.

Definition perm_bool b :=
  match b with
    | true => @perm_t ill_form
    | _    => perm_bang_t ill_bang
  end.

Notation " x '~[' b ']' y " := (perm_bool b x y) (at level 70, format "x  ~[ b ]  y").

Fact illnc_perm_t_map_inv_t l m : ‼ l ~! m -> { l' | m = ‼ l' }.
Proof.
  apply perm_bang_t_map_inv_t.
  inversion 1; trivial.
Qed.

Hint Resolve perm_t_refl.

Fact ill_perm_t_refl b l : l ~[b] l.
Proof. destruct b; simpl; auto. Qed.

Hint Resolve ill_perm_t_refl.

Fact ill_perm_t_app b l1 l2 m1 m2 : l1 ~[b] m1 -> l2 ~[b] m2 -> l1++l2 ~[b] m1++m2.
Proof.
  destruct b; simpl.
  + apply perm_t_app.
  + apply perm_bang_t_app.
Qed.

Fact ill_perm_t_trans b l m p : l ~[b] m -> m ~[b] p -> l ~[b] p.
Proof.
  destruct b; simpl.
  + apply perm_t_trans.
  + apply perm_bang_t_trans.
Qed.

Fact ill_perm_t_swap b x y l : !x::!y::l ~[b] !y::!x::l.
Proof.
  destruct b; simpl; constructor 3.
Qed.

Fact ill_perm_t_map_inv_t b l m : ‼ l ~[b] m -> { l' | m = ‼ l' }.
Proof.
  destruct b; simpl.
  + intros H.
    destruct perm_t_map_inv_t with (1 := H) as (l' & H1 & _).
    exists l'; auto.
  + apply illnc_perm_t_map_inv_t.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.
From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=   Nil : lst | Cons : natural -> lst -> lst.

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

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

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

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint rotate (rotate_arg0 : natural) (rotate_arg1 : lst) : lst
           := match rotate_arg0, rotate_arg1 with
              | Zero, x => x
              | Succ n, Nil => Nil
              | Succ n, Cons y x => rotate n (append x (Cons y Nil))
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma rotate_len_append : forall (x y : lst), rotate (len x) (append x y) = append y x.
Proof.
   intro.
   induction x.
   - intros. simpl. rewrite append_nil. reflexivity.
   - intros. simpl. rewrite append_assoc. rewrite IHx. lfind. Admitted.


(*|
###############################
Closing a lemma on list of nats
###############################

:Link: https://stackoverflow.com/q/59747670
|*)

(*|
Question
********

I am stuck to prove the following admitted lemma. Kindly help me how
to proceed.

The function ``sumoneseq`` adds to and returns list of repetitions of
``true``, in reverse order. Given [\ **true**;false;\ **true**;\
**true**;false;\ **true**;\ **true**;\ **true**], it returns [3;2;1].
The function ``sumones`` adds values in the ``nat`` list. Given
[3;2;1], it returns 6.
|*)

Notation "x :: l" := (cons x l) (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Fixpoint sumoneseq (lb: list bool) (ln: list nat) : list nat :=
  match lb, ln with
  | nil, 0::tl'' => tl''
  | nil, _ => ln
  | true::tl', nil => sumoneseq tl' (1::nil)
  | true::tl', h::tl'' => sumoneseq tl' (S h::tl'')
  | false::tl', 0::tl'' => sumoneseq tl' ln
  | false::tl', _ => sumoneseq tl' (0::ln)
  end.

Fixpoint sumones (ln: list nat) : nat :=
  match ln with
  | nil => 0
  | r::tl => r + (sumones tl)
  end.

Lemma sumones_l: forall lb ln,
    sumones (sumoneseq lb ln) = sumones ln + sumones (sumoneseq lb []).
Proof.
  induction ln.
  + simpl. auto.
  + simpl.
Admitted.

(*|
Answer
******

Two things:

1. When proving a property of some function ``f`` using a direct
   induction, choose the parameter on which ``f`` is structurally
   recursive on. So in your example involving ``sumoneseq``, induct on
   ``lb`` instead of ``ln`` since ``sumoneseq`` is structurally
   recursive on ``lb``.
2. Proving a property of some function ``f`` where one or more of its
   arguments are fixed to specific values (e.g. ``sumoneseq`` with its
   second argument being ``[]``) by direct induction is almost
   guaranteed to fail, since the value of that argument varies between
   recursive calls of ``f``, meaning that you would not be able to
   apply the induction hypothesis in your inductive case. In that
   case, you need to manually generalize the induction hypothesis by
   finding a more general property on which ``f`` holds, with each of
   its arguments being sufficiently general. For example, instead of
   proving ``forall lb ln, sumones (sumoneseq lb ln) = sumones ln +
   sumones (sumoneseq lb [])`` directly by induction, try generalizing
   it to something like ``forall lb ln ln', sumones (sumoneseq lb (ln
   ++ ln')) = sumones ln + sumones (sumoneseq lb ln')`` instead and
   prove *that* by direct induction. Your desired result then follows
   as a corollary of that more general result.

You can learn more about generalizing the induction hypothesis in
`James Wilcox's blog post
<https://jamesrwilcox.com/InductionExercises.html>`__ which generously
includes 8 exercises of increasing difficulty on doing just that.

Now try to prove your lemma with these two points in mind. *Hint: when
proving your more general statement about* ``sumoneseq`` *by direct
induction, you may also find it helpful to extract out a suitable
lemma on a certain property of* ``sumones``.

If you've tried again to no avail then the full solution is provided
below the horizontal rule (**spoiler alert!**).

----

Here goes the full solution. As you can probably see, a lot of case
analysis is required on top of the main induction (likely due to your
optimization in ``sumoneseq`` of discarding ``0``\ s from ``ln``) and
the reasoning for many of these cases are actually very similar and
repetitive. I could've probably further shortened the proof script
with a bit of ``Ltac`` programming looking for similar patterns in the
various cases but I haven't bothered doing so since I just hacked it
up straight away.
|*)

Reset Initial. (* .none *)
From Coq Require Import List Lia.
Import ListNotations.

Fixpoint sumoneseq (lb: list bool) (ln: list nat) : list nat :=
  match lb, ln with
  | nil, 0::tl'' => tl''
  | nil, _ => ln
  | true::tl', nil => sumoneseq tl' (1::nil)
  | true::tl', h::tl'' => sumoneseq tl' (S h::tl'')
  | false::tl', 0::tl'' => sumoneseq tl' ln
  | false::tl', _ => sumoneseq tl' (0::ln)
  end.

Fixpoint sumones (ln: list nat) : nat :=
  match ln with
  | nil => 0
  | r::tl => r + (sumones tl)
  end.

Lemma sumones_app_plus_distr : forall l l',
    sumones (l ++ l') = sumones l + sumones l'.
Proof.
  induction l; simpl; intros; auto.
  rewrite IHl; lia.
Qed.

Lemma sumones_l' : forall lb ln ln',
    sumones (sumoneseq lb (ln ++ ln')) =
    sumones ln + sumones (sumoneseq lb ln').
Proof.
  induction lb; simpl; intros.
  - destruct ln, ln'; simpl; auto.
    + destruct n; rewrite app_nil_r; simpl; auto.
    + destruct n, n0; simpl; rewrite sumones_app_plus_distr;
        simpl; lia.
  - destruct a, ln, ln'; simpl; auto.
    + replace (S n :: ln ++ []) with ((S n :: ln) ++ [])
        by reflexivity.
      replace [1] with ([1] ++ []) by now rewrite app_nil_r.
      repeat rewrite IHlb; simpl; lia.
    + replace (S n :: ln ++ n0 :: ln')
        with ((S n :: ln ++ [n0]) ++ ln')
        by (simpl; now rewrite <- app_assoc).
      replace (S n0 :: ln') with ([S n0] ++ ln')
        by reflexivity.
      repeat rewrite IHlb.
      replace (S n :: ln ++ [n0])
        with ((S n :: ln) ++ [n0])
        by reflexivity.
      repeat rewrite sumones_app_plus_distr; simpl; lia.
    + destruct n.
      * replace (0 :: ln ++ []) with ((0 :: ln) ++ [])
          by reflexivity.
        replace [0] with ([0] ++ [])
          by now rewrite app_nil_r.
        repeat rewrite IHlb; simpl; lia.
      * replace (0 :: S n :: ln ++ [])
          with ((0 :: S n :: ln) ++ []) by reflexivity.
        replace [0] with ([0] ++ [])
          by now rewrite app_nil_r.
        repeat rewrite IHlb; simpl; lia.
    + destruct n, n0.
      * replace (0 :: ln ++ 0 :: ln')
          with ((0 :: ln ++ [0]) ++ ln')
          by (simpl; now rewrite <- app_assoc).
        replace (0 :: ln') with ([0] ++ ln') by reflexivity.
        repeat rewrite IHlb.
        repeat (repeat rewrite sumones_app_plus_distr;
                simpl); lia.
      * replace (0 :: ln ++ S n0 :: ln')
          with ((0 :: ln ++ [S n0]) ++ ln')
          by (simpl; now rewrite <- app_assoc).
        replace (0 :: S n0 :: ln') with ([0; S n0] ++ ln')
          by reflexivity.
        repeat rewrite IHlb.
        repeat (repeat rewrite sumones_app_plus_distr;
                simpl); lia.
      * replace (0 :: S n :: ln ++ 0 :: ln')
          with ((0 :: S n :: ln ++ [0]) ++ ln')
          by (simpl; now rewrite <- app_assoc).
        replace (0 :: ln') with ([0] ++ ln')
          by reflexivity.
        repeat rewrite IHlb.
        repeat (repeat rewrite sumones_app_plus_distr;
                simpl); lia.
      * replace (0 :: S n :: ln ++ S n0 :: ln')
          with ((0 :: S n :: ln ++ [S n0]) ++ ln')
          by (simpl; now rewrite <- app_assoc).
        replace (0 :: S n0 :: ln') with ([0; S n0] ++ ln')
          by reflexivity.
        repeat rewrite IHlb.
        repeat (repeat rewrite sumones_app_plus_distr;
                simpl); lia.
Qed.

Lemma sumones_l: forall lb ln,
    sumones (sumoneseq lb ln) =
    sumones ln + sumones (sumoneseq lb []).
Proof.
  intros; replace (sumoneseq lb ln)
            with (sumoneseq lb (ln ++ []))
    by (now rewrite app_nil_r); apply sumones_l'.
Qed.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Lemma ord_minn_le n (i j : 'I_n) : minn i j < n.
Proof. by rewrite gtn_min ltn_ord. Qed.
Definition ord_minn {n} (i j : 'I_n) := Ordinal (ord_minn_le i j).

Section ord_min.
Variable (n : nat).
Notation T := (ord_max : 'I_n.+1).
Notation min := (@ord_minn n.+1).

Lemma minTo : left_id T min.
Proof. by move=> i; apply/val_inj; rewrite /= (minn_idPr _) ?leq_ord. Qed.

Lemma minoT : right_id T min.
Proof. by move=> i; apply/val_inj; rewrite /= (minn_idPl _) ?leq_ord. Qed.

Lemma minoA : associative min.
Proof. by move=> ???; apply/val_inj/minnA. Qed.

Lemma minoC : commutative min.
Proof. by move=> ??; apply/val_inj/minnC. Qed.

Canonical ord_minn_monoid := Monoid.Law minoA minTo minoT.
Canonical ord_minn_comoid := Monoid.ComLaw minoC.

End ord_min.

Notation "\min_ ( i | P ) F" := (\big[ord_minn/ord_max]_(i | P%B) F%N)
  (at level 41, F at level 41, i at level 50,
   format "'[' \min_ ( i  |  P ) '/  '  F ']'") : nat_scope.
Notation "\min_ i F" := (\big[ord_minn/ord_max]_i F%N)
  (at level 41, F at level 41, i at level 0,
   format "'[' \min_ i '/  '  F ']'") : nat_scope.
Notation "\min_ ( i 'in' A | P ) F" :=
 (\big[ord_minn/ord_max]_(i in A | P%B) F%N)
  (at level 41, F at level 41, i, A at level 50,
   format "'[' \min_ ( i  'in'  A  |  P ) '/  '  F ']'") : nat_scope.
Notation "\min_ ( i 'in' A ) F" :=
 (\big[ord_minn/ord_max]_(i in A) F%N)
  (at level 41, F at level 41, i, A at level 50,
   format "'[' \min_ ( i  'in'  A ) '/  '  F ']'") : nat_scope.

Section extra_bigmin.

Variables (n : nat) (I : finType).
Implicit Type (F : I -> 'I_n.+1).

Lemma geq_bigmin_cond (P : pred I) F i0 :
  P i0 -> F i0 >= \min_(i | P i) F i.
Proof. by move=> Pi0; rewrite (bigD1 i0) //= geq_minl. Qed.
Arguments geq_bigmin_cond [P F].

Lemma geq_bigmin F (i0 : I) : F i0 >= \min_i F i.
Proof. exact: geq_bigmin_cond. Qed.

Lemma bigmin_geqP (P : pred I) (m : 'I_n.+1) F :
  reflect (forall i, P i -> F i >= m) (\min_(i | P i) F i >= m).
Proof.
apply: (iffP idP) => leFm => [i Pi|].
  by apply: leq_trans leFm _; apply: geq_bigmin_cond.
by elim/big_ind: _; rewrite ?leq_ord // => m1 m2; rewrite leq_min => ->.
Qed.

Lemma bigmin_inf i0 (P : pred I) (m : 'I_n.+1) F :
  P i0 -> m >= F i0 -> m >= \min_(i | P i) F i.
Proof.
by move=> Pi0 le_m_Fi0; apply: leq_trans (geq_bigmin_cond i0 Pi0) _.
Qed.

Lemma bigmin_eq_arg i0 (P : pred I) F :
  P i0 -> \min_(i | P i) F i = F [arg min_(i < i0 | P i) F i].
Proof.
move=> Pi0; case: arg_minnP => //= i Pi minFi.
by apply/val_inj/eqP; rewrite eqn_leq geq_bigmin_cond //=; apply/bigmin_geqP.
Qed.

Lemma eq_bigmin_cond (A : pred I) F :
  #|A| > 0 -> {i0 | i0 \in A & \min_(i in A) F i = F i0}.
Proof.
case: (pickP A) => [i0 Ai0 _ | ]; last by move/eq_card0->.
by exists [arg min_(i < i0 in A) F i]; [case: arg_minnP | apply: bigmin_eq_arg].
Qed.

Lemma eq_bigmin F : #|I| > 0 -> {i0 : I | \min_i F i = F i0}.
Proof. by case/(eq_bigmin_cond F) => x _ ->; exists x. Qed.

Lemma bigmin_setU (A B : {set I}) F :
  \min_(i in (A :|: B)) F i =
  ord_minn (\min_(i in A) F i) (\min_(i in B) F i).
Proof.
have d : [disjoint A :\: B & B] by rewrite -setI_eq0 setIDAC setDIl setDv setI0.
rewrite (eq_bigl [predU (A :\: B) & B]) ?bigU//=; last first.
  by move=> y; rewrite !inE; case: (_ \in _) (_ \in _) => [] [].
symmetry; rewrite (big_setID B) /= [X in ord_minn X _]minoC -minoA.
congr (ord_minn _ _); apply: val_inj; rewrite /= (minn_idPr _)//.
by apply/bigmin_geqP=> i; rewrite inE => /andP[iA iB]; rewrite (bigmin_inf iB).
Qed.

End extra_bigmin.

Arguments geq_bigmin_cond [n I P F].
Arguments geq_bigmin [n I F].
Arguments bigmin_geqP {n I P m F}.
Arguments bigmin_inf [n I] i0 [P m F].
Arguments bigmin_eq_arg [n I] i0 [P F].

Section extra_fintype.

Variable V : finType.

Definition relto (a : pred V) (g : rel V) := [rel x y | (y \in a) && g x y].
Definition relfrom (a : pred V) (g : rel V) := [rel x y | (x \in a) && g x y].

Lemma connect_rev (g : rel V) :
  connect g =2 (fun x => connect (fun x => g^~ x) ^~ x).
Proof.
move=> x y; apply/connectP/connectP=> [] [p gp ->];
[exists (rev (belast x p))|exists (rev (belast y p))]; rewrite ?rev_path //;
by case: (lastP p) => //= ??; rewrite belast_rcons rev_cons last_rcons.
Qed.

Lemma path_to a g z p : path (relto a g) z p = (path g z p) && (all a p).
Proof.
apply/(pathP z)/idP => [fgi|/andP[/pathP gi] /allP ga]; last first.
  by move=> i i_lt /=; rewrite gi ?andbT ?[_ \in _]ga // mem_nth.
rewrite (appP (pathP z) idP) //=; last by move=> i /fgi /= /andP[_ ->].
by apply/(all_nthP z) => i /fgi /andP [].
Qed.

Lemma path_from a g z p :
  path (relfrom a g) z p = (path g z p) && (all a (belast z p)).
Proof. by rewrite -rev_path path_to all_rev rev_path. Qed.

Lemma connect_to (a : pred V) (g : rel V) x z : connect g x z ->
  exists y, [/\ (y \in a) ==> (x == y) && (x \in a),
                 connect g x y & connect (relto a g) y z].
Proof.
move=> /connectP [p gxp ->].
pose P := [pred i | let y := nth x (x :: p) i in
  [&& connect g x y & connect (relto a g) y (last x p)]].
have [] := @ex_minnP P.
  by exists (size p); rewrite /= nth_last (path_connect gxp) //= mem_last.
move=> i /= /andP[g1 g2] i_min; exists (nth x (x :: p) i); split=> //.
case: i => [|i] //= in g1 g2 i_min *; first by rewrite eqxx /= implybb.
have i_lt : i < size p.
  by rewrite i_min // !nth_last /= (path_connect gxp) //= mem_last.
have [<-/=|neq_xpi /=] := altP eqP; first by rewrite implybb.
have := i_min i; rewrite ltnn => /contraNF /(_ isT) <-; apply/implyP=> axpi.
rewrite (connect_trans _ g2) ?andbT //; last first.
  by rewrite connect1 //= [_ \in _]axpi /= (pathP x _).
by rewrite (path_connect gxp) //= mem_nth //= ltnW.
Qed.

Lemma connect_from (a : pred V) (g : rel V) x z : connect g x z ->
  exists y, [/\ (y \in a) ==> (z == y) && (z \in a),
                connect (relfrom a g) x y & connect g y z].
Proof.
rewrite connect_rev => cgxz; have [y [ayaz]]//= := connect_to a cgxz.
by exists y; split; rewrite // connect_rev.
Qed.

Lemma connect1l (g : rel V) x z :
  connect g x z -> z != x -> exists2 y, g x y & connect g y z.
Proof.
move=> /connectP [[|y p] //= xyp ->]; first by rewrite eqxx.
by move: xyp=> /andP[]; exists y => //; apply/connectP; exists p.
Qed.

Lemma connect1r (g : rel V) x z :
  connect g x z -> z != x -> exists2 y, connect g x y & g y z.
Proof.
move=> xz zNx; move: xz; rewrite connect_rev => /connect1l.
by rewrite eq_sym => /(_ zNx) [y]; exists y; rewrite // connect_rev.
Qed.

Section connected.

Variable (g : rel V).

Definition connected := forall x y, connect g x y.

Lemma cover1U (A : {set V}) P : cover (A |: P) = A :|: cover P.
Proof. by apply/setP => x; rewrite /cover bigcup_setU big_set1. Qed.

Lemma connectedU (A B : {set V}) : {in A &, connected} -> {in B &, connected} ->
  {in A & B, connected} -> {in B & A, connected} -> {in A :|: B &, connected}.
Proof.
move=> cA cB cAB cBA z t; rewrite !inE => /orP[zA|zB] /orP[tA|tB];
by[apply: cA|apply: cB|apply: cAB|apply: cBA].
Qed.

End connected.

Section Symconnect.

Variable r : rel V.

(* x is symconnected to y *)
Definition symconnect x y := connect r x y && connect r y x.

Lemma symconnect0 : reflexive symconnect.
Proof. by move=> x; apply/andP. Qed.

Lemma symconnect_sym : symmetric symconnect.
Proof. by move=> x y; apply/andP/andP=> [] []. Qed.

Lemma symconnect_trans : transitive symconnect.
Proof.
move=> x y z /andP[Cyx Cxy] /andP[Cxz Czx].
by rewrite /symconnect (connect_trans Cyx) ?(connect_trans Czx).
Qed.
Hint Resolve symconnect0 symconnect_sym symconnect_trans : core.

Lemma symconnect_equiv : equivalence_rel symconnect.
Proof. by apply/equivalence_relP; split; last apply/sym_left_transitive. Qed.

(*************************************************)
(* Connected components of the graph, abstractly *)
(*************************************************)

Definition sccs := equivalence_partition symconnect setT.

Lemma sccs_partition : partition sccs setT.
Proof. by apply: equivalence_partitionP => ?*; apply: symconnect_equiv. Qed.

Definition cover_sccs := cover_partition sccs_partition.

Lemma trivIset_sccs : trivIset sccs.
Proof. by case/and3P: sccs_partition. Qed.
Hint Resolve trivIset_sccs : core.

Notation scc_of := (pblock sccs).

Lemma mem_scc x y : x \in scc_of y = symconnect y x.
Proof.
by rewrite pblock_equivalence_partition // => ?*; apply: symconnect_equiv.
Qed.

Definition def_scc scc x := @def_pblock _ _ scc x trivIset_sccs.

Definition is_subscc (A : {set V}) := A != set0 /\
                                      {in A &, forall x y, connect r x y}.

Lemma is_subscc_in_scc (A : {set V}) :
  is_subscc A -> exists2 scc, scc \in sccs & A \subset scc.
Proof.
move=> []; have [->|[x xA]] := set_0Vmem A; first by rewrite eqxx.
move=> AN0 A_sub; exists (scc_of x); first by rewrite pblock_mem ?cover_sccs.
by apply/subsetP => y yA; rewrite mem_scc /symconnect !A_sub.
Qed.

Lemma is_subscc1 x (A : {set V}) : x \in A ->
  (forall y, y \in A -> connect r x y /\ connect r y x) -> is_subscc A.
Proof.
move=> xA AP; split; first by apply: contraTneq xA => ->; rewrite inE.
by move=> y z /AP [xy yx] /AP [xz zx]; rewrite (connect_trans yx).
Qed.

End Symconnect.

Lemma setUD (B A C : {set V}) : B \subset A -> C \subset B ->
  (A :\: B) :|: (B :\: C) = (A :\: C).
Proof.
move=> subBA subCB; apply/setP=> x; rewrite !inE.
have /implyP  := subsetP subBA x; have /implyP  := subsetP subCB x.
by do !case: (_ \in _).
Qed.

Lemma setUDl (T : finType) (A B : {set T}) : A :|: B :\: A = A :|: B.
Proof. by apply/setP=> x; rewrite !inE; do !case: (_ \in _). Qed.

Lemma subset_cover (sccs sccs' : {set {set V}}) :
  sccs \subset sccs' -> cover sccs \subset cover sccs'.
Proof.
move=> /subsetP subsccs; apply/subsetP=> x /bigcupP [scc /subsccs].
by move=> scc' x_in; apply/bigcupP; exists scc.
Qed.

Lemma disjoint1s (A : pred V) (x : V) : [disjoint [set x] & A] = (x \notin A).
Proof.
apply/pred0P/idP=> [/(_ x)/=|]; first by rewrite inE eqxx /= => ->.
by move=> xNA y; rewrite !inE; case: eqP => //= ->; apply/negbTE.
Qed.

Lemma disjoints1 (A : pred V) (x : V) : [disjoint A & [set x]] = (x \notin A).
Proof. by rewrite disjoint_sym disjoint1s. Qed.

End extra_fintype.


Require Export A_4_2.

Module A5_1.

(* 5.1 导数的概念 *)
Definition derivative (f : Fun) (x0 y0' : R) :=
  Function f /\ (∃ δ', δ' > 0 /\ Neighbor x0 δ' ⊂ dom[f]) /\
  (limit {` λ x y, y = (f[x] - f[x0]) / (x - x0) `} x0 y0').

(* 在某去心邻域导数 *)
Definition derivativeU (f : Fun) (x0 y0' δ' : R) :=
  Function f /\ (δ' > 0 /\ Neighbor x0 δ' ⊂ dom[f]) /\
  (limit {` λ x y, y = (f[x] - f[x0]) / (x - x0) `} x0 y0').

(* 可导 *)
Definition derivable (f : Fun) (x0 : R) := (∃ y0', derivative f x0 y0').

Definition derivableU (f : Fun) (x0 δ' : R)
  := (∃ y0', derivativeU f x0 y0' δ').

(* 右导数 *)
Definition derivative_pos (f : Fun) (x0 y0' : R) :=
  Function f /\ (∃ δ', δ' > 0 /\ rightNeighbor x0 δ' ⊂ dom[f]) /\
  (limit_pos {` λ x y, y = (f[x] - f[x0]) / (x - x0) `} x0 y0').

(* 左导数 *)
Definition derivative_neg (f : Fun) (x0 y0' : R) :=
  Function f /\ (∃ δ', δ' > 0 /\ leftNeighbor x0 δ' ⊂ dom[f]) /\
  (limit_neg {` λ x y, y = (f[x] - f[x0]) / (x - x0) `} x0 y0').

(* 导数唯一性 *)
Theorem derivativeUnique : ∀ (f : Fun) (x0 A B : R),
  derivative f x0 A -> derivative f x0 B -> A = B.
Proof.
  unfold derivative.
  intros f x0 A B [H0 [H1 H2]] [H3 [H4 H5]].
  eapply Theorem3_2; eauto.
Qed.

Definition der f x := cR \{ λ y', derivative f x y' \}.

Notation "f '[ x ]" := (der f x)(at level 20).

Theorem derEqual : ∀ (f : Fun) (x y' : R),
  derivative f x y' -> f '[x] = y'.
Proof.
  intros f x y' H0.
  assert (H1 : derivative f x (f '[x])).
  { assert (I1 : NotEmpty \{ λ y', derivative f x y' \}).
    { exists y'. apply AxiomII. assumption. }
    apply AxiomcR in I1. applyAxiomII I1.
    assumption. }
  eapply derivativeUnique; eauto.
Qed.

(* 定理5.1 可导一定连续 *)
Theorem Theorem5_1 : ∀ (f : Fun) (x0 : R),
  derivable f x0 -> Continuous f x0.
Proof.
  intros f x0 [y0' [H0 [[δ' [H1 H2]] H3]]].
  assert (H4 : x0 ∈ dom[f]).
  { apply H2. apply AxiomII. rewrite Abs_ge; lra. }
  split; auto. unfold limit. split; auto. exists δ'.
  assert (H5 : Neighbor0 x0 δ' ⊂ dom[ f]).
  { intros x I1. apply H2. applyAxiomII I1.
    apply AxiomII. apply I1. }
  repeat split; auto. intros ε H6.
  unfold limit in H3. destruct H3 as [H3 [δ1' [H7 [H8 H9]]]].
  assert (H10 : ∀ ε', ε' > 0 -> ∃ δ, 0 < δ /\ (∀ x, 0 < Abs [x - x0] < δ
    -> (ε' + Abs[y0']) * Abs[x - x0] < ε)).
  { intros ε' I1. exists (ε / (ε' + Abs[y0'])).
    assert (I4 : 0 < ε' + Abs [y0']).
    { generalize (Abs_Rge0 y0'). intro J1. lra. }
    split.
    - apply Rdiv_lt_0_compat; auto.
    - intros x [I2 I3].
      apply Rmult_lt_compat_l with (r := ε' + Abs [y0']) in I3; auto.
      assert (I5 : (ε' + Abs [y0']) * (ε / (ε' + Abs [y0'])) = ε).
      { field; try lra. }
      rewrite I5 in I3. assumption. }
  assert (H11 : 1 > 0). lra.
  apply H10 in H11 as H12.
  destruct H12 as [δ0 [H12 H16]].
  apply H9 in H11 as H13.
  destruct H13 as [δ1 [H13 H14]].
  assert (H15 : ∃ δ, 0 < δ /\ δ < δ' /\ δ < δ1 /\ δ < δ0).
  { destruct (Rlt_or_le δ' δ1) as [I1 | I1].
    - destruct (Rlt_or_le δ' δ0) as [I2 | I2].
      + exists (δ' / 2). lra.
      + exists (δ0 / 2). repeat split; lra.
    - destruct (Rlt_or_le δ1 δ0) as [I2 | I2].
      + exists (δ1 / 2). lra.
      + exists (δ0 / 2). repeat split; lra. }
  destruct H15 as [δ [H17 [H18 [H19 H20]]]].
  exists δ. split; try lra. intros x H21.
  assert (H22 : 0 < Abs [x - x0] < δ0). lra.
  assert (H23 : 0 < Abs [x - x0] < δ1). lra.
  apply H16 in H22. apply H14 in H23.
  assert (H24 : {` λ x y, y = (f [x] - f [x0]) / (x - x0) `} [x]
      = (f [x] - f [x0]) / (x - x0)).
  { apply f_x; try apply H3. apply AxiomII'. reflexivity. }
  rewrite H24 in H23. clear H24.
  generalize (Abs_abs_minus' ((f [x] - f [x0]) / (x - x0)) y0').
  intro H24. assert (H25 : x - x0 <> 0).
  { apply Abs_not_eq_0. lra. }
  rewrite Abs_div in H24; auto.
  assert (H26 : Abs [f [x] - f [x0]] / Abs [x - x0] < 1 + Abs [y0']).  lra.
  assert (H27 : Abs [f [x] - f [x0]] < (1 + Abs [y0']) * Abs [x - x0]).
  { apply Rmult_lt_compat_r with (r := Abs [x - x0]) in H26; try apply H21.
    assert (I1 : Abs [f [x] - f [x0]] / Abs [x - x0] * Abs [x - x0]
      = Abs [f [x] - f [x0]]).
    { field. lra. }
    rewrite I1 in H26. assumption. }
  lra.
Qed.

(* 导函数 *)
Definition derivativeFun (f : Fun) := {` λ x y, derivative f x y `}.

Theorem derivativeIsFun : ∀ (f : Fun), Function (derivativeFun f).
Proof.
  intro f. unfold Function. intros x y z H1 H2. applyAxiomII' H1.
  applyAxiomII' H2. destruct H1 as [H1 [H3 H4]].
  destruct H2 as [H2 [H5 H6]]. eapply Theorem3_2; eauto.
Qed.

(* 极值 *)
Definition localMax (f : Fun) (x0 : R) :=
  Function f /\ (∃ δ', δ' > 0 /\ Neighbor x0 δ' ⊂ dom[f] /\
  (∀ x, x ∈ Neighbor x0 δ' -> f[x] <= f[x0])).

Definition localMin (f : Fun) (x0 : R) :=
  Function f /\ (∃ δ', δ' > 0 /\ Neighbor x0 δ' ⊂ dom[f] /\
  (∀ x, x ∈ Neighbor x0 δ' -> f[x0] <= f[x])).

Definition extremum (f : Fun) (x0 : R) := localMax f x0 \/ localMin f x0.

(* 费马定理 *)
Theorem Theorem5_3 : ∀ (f : Fun) (x0 : R), derivable f x0
  -> extremum f x0 -> derivative f x0 0.
Proof.
  intros f x0 [y0' [H0 [[δ' [H2 H3]] H4]]] H5.
  assert (H6 : Function {` λ x y, y =
    (f [x] - f [x0]) / (x - x0) `}).
  { intros x y z I1 I2. applyAxiomII' I1; applyAxiomII' I2.
    rewrite I2; assumption. }
  assert (H7 : ∀ x, {` λ x y, y =
    (f [x] - f [x0]) / (x - x0) `} [x]
    = (f [x] - f [x0]) / (x - x0)).
  { intro x. apply f_x; auto. apply AxiomII'. reflexivity. }
  assert (H8 : y0' = 0).
  { apply NNPP. intro I1. apply Rdichotomy in I1.
    destruct I1 as [I1 | I1].
    - generalize (Theorem3_4_2 ({` λ x y, y =
        (f [x] - f [x0]) / (x - x0) `}) x0 y0' H4 I1).
      intro I2. assert (I3 : 0 < ((-y0') / 2) < -y0'). lra.
      apply I2 in I3 as I4. destruct I4 as [δ [I4 I5]].
      clear I2. destruct H5 as [I6 | I6].
      + destruct I6 as [I6 [δ0' [I7 [I8 I9]]]].
        assert (I10 : ∃ δ0, 0 < δ0 /\ δ0 < δ0' /\ δ0 < δ).
        { destruct (Rlt_or_le δ0' δ) as [J1 | J1].
          - exists (δ0' / 2). repeat split; lra.
          - exists (δ / 2). repeat split; lra. }
        destruct I10 as [δ0 [I10 [I11 I12]]].
        assert (I13 : x0 - δ0/2 ∈ Neighbor x0 δ0').
        { apply AxiomII. apply Abs_R. lra. }
        assert (I14 : x0 - δ0/2 ∈ Neighbor0 x0 δ).
        { apply AxiomII. split.
          - apply Abs_not_eq_0. lra.
          - apply Abs_R. lra. }
        apply I9 in I13. apply I5 in I14.
        rewrite H7 in I14.
        assert (I15 : (f [x0 - δ0 / 2] - f [x0])
          / (x0 - δ0 / 2 - x0) < 0). lra.
        assert (I16 : x0 - δ0 / 2 - x0 < 0). lra.
        apply Rmult_lt_gt_compat_neg_l
          with (r := x0 - δ0 / 2 - x0) in I15; auto.
        rewrite Rmult_0_r in I15.
        assert (I17 : (x0 - δ0 / 2 - x0) *
          ((f [x0 - δ0 / 2] - f [x0]) /
          (x0 - δ0 / 2 - x0)) = f [x0 - δ0 / 2] - f [x0]).
        { field. lra. }
        rewrite I17 in I15. lra.
      + destruct I6 as [I6 [δ0' [I7 [I8 I9]]]].
        assert (I10 : ∃ δ0, 0 < δ0 /\ δ0 < δ0' /\ δ0 < δ).
        { destruct (Rlt_or_le δ0' δ) as [J1 | J1].
          - exists (δ0' / 2). repeat split; lra.
          - exists (δ / 2). repeat split; lra. }
        destruct I10 as [δ0 [I10 [I11 I12]]].
        assert (I13 : x0 + δ0/2 ∈ Neighbor x0 δ0').
        { apply AxiomII. apply Abs_R. lra. }
        assert (I14 : x0 + δ0/2 ∈ Neighbor0 x0 δ).
        { apply AxiomII. split.
          - apply Abs_not_eq_0. lra.
          - apply Abs_R. lra. }
        apply I9 in I13. apply I5 in I14.
        rewrite H7 in I14.
        assert (I15 : (f [x0 + δ0 / 2] - f [x0])
          / (x0 + δ0 / 2 - x0) < 0). lra.
        assert (I16 : x0 + δ0 / 2 - x0 > 0). lra.
        apply Rmult_lt_compat_l with (r := x0 + δ0 / 2 - x0)
          in I15; auto. rewrite Rmult_0_r in I15.
        assert (I17 : (x0 + δ0 / 2 - x0) *
          ((f [x0 + δ0 / 2] - f [x0]) /
          (x0 + δ0 / 2 - x0)) = f [x0 + δ0 / 2] - f [x0]).
        { field. lra. }
        rewrite I17 in I15. lra.
    - generalize (Theorem3_4_1 ({` λ x y, y =
        (f [x] - f [x0]) / (x - x0) `}) x0 y0' H4 I1).
      intro I2. assert (I3 : 0 < (y0' / 2) < y0'). lra.
      apply I2 in I3 as I4. destruct I4 as [δ [I4 I5]].
      clear I2. destruct H5 as [I6 | I6].
      + destruct I6 as [I6 [δ0' [I7 [I8 I9]]]].
        assert (I10 : ∃ δ0, 0 < δ0 /\ δ0 < δ0' /\ δ0 < δ).
        { destruct (Rlt_or_le δ0' δ) as [J1 | J1].
          - exists (δ0' / 2). repeat split; lra.
          - exists (δ / 2). repeat split; lra. }
        destruct I10 as [δ0 [I10 [I11 I12]]].
        assert (I13 : x0 + δ0/2 ∈ Neighbor x0 δ0').
        { apply AxiomII. apply Abs_R. lra. }
        assert (I14 : x0 + δ0/2 ∈ Neighbor0 x0 δ).
        { apply AxiomII. split.
          - apply Abs_not_eq_0. lra.
          - apply Abs_R. lra. }
        apply I9 in I13. apply I5 in I14.
        rewrite H7 in I14.
        assert (I15 : (f [x0 + δ0 / 2] - f [x0])
          / (x0 + δ0 / 2 - x0) > 0). lra.
        assert (I16 : x0 + δ0 / 2 - x0 > 0). lra.
        apply Rmult_lt_compat_l with (r := x0 + δ0 / 2 - x0)
          in I15; auto. rewrite Rmult_0_r in I15.
        assert (I17 : (x0 + δ0 / 2 - x0) *
          ((f [x0 + δ0 / 2] - f [x0]) /
          (x0 + δ0 / 2 - x0)) = f [x0 + δ0 / 2] - f [x0]).
        { field. lra. }
        rewrite I17 in I15. lra.
      + destruct I6 as [I6 [δ0' [I7 [I8 I9]]]].
        assert (I10 : ∃ δ0, 0 < δ0 /\ δ0 < δ0' /\ δ0 < δ).
        { destruct (Rlt_or_le δ0' δ) as [J1 | J1].
          - exists (δ0' / 2). repeat split; lra.
          - exists (δ / 2). repeat split; lra. }
        destruct I10 as [δ0 [I10 [I11 I12]]].
        assert (I13 : x0 - δ0/2 ∈ Neighbor x0 δ0').
        { apply AxiomII. apply Abs_R. lra. }
        assert (I14 : x0 - δ0/2 ∈ Neighbor0 x0 δ).
        { apply AxiomII. split.
          - apply Abs_not_eq_0. lra.
          - apply Abs_R. lra. }
        apply I9 in I13. apply I5 in I14.
        rewrite H7 in I14.
        assert (I15 : (f [x0 - δ0 / 2] - f [x0])
          / (x0 - δ0 / 2 - x0) > 0). lra.
        assert (I16 : x0 - δ0 / 2 - x0 < 0). lra.
        apply Rmult_lt_gt_compat_neg_l
          with (r := x0 - δ0 / 2 - x0) in I15; auto.
        rewrite Rmult_0_r in I15.
        assert (I17 : (x0 - δ0 / 2 - x0) *
          ((f [x0 - δ0 / 2] - f [x0]) /
          (x0 - δ0 / 2 - x0)) = f [x0 - δ0 / 2] - f [x0]).
        { field. lra. }
        rewrite I17 in I15. lra. }
  split; auto; split.
  - exists δ'. split; auto.
  - rewrite <- H8. assumption.
Qed.

End A5_1.

Export A5_1.


Require Import Iron.Language.SystemF.TyJudge.
Require Import Iron.Language.SystemF.SubstTypeType.

(* Substitution of types in expressions preserves typing.

   Note that substituting a type into an expression can instantiate
   type variables, so we also need to perform the substitution
   to the result type.
 *)
Theorem subst_type_exp_ix
 :  forall ix ke te x1 t1 t2 k2
 ,  get ix ke = Some k2
 -> TYPE ke  te x1 t1
 -> KIND (delete ix ke)  t2 k2
 -> TYPE (delete ix ke)     (substTE ix t2 te)
         (substTX ix t2 x1) (substTT ix t2 t1).
Proof.
 intros. gen ix ke te t1 t2 k2.
 induction x1; intros; simpl; inverts H0; eauto.

 Case "XVar".
  apply TYVar.
  unfold substTE. eapply get_map. auto.
  eapply subst_type_type_ix; eauto.

 Case "XLAM".
  simpl. apply TYLAM.
  rewrite delete_rewind.
  rewrite (liftTE_substTE 0 ix).
  eapply IHx1; eauto.
   apply liftTT_weaken. auto.

 Case "XAPP".
  rewrite (substTT_substTT 0 ix).
  apply TYAPP.
   simpl. eapply (IHx1 ix) in H6; eauto.
   simpl. eapply subst_type_type_ix; eauto.

 Case "XLam".
  simpl. apply TYLam.
  eapply subst_type_type_ix; eauto.
  unfold substTE. rewrite map_rewind.
  assert ( map (substTT ix t2) (te :> t)
         = substTE ix t2 (te :> t)). auto.
  rewrite H0.
   eapply IHx1; eauto.

 Case "XApp".
  eapply TYApp.
   eapply IHx1_1 in H6; eauto.
   eapply IHx1_2 in H8; eauto.
Qed.

Theorem subst_type_value
 :  forall ke te x1 t1 t2 k2
 ,  TYPE (ke :> k2) te x1 t1
 -> KIND ke  t2 k2
 -> TYPE ke                (substTE 0 t2 te)
         (substTX 0 t2 x1) (substTT 0 t2 t1).
Proof.
 intros.
 assert (ke = delete 0 (ke :> k2)). auto. rewrite H1.
 eapply subst_type_exp_ix; simpl; eauto.
Qed.


Require Import Basic.
Require Import EqDec.
Require Import Minus.
Require Import Incremental.
Require Import ListEx.
Require Import Rosette.Unquantified.
Require Import Native.
Require Import Bool.
Require Import Nat.

Open Scope nat.

(* A very simple test case for nats to demonstrate
   work saved by incremental serarch *)

(* purposely dumb, slow, bad primality test *)
Definition isPrime (n: nat) : bool :=
  let aux :=
      fix hasFactor n t :=
        match t with
        | 0 | 1 => false
        | S t' =>
          if (n / t) * t =? n then true
          else hasFactor n t'
        end
  in
  match n with
  | 0%nat => false (* undefined *)
  | 1%nat => false (* undefined *)
  | S n' => negb (aux n n')
  end.

Compute (fold_left (fun b n => andb b (isPrime n))
            [2; 3; 5; 7; 11; 13; 17; 19] true).

Compute (fold_left (fun b n => andb b (negb (isPrime n)))
            [4; 6; 8; 9; 10; 12; 14; 15; 16; 18; 20] true).

Definition evensAfterTwo (n : nat) : list nat :=
  let aux := (fix buildList n acc :=
     match n with
     | 0 => acc
     | S n' =>
       match acc with
       | [] => buildList n' [4]
       | h :: _ => buildList n' (2+h :: acc)
       end
     end) in
  rev (aux n []).

Compute evensAfterTwo 100.

Definition evenSpace `{Basic} (n : nat) : Space nat :=
  let aux := (fix spaceOf l acc :=
                match l with
                | [] => acc
                | h :: t => spaceOf t (union (single h) acc)
                end) in
  let evens := evensAfterTwo n in
  aux evens empty.

Compute (@evenSpace listSpace 5).

Existing Instance rosetteSearch.

Definition listToOption {A} (l:list A) : option A :=
  match l with
  | [] => None
  | a::_ => Some a
  end.

Definition testSpace (n : nat) : Space nat :=
  if isPrime n then single n else empty.

Definition primeSearch (n : nat) : Result nat :=
  search (bind (evenSpace n) testSpace).

Extraction Language Scheme.

Extraction "primes-naive" primeSearch.

Definition primeIncSearch `{eqDec nat} (n : nat) : Result nat :=
  let evens := evenSpace n in
  let extra := union evens (single 3) in
  incSearch extra evens testSpace.

Definition testIncSearch := @primeIncSearch _.

Extraction Language Scheme.

Extraction "primes-incremental" testIncSearch.


(* Ring2.v *)

Require Import Utf8.

Class ring_op A :=
  { rng_zero : A;
    rng_one : A;
    rng_add : A → A → A;
    rng_mul : A → A → A;
    rng_opp : A → A }.

Definition rng_sub {A} {R : ring_op A} a b := rng_add a (rng_opp b).

Declare Scope ring_scope.
Delimit Scope ring_scope with Rng.
(*
Bind Scope ring_scope with ring.
*)
Notation "a + b" := (rng_add a b) : ring_scope.
Notation "a - b" := (rng_sub a b) : ring_scope.
Notation "a * b" := (rng_mul a b) : ring_scope.
Notation "- a" := (rng_opp a) : ring_scope.
Notation "0" := rng_zero : ring_scope.
Notation "1" := rng_one : ring_scope.

Class ring_prop {A} {ro : ring_op A} :=
  { rng_1_neq_0 : (1 ≠ 0)%Rng;
    rng_eq_dec : ∀ a b : A, {a = b} + {a ≠ b};
    rng_add_comm : ∀ a b : A, (a + b = b + a)%Rng;
    rng_add_assoc : ∀ a b c : A, (a + (b + c) = (a + b) + c)%Rng;
    rng_add_0_l : ∀ a : A, (0 + a)%Rng = a;
    rng_add_opp_l : ∀ a : A, (- a + a = 0)%Rng;
    rng_mul_comm : ∀ a b : A, (a * b = b * a)%Rng;
    rng_mul_assoc : ∀ a b c : A, (a * (b * c) = (a * b) * c)%Rng;
    rng_mul_1_l : ∀ a : A, (1 * a)%Rng = a;
    rng_mul_add_distr_l : ∀ a b c : A, (a * (b + c) = a * b + a * c)%Rng }.

Arguments rng_eq_dec {_} {_} {_} _%Rng _%Rng.

Fixpoint rng_power {A} {R : ring_op A} a n :=
  match n with
  | O => 1%Rng
  | S m => (a * rng_power a m)%Rng
  end.

Notation "a ^ b" := (rng_power a b) : ring_scope.

Section ring_theorems.

Context {A : Type}.
Context {ro : ring_op A}.
Context {rp : ring_prop}.

Theorem rng_add_opp_r : ∀ x, (x - x = 0)%Rng.
Proof.
intros x; unfold rng_sub; rewrite rng_add_comm.
apply rng_add_opp_l.
Qed.

Theorem rng_mul_1_r : ∀ a, (a * 1 = a)%Rng.
Proof.
intros a; simpl.
rewrite rng_mul_comm, rng_mul_1_l.
reflexivity.
Qed.

Theorem rng_add_compat_l : ∀ a b c,
  (a = b)%Rng → (c + a = c + b)%Rng.
Proof.
intros a b c Hab.
rewrite Hab; reflexivity.
Qed.

Theorem rng_add_compat_r : ∀ a b c,
  (a = b)%Rng → (a + c = b + c)%Rng.
Proof.
intros a b c Hab.
rewrite Hab; reflexivity.
Qed.

Theorem rng_add_compat : ∀ a b c d,
  (a = b)%Rng
  → (c = d)%Rng
    → (a + c = b + d)%Rng.
Proof.
intros a b c d Hab Hcd.
rewrite Hab, Hcd; reflexivity.
Qed.

Theorem rng_sub_compat_l : ∀ a b c,
  (a = b)%Rng → (a - c = b - c)%Rng.
Proof.
intros a b c Hab.
now rewrite Hab.
Qed.

Theorem rng_sub_compat_r : ∀ a b c,
  (b = c)%Rng → (a - b = a - c)%Rng.
Proof.
intros a b c Hbc.
now rewrite Hbc.
Qed.

Theorem rng_mul_compat_r : ∀ a b c,
  (a = b)%Rng
  → (a * c = b * c)%Rng.
Proof.
intros a b c Hab; simpl in Hab |- *.
rewrite Hab; reflexivity.
Qed.

Theorem rng_mul_compat : ∀ a b c d,
  (a = b)%Rng
  → (c = d)%Rng
    → (a * c = b * d)%Rng.
Proof.
intros a b c d Hab Hcd.
rewrite Hab, Hcd; reflexivity.
Qed.

Theorem rng_add_0_r : ∀ a, (a + 0 = a)%Rng.
Proof.
intros a; simpl.
rewrite rng_add_comm.
apply rng_add_0_l.
Qed.

Theorem fold_rng_sub : ∀ a b, (a + - b)%Rng = (a - b)%Rng.
Proof. intros; easy. Qed.

Theorem rng_add_sub : ∀ a b, (a + b - b = a)%Rng.
Proof.
intros.
unfold rng_sub.
rewrite <- rng_add_assoc.
rewrite fold_rng_sub.
rewrite rng_add_opp_r.
apply rng_add_0_r.
Qed.

Theorem rng_sub_add : ∀ a b, (a - b + b = a)%Rng.
Proof.
intros.
unfold rng_sub.
rewrite <- rng_add_assoc.
rewrite rng_add_opp_l.
apply rng_add_0_r.
Qed.

Theorem rng_add_reg_r : ∀ a b c, (a + c = b + c)%Rng → (a = b)%Rng.
Proof.
intros a b c Habc; simpl in Habc; simpl.
eapply rng_sub_compat_l with (c := c) in Habc.
now do 2 rewrite rng_add_sub in Habc.
Qed.

Theorem rng_add_reg_l : ∀ a b c, (c + a = c + b)%Rng → (a = b)%Rng.
Proof.
intros a b c Habc; simpl in Habc; simpl.
apply rng_add_reg_r with (c := c).
rewrite rng_add_comm; symmetry.
rewrite rng_add_comm; symmetry.
assumption.
Qed.

Theorem rng_opp_add_distr : ∀ a b,
  (- (a + b) = - a - b)%Rng.
Proof.
intros.
apply (rng_add_reg_l _ _ (b + a)%Rng).
unfold rng_sub.
rewrite rng_add_assoc.
do 3 rewrite fold_rng_sub.
rewrite rng_add_sub.
rewrite rng_add_comm.
now do 2 rewrite rng_add_opp_r.
Qed.

Theorem rng_sub_add_distr : ∀ a b c, (a - (b + c) = a - b - c)%Rng.
Proof.
intros.
unfold rng_sub.
rewrite rng_opp_add_distr.
apply rng_add_assoc.
Qed.

Theorem rng_mul_add_distr_r : ∀ x y z,
  ((x + y) * z = x * z + y * z)%Rng.
Proof.
intros x y z; simpl.
rewrite rng_mul_comm.
rewrite rng_mul_add_distr_l.
rewrite rng_mul_comm.
assert (rng_mul z y = rng_mul y z) as H.
 apply rng_mul_comm.

 rewrite H; reflexivity.
Qed.

Theorem rng_mul_0_l : ∀ a, (0 * a = 0)%Rng.
Proof.
intros a.
assert ((0 * a + a = a)%Rng) as H.
 transitivity ((0 * a + 1 * a)%Rng).
  rewrite rng_mul_1_l; reflexivity.

  rewrite <- rng_mul_add_distr_r.
  rewrite rng_add_0_l, rng_mul_1_l.
  reflexivity.

 apply rng_add_reg_r with (c := a).
 rewrite rng_add_0_l; assumption.
Qed.

Theorem rng_mul_0_r : ∀ a, (a * 0 = 0)%Rng.
Proof.
intros a; simpl.
rewrite rng_mul_comm, rng_mul_0_l.
reflexivity.
Qed.

Theorem rng_mul_opp_l : ∀ a b, ((- a) * b = - (a * b))%Rng.
Proof.
intros a b; simpl.
apply rng_add_reg_l with (c := (a * b)%Rng).
rewrite fold_rng_sub.
rewrite rng_add_opp_r.
rewrite <- rng_mul_add_distr_r.
rewrite fold_rng_sub.
rewrite rng_add_opp_r, rng_mul_0_l.
reflexivity.
Qed.

Theorem rng_mul_opp_r : ∀ a b, (a * (- b) = - (a * b))%Rng.
Proof.
intros a b; simpl.
rewrite rng_mul_comm; symmetry.
rewrite rng_mul_comm; symmetry.
apply rng_mul_opp_l.
Qed.

Theorem rng_mul_sub_distr_l : ∀ x y z,
  (x * (y - z) = x * y - x * z)%Rng.
Proof.
intros.
unfold rng_sub.
rewrite rng_mul_add_distr_l.
now rewrite <- rng_mul_opp_r.
Qed.

Theorem rng_mul_sub_distr_r : ∀ x y z,
  ((x - y) * z = x * z - y * z)%Rng.
Proof.
intros.
rewrite rng_mul_comm.
rewrite rng_mul_sub_distr_l.
rewrite (rng_mul_comm _ x).
rewrite (rng_mul_comm _ y).
easy.
Qed.

Theorem rng_opp_0 : (- 0 = 0)%Rng.
Proof.
simpl; etransitivity; [ symmetry; apply rng_add_0_l | idtac ].
apply rng_add_opp_r.
Qed.

Theorem rng_sub_0_r : ∀ a, (a - 0 = a)%Rng.
Proof.
intros.
unfold rng_sub.
rewrite rng_opp_0.
apply rng_add_0_r.
Qed.

Theorem rng_add_move_0_r : ∀ a b, (a + b = 0)%Rng ↔ (a = - b)%Rng.
Proof.
intros a b.
split; intros H.
 apply rng_sub_compat_l with (c := b) in H.
 rewrite rng_add_sub in H.
 unfold rng_sub in H.
 now rewrite rng_add_0_l in H.

 rewrite H.
 rewrite rng_add_opp_l; reflexivity.
Qed.

Theorem rng_opp_inj_wd : ∀ a b, (- a = - b)%Rng ↔ (a = b)%Rng.
Proof.
intros a b; split; intros H.
 apply rng_add_move_0_r in H.
 rewrite rng_add_comm in H.
 apply rng_add_move_0_r in H.
 rewrite H.
 apply rng_add_move_0_r.
 apply rng_add_opp_r.

 rewrite H; reflexivity.
Qed.

Theorem rng_opp_involutive : ∀ x, (- - x)%Rng = x.
Proof.
intros.
symmetry.
apply rng_add_move_0_r.
apply rng_add_opp_r.
Qed.

Theorem rng_add_add_swap : ∀ n m p, (n + m + p = n + p + m)%Rng.
Proof.
intros n m p; simpl.
do 2 rewrite <- rng_add_assoc.
assert (m + p = p + m)%Rng as H by apply rng_add_comm.
rewrite H; reflexivity.
Qed.

Theorem rng_mul_mul_swap : ∀ n m p, (n * m * p = n * p * m)%Rng.
Proof.
intros n m p.
do 2 rewrite <- rng_mul_assoc.
assert (m * p = p * m)%Rng as H by apply rng_mul_comm.
rewrite H; reflexivity.
Qed.

Theorem rng_mul_eq_0 : ∀ n m,
  (n = 0)%Rng ∨ (m = 0)%Rng
  → (n * m = 0)%Rng.
Proof.
intros n m H; simpl in H; simpl.
destruct H as [H| H]; rewrite H; [ apply rng_mul_0_l | apply rng_mul_0_r ].
Qed.

Theorem rng_pow_1_r : ∀ a, (a ^ 1 = a)%Rng.
Proof. now intros; cbn; rewrite rng_mul_1_r. Qed.

End ring_theorems.


Definition prop0 : forall (A : Prop), A -> A.
Proof.
intros.
apply H.
Qed.

Theorem prop0' : forall (A : Prop), A -> A.

Lemma prop0'' : forall (A : Prop), A -> A.

Example prop0''' : forall (A : Prop), A -> A.
Example prop0'''' : forall (A : Prop), A -> A := fun A x => x.

Goal forall (A : Prop), A -> A.

Goal forall (P Q : Prop), (forall P : Prop, (P -> Q) -> Q) -> ((P -> Q) -> P) -> P.
intro.
intro.
intro.
intro.
apply H0.
intro.
apply (H (P -> Q)).
apply (H P).
Qed.

Goal forall (P Q : Prop), (forall P : Prop, (P -> Q) -> Q) -> ((P -> Q) -> P) -> P.
Proof.
intros.
apply H0.
intros.
apply (H Q).
intro.
apply H2.
Qed.

Goal forall (P Q R : Prop), (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros.
  apply (H0 (H H1)).
Qed.

Inductive list (A : Type) : Type :=
| nil : list A
| cons : A -> list A -> list A.

Inductive False : Prop :=.

Definition not (A : Prop) := A -> False.

Goal forall P : Prop, P -> ~~P.
  intros.
  intro.
  apply H0.
  apply H.
Qed.

Goal forall P : Prop, P -> ~~P.
  unfold not.
  intros.
  intro.
  apply H0.
  apply H.
Qed.

(*
Goal forall P : Prop, P -> not (not P).
  intros.
  intro.
  apply H0.
  apply H.
Qed.
 *)

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

(*
Goal forall (P Q : Prop), P \/ Q -> Q \/ P.
  intros.
  case H.
  apply or_intror.
  apply or_introl.
Qed.
*)

Goal forall (P Q : Prop), P \/ Q -> Q \/ P.
  intros.
  destruct H.
  right.
  apply H.
  left.
  apply H.
Qed.

Inductive and (A B : Prop) : Prop :=
  conj : A -> B -> and A B.

(*
Goal forall (P Q : Prop), P /\ Q -> Q /\ P.
  intros.
  destruct H.
  apply conj.
 *)

Goal forall (P Q : Prop), P /\ Q -> Q /\ P.
  intros.
  destruct H.
  split.
  apply H0.
  apply H.
Qed.

Goal forall (P : Prop), P -> ~~P.
  auto.
Qed.

Goal forall (P Q : Prop), P \/ Q -> Q \/ P.
  tauto.
Qed.

Goal forall (P Q : Prop), P /\ Q -> Q /\ P.
  tauto.
Qed.

Goal forall (P : Prop), ~(P /\ ~P).
  intros.
  intro.
  destruct H.
  apply H0.
  apply H.
Qed.

Goal forall (P Q : Prop), ~P \/ ~Q -> ~(P /\ Q).
  intros.
  intro.
  destruct H.
  apply H.
  destruct H0.
  apply H0.
  apply H.
  destruct H0.
  apply H1.
Qed.

(*
Goal forall (P : Prop), (forall (P : Prop), ~~P -> P) -> P \/ ~P.
  intros.
  left.
  apply (H P).
  intro.
  apply H0.
  apply (H P).
  intro.
  apply (H0).
 *)

(*
Goal forall (P : Prop), (forall (P : Prop), ~~P -> P) -> P \/ ~P.
  intros.
  left.
  apply H.
  intro.
  apply H0.
  apply (H P).
  intro.
  apply (H (~P)).
 *)

(*
Goal forall (P : Prop), (forall (P : Prop), ~~P -> P) -> P \/ ~P.
  intros.
  left.
  apply (H P).
  intro.
  apply H0.
  apply H.
  apply (H (~~P)).
  intro.
  apply
 *)

(*
Goal forall (P : Prop), (forall (P : Prop), ~~P -> P) -> P \/ ~P.
  unfold not.
  intros.
  apply H.
Qed.
 *)

Goal forall (P : Prop), (forall (P : Prop), ~~P -> P) -> P \/ ~P.
  intros.
  apply (H (P \/ (~P))).
  intros.
  intro.
  apply H0.
  intros.
  right.
  intro.
  apply H0.
  left.
  apply H1.
Qed.


From discprob.basic Require Import base order nify.
From discprob.prob Require Import prob countable finite stochastic_order uniform.
From discprob.monad Require Import monad permutation.
From discprob.monad Require quicksort quicksort_cost.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
From Coq Require Import Reals Fourier Psatz Program.Wf Omega.

Lemma range_half: 0 <= 1/2 <= 1.
Proof. nra. Qed.

Lemma range_half_pow c: 0 <= 1 / (2 ^ c) <= 1.
Proof.
  induction c; first by (rewrite //=; split; nra).
  replace (1 /2 ^ (S c)) with (1/2 * 1/(2 ^ c)); last first.
  { rewrite //=. field. clear; induction c => //=; nra.  }
  nra.
Qed.

Definition flip := bernoulli (1/2) range_half.
Definition flipn k := bernoulli (1/(2^k)) (range_half_pow k).

Lemma bernoulli_powS c:
  eq_dist (rvar_of_ldist (bernoulli (1/(2 ^ (S c))) (range_half_pow (S c))))
          (rvar_of_ldist ( b1 ← bernoulli (1/2) range_half;
                           b2 ← bernoulli (1/(2 ^ c)) (range_half_pow c);
                           mret (b1 && b2))).
Proof.
  intros b. repeat (rewrite pr_mbind_ldist2 ?big_cons big_nil).
  rewrite ?pr_mret_simpl.
  destruct b => //=; rewrite ?pr_bernoulli_true ?pr_bernoulli_false;
  field; apply Rgt_not_eq; induction c => //=; nra.
Qed.

Lemma flipnS c:
  eq_dist (rvar_of_ldist (flipn (S c)))
          (rvar_of_ldist ( b1 ← flip;
                           b2 ← flipn c;
                           mret (b1 && b2))).
Proof. rewrite /flipn/flip; apply bernoulli_powS. Qed.

Lemma pr_flip_true: pr_eq (rvar_of_ldist flip) true = 1/2.
Proof. rewrite /flip; apply pr_bernoulli_true. Qed.

Lemma pr_flip_false: pr_eq (rvar_of_ldist flip) false = 1/2.
Proof. rewrite /flip; rewrite pr_bernoulli_false; nra. Qed.

Lemma pr_flipn_true c:
  pr_eq (rvar_of_ldist (flipn c)) true = 1 / (2 ^ c).
Proof. rewrite /flipn; rewrite pr_bernoulli_true //. Qed.

Lemma pr_flipn_false c:
  pr_eq (rvar_of_ldist (flipn c)) false = 1 - 1 / (2 ^ c).
Proof. rewrite /flipn; rewrite pr_bernoulli_false //. Qed.

Lemma flip_unfold:
  flip = bernoulli (1/2) (range_half).
Proof.
  done.
Qed.

Opaque flip.
Opaque flipn.
Opaque dist_bind.
Opaque dist_ret.

Definition approx_incr (c: nat) : ldist nat :=
  b ← flipn c;
    mret (if (b : bool) then
            S c
          else
            c).

Fixpoint approx_incrn (n: nat) (c: nat) : ldist nat :=
  match n with
    | 0 => mret c
    | S n' =>
      c' ← approx_incrn n' c;
      approx_incr c'
  end.

Fixpoint approx_incr' (c: nat) : ldist nat :=
  match c with
    | O => mret (S O)
    | S c' =>
      b ← flip;
      if (b : bool) then
        result ← approx_incr' c';
        mret (S result)
      else
        mret c
  end.

Lemma approx_incr'_unfold (c: nat):
  approx_incr' c =
  match c with
    | O => mret (S O)
    | S c' =>
      b ← flip;
      if (b : bool) then
        result ← approx_incr' c';
        mret (S result)
      else
        mret c
  end.
Proof. destruct c; auto. Qed.

Lemma eq_dist_approx_incr_incr' c:
  eq_dist (rvar_of_ldist (approx_incr c))
          (rvar_of_ldist (approx_incr' c)).
Proof.
  induction c as [| c].
  - intros n.
    rewrite //=/approx_incr/approx_incr'//=.
    specialize (pr_mbind_ldist2 (flipn 0) (λ b, mret (if b then (S O) else O)) n).
    rewrite //= => ->.
    rewrite ?big_cons big_nil.
    rewrite //= pr_bernoulli_true pr_bernoulli_false.
    field.
  - rewrite /approx_incr approx_incr'_unfold.
    eapply eq_dist_trans.
    { eapply (eq_dist_ldist_bind_congr _ _ _ _ (flipnS c)); done. }
    rewrite [a in eq_dist _ a]//=.
    rewrite ldist_assoc.
     apply eq_dist_ldist_bind_ext.
    intros b.
    destruct b; last first.
    { rewrite /andb. rewrite ldist_fmap_bind.
      intros n. rewrite ?pr_mbind_ldist2 !big_cons !big_nil pr_bernoulli_true pr_bernoulli_false.
      rewrite //=. rewrite !pr_mret_simpl.
        case: ifP; intros; nra.
    }
    rewrite /andb. rewrite !ldist_fmap_bind. simpl size.
    intros.
    eapply (eq_dist_trans _ _
                          (rvar_of_ldist
                             (x ← (x ← flipn c; mret (if (x : bool) then S c else c));
                               mret (S x)))).
    { rewrite ldist_fmap_bind.  eapply eq_dist_ldist_bind_ext => x.
      destruct x => //=. }
    eapply eq_dist_ldist_bind_congr; last done.
    rewrite /approx_incr in IHc. intros x.
    rewrite IHc. done.
Qed.

Fixpoint binomial (n: nat) : ldist { x: nat | (x <= n)%nat}.
  refine(match n with
    | 0 => mret (exist _ O _)
    | S n' =>
      b ← flip;
      rest ← binomial n';
      if (b : bool) then
        mret (exist _ (S (sval rest)) _ )
      else
        mret (exist _ (sval rest) _)
  end); auto.
  - abstract (destruct rest => //=; nify; omega).
  - abstract (destruct rest => //=; nify; omega).
Defined.

Lemma binomial_unfold n:
  binomial n =
  match n as n0 return (ldist {x : nat | (x <= n0)%nat}) with
  | 0%nat => mret (exist (λ x : nat, (x <= 0)%nat) 0%nat (leqnn 0))
  | n'.+1 =>
      b ← flip;
      rest ← binomial n';
      (if (b : bool)
       then mret (exist (λ x : nat, (x <= n'.+1)%nat) (sval rest).+1 (binomial_subproof n' rest))
       else mret (exist (λ x : nat, (x <= n'.+1)%nat) (sval rest) (binomial_subproof0 n' rest)))
  end.
Proof. rewrite {1}/binomial. destruct n => //=. Qed.

Definition approx_incr'_bulk : nat → ldist (nat).
  refine(Fix lt_wf (fun _ => ldist (nat))
  (fun incrs approx_incrn' =>
  match incrs as incrs' return (incrs = incrs' → ldist (nat)) with
    | O => λ eq, mret O
    | (S O) => λ eq, mret (S O)
    | (S (S n')) => λ eq,
      surv ← binomial (S n');
      result ← approx_incrn' (sval surv) _;
      mret (S result)
  end (Init.Logic.eq_refl))); auto.
Proof.
  abstract (destruct surv as (x&i) => //=; subst => //=; nify; rewrite //= in i; omega).
Defined.

Lemma approx_incr'_bulk_unfold_aux n:
  approx_incr'_bulk n =
  match n as n' return (n = n' → ldist (nat)) with
    | O => λ eq, mret O
    | (S O) => λ eq, mret (S O)
    | (S (S n')) => λ eq,
      surv ← binomial (S n');
      result ← approx_incr'_bulk (sval surv);
      mret (S result)
  end (Init.Logic.eq_refl).
Proof. rewrite /approx_incr'_bulk quicksort.easy_fix_eq; done. Qed.

Lemma approx_incr'_bulk_unfold n:
  approx_incr'_bulk n =
  match n with
    | O => mret O
    | (S O) => mret (S O)
    | (S (S n')) =>
      surv ← binomial (S n');
      result ← approx_incr'_bulk (sval surv);
      mret (S result)
  end.
Proof.
  rewrite approx_incr'_bulk_unfold_aux.
  destruct n as [| n] => //. destruct n as [|  n] => //.
Qed.

Fixpoint approx_incrn'  (n: nat) (c: nat) :=
  match n with
    | 0 => mret c
    | S n' =>
      c' ← approx_incrn' n' c;
      approx_incr' c'
  end.

Lemma approx_incrn'_right k:
      eq_dist (rvar_of_ldist (approx_incr'_bulk (S k)))
              (rvar_of_ldist (x ← approx_incr'_bulk k; approx_incr' x)).
Proof.
  induction k as [k IH] using (well_founded_induction lt_wf).
  destruct k as [| k]; last destruct k as [| k].
  - subst. rewrite ?approx_incr'_bulk_unfold ldist_left_id//=.
  - subst. rewrite ?approx_incr'_bulk_unfold ldist_left_id.
    rewrite /binomial/approx_incr'. rewrite ldist_assoc.
    apply eq_dist_ldist_bind_ext => b.
    rewrite ldist_assoc ldist_left_id.
    destruct b.
    * rewrite /sval ldist_left_id. rewrite approx_incr'_bulk_unfold. done.
    * rewrite /sval ldist_left_id. rewrite approx_incr'_bulk_unfold ldist_left_id. done.
  - subst. rewrite approx_incr'_bulk_unfold binomial_unfold ldist_assoc.
   rewrite approx_incr'_bulk_unfold => v.
   rewrite pr_mbind_ldist2.
   rewrite {1}flip_unfold ?big_cons ?big_nil pr_flip_true pr_flip_false. rewrite /snd.
   rewrite ?ldist_fmap_bind/sval.
   symmetry.
   rewrite ldist_assoc.
   rewrite ?pr_mbind_ldist2.
   rewrite Rplus_0_r.
   rewrite -Rmult_plus_distr_l.
   rewrite -big_split. rewrite big_distrr.
   apply eq_bigr. intros (k'&Hsize) _.
   rewrite //= -Rmult_plus_distr_l -Rmult_assoc (Rmult_comm ( 1 / 2)).
   rewrite Rmult_assoc; f_equal.
   specialize (@ldist_fmap_bind).
   rewrite //=/base.mbind => ->.
   specialize (IH k').
   assert (Hinj: injective (succn)).
   { intros ??. congruence. }
   assert (Hbound: ((k' < (S (S k))))%coq_nat).
   { rewrite //=.  rewrite //= in Hsize.  nify. omega. }
   specialize (IH Hbound).
   etransitivity.
   {
     eapply eq_dist_ldist_bind_ext => c.
     rewrite approx_incr'_unfold.
     done.
   }
   rewrite ldist_bind_swap pr_mbind_ldist2 ?big_cons ?big_nil Rplus_0_r.
   rewrite /snd pr_flip_true pr_flip_false.
   rewrite -Rmult_plus_distr_l.
   rewrite -ldist_assoc.
   f_equal.
   destruct v as [| v].
   * rewrite ?pr_mbind_mret_inj0 //.
   * rewrite ?pr_mbind_mret_inj //. rewrite IH. done.
Qed.

Lemma eq_dist_approx_incr'_bulk (k: nat):
  eq_dist (rvar_of_ldist (approx_incr'_bulk k))
          (rvar_of_ldist (approx_incrn' k O)).
Proof.
  induction k as [k IH] using (well_founded_induction lt_wf).
  destruct k as [| k]; last destruct k as [| k].
  - subst. rewrite approx_incr'_bulk_unfold/size/approx_incrn'//=.
  - subst. rewrite approx_incr'_bulk_unfold/size/approx_incrn'.
    rewrite ldist_left_id/approx_incr'. done.
  - subst. rewrite approx_incr'_bulk_unfold.
    rewrite /approx_incrn' -/approx_incrn'.
    apply eq_dist_sym.
    eapply eq_dist_trans.
    { eapply eq_dist_ldist_bind_congr.
      - apply eq_dist_sym. apply (IH (S k)).
        rewrite //=.
      - done.
    }
    eapply eq_dist_trans.
    { eapply eq_dist_sym. apply: approx_incrn'_right.  }
    rewrite approx_incr'_bulk_unfold. done.
Qed.

Lemma eq_dist_approx_incrn_incrn' n c:
  eq_dist (rvar_of_ldist (approx_incrn n c))
          (rvar_of_ldist (approx_incrn' n c)).
Proof.
  induction n.
  - by done.
  - rewrite //=. apply eq_dist_ldist_bind_congr.
      * apply IHn.
      * apply eq_dist_approx_incr_incr'.
Qed.

Lemma eq_dist_approx_incrn_bulk n:
  eq_dist (rvar_of_ldist (approx_incrn n O))
          (rvar_of_ldist (approx_incr'_bulk n)).
Proof.
  eapply eq_dist_trans.
  - eapply eq_dist_approx_incrn_incrn'.
  - apply eq_dist_sym. apply eq_dist_approx_incr'_bulk.
Qed.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__betweennotequal.
Require Export lemma__collinear4.
Require Export logic.
Definition lemma__rayimpliescollinear : forall A B C, (euclidean__defs.Out A B C) -> (euclidean__axioms.Col A B C).
Proof.
intro A.
intro B.
intro C.
intro H.
assert (exists J, (euclidean__axioms.BetS J A C) /\ (euclidean__axioms.BetS J A B)) as H0 by exact H.
destruct H0 as [J H1].
destruct H1 as [H2 H3].
assert (* Cut *) (euclidean__axioms.neq J A) as H4.
- assert (* Cut *) ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq J A) /\ (euclidean__axioms.neq J B))) as H4.
-- apply (@lemma__betweennotequal.lemma__betweennotequal J A B H3).
-- destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
exact H7.
- assert (* Cut *) (euclidean__axioms.Col J A B) as H5.
-- right.
right.
right.
right.
left.
exact H3.
-- assert (* Cut *) (euclidean__axioms.Col J A C) as H6.
--- right.
right.
right.
right.
left.
exact H2.
--- assert (* Cut *) (euclidean__axioms.Col A B C) as H7.
---- apply (@euclidean__tactics.not__nCol__Col A B C).
-----intro H7.
apply (@euclidean__tactics.Col__nCol__False A B C H7).
------apply (@lemma__collinear4.lemma__collinear4 J A B C H5 H6 H4).

---- exact H7.
Qed.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Ch13_1.

Section playfair_midpoints.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma playfair_s_postulate_implies_midpoint_converse_postulate :
  playfair_s_postulate ->
  midpoint_converse_postulate.
Proof.
intros HP A; intros.
destruct (midpoint_existence A C) as [X HAC].
assert (X = Q).
 assert (Par_strict A B X P).
  apply triangle_mid_par with C; assumption.
 assert_diffs.
 assert_cols.
 apply l6_21 with A C P Q.
  intro.
  assert (Col A B C) by ColR.
  contradiction.
  assert (Par A B Q P /\ A <> B /\ Q <> P) by (apply par_distincts; finish).
  spliter; intuition.
  Col.
  Col.
  destruct (HP A B Q P X P P) as [HCol1 HCol2]; Col; apply par_strict_par; Par.
  Col.
treat_equalities; assumption.
Qed.

End playfair_midpoints.


Require Import Plus.

Inductive foo6 : nat -> Prop :=
| O6 : foo6 6
| S6 : forall m, foo6 m -> foo6 (6 + m).

Inductive foo10 : nat -> Prop :=
| O10 : foo10 10
| S10 : forall m, foo10 m -> foo10 (10 + m).

Inductive foo : nat -> Prop :=
| Six : forall n, foo6 n -> foo n
| Ten : forall n, foo10 n -> foo n.

Example thirteen_not_foo :
  ~ (foo 13).
Proof.
  intros H. inversion H; subst.
  - inversion H0; subst. inversion H2; subst. inversion H3.
  - inversion H0; subst. inversion H2.
Qed.

Inductive odd : nat -> Prop :=
| SO : odd 1
| SSo : forall m, odd m -> odd (S (S m)).

(* dirty... *)
Theorem foo_not_odd : forall n,
  foo n -> ~ (odd n).
Proof.
  intros n H H0. inversion H; subst; clear H.
  - induction H1; subst.
    + inversion H0; subst; clear H0.
      inversion H1; subst; clear H1.
      inversion H0; subst; clear H0.
      inversion H1.
    + apply IHfoo6.
      inversion H0; subst; clear H0.
      inversion H2; subst; clear H2.
      inversion H0; subst; clear H0.
      assumption.
  - induction H1; subst.
    + inversion H0; subst; clear H0.
      inversion H1; subst; clear H1.
      inversion H0; subst; clear H0.
      inversion H1; subst; clear H1.
      inversion H0; subst; clear H0.
      inversion H1.
    + apply IHfoo10.
      inversion H0; subst; clear H0.
      inversion H2; subst; clear H2.
      inversion H0; subst; clear H0.
      inversion H2; subst; clear H2.
      inversion H0; subst; clear H0.
      assumption.
Qed.


(* Copyright (c) 2008-2012, 2015, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* begin hide *)
Require Import List.

Require Import Cpdt.CpdtTactics.

Definition bad : unit := tt.

Set Implicit Arguments.
Set Asymmetric Patterns.
(* end hide *)

Section stream.
  Variable A : Type.
  CoInductive stream : Type :=
  | Cons : A -> stream -> stream.
End stream.

CoFixpoint zeros : stream nat := Cons 0 zeros.

CoFixpoint trues_falses : stream bool := Cons true falses_trues
with falses_trues : stream bool := Cons false trues_falses.

Fixpoint approx A (s : stream A) (n : nat) : list A :=
  match n with
  | O => nil
  | S n' =>
    match s with
    | Cons h t => h :: approx t n'
    end
  end.

Eval simpl in approx zeros 10.

Eval simpl in approx trues_falses 10.

Section map.
  Variables A B : Type.
  Variable f : A -> B.
  CoFixpoint map (s : stream A) : stream B :=
    match s with
    | Cons h t => Cons (f h) (map t)
    end.
End map.

Section interleave.
  Variable A : Type.
  CoFixpoint interleave (s1 s2 : stream A) : stream A :=
    match s1, s2 with
    | Cons h1 t1, Cons h2 t2 => Cons h1 (Cons h2 (interleave t1 t2))
    end.
End interleave.

(* Section map'. *)
(*   Variables A B : Type. *)
(*   Variable f : A -> B. *)
(*   CoFixpoint map' (s : stream A) : stream B := *)
(*     match s with *)
(*     | Cons h t => interleave (Cons (f h) (map' t)) (Cons (f h) (map' t)) *)
(*     end. *)

Definition tl A (s : stream A) : stream A :=
  match s with
  | Cons _ s' => s'
  end.

(* CoFixpoint bad : stream nat := tl (Cons 0 bad). *)
(* The restrictions of Coq on coinductive types and cofix function definitions. As coinductive is used to produce infinite data structure, a cofix function must produce a result through a constructor for a coinductive type. Coq's restriction is so tight that any indirections may fail Coq's check *)

CoFixpoint ones : stream nat := Cons 1 ones.
Definition ones' := map S zeros.

Theorem ones_eq : ones = ones'.
Abort.

Section stream_eq.
  Variable A : Type.
  CoInductive stream_eq : stream A -> stream A -> Prop :=
  | Stream_eq : forall h t1 t2, stream_eq t1 t2 -> stream_eq (Cons h t1) (Cons h t2).
End stream_eq.

Theorem ones_eq : stream_eq ones ones'.
  cofix ones_eq.
  assumption.
  Undo.
  simpl.
Abort.

Definition frob A (s : stream A) : stream A :=
  match s with
  | Cons h t => Cons h t
  end.

Theorem frob_eq : forall A (s : stream A), s = frob s.
  destruct s. simpl. reflexivity.
Qed.

Theorem ones_eq : stream_eq ones ones'.
  cofix ones_eq.
  rewrite (frob_eq ones).
  rewrite (frob_eq ones').
  simpl.
  constructor.
  assumption.
Qed.

Theorem ones_eq' : stream_eq ones ones'.
  cofix ones_eq'; crush.
Abort.

Definition hd A (s : stream A) : A :=
  match s with
  | Cons x _ => x
  end.

Section stream_eq_coind.
  Variable A : Type.
  Variable R : stream A -> stream A -> Prop.
  Hypothesis Cons_case_hd : forall s1 s2, R s1 s2 -> hd s1 = hd s2.
  Hypothesis Cons_case_tl : forall s1 s2, R s1 s2 -> R (tl s1) (tl s2).

  Theorem stream_eq_coind : forall s1 s2, R s1 s2 -> stream_eq s1 s2.
    cofix stream_eq_coind; destruct s1; destruct s2; intro.
    generalize (Cons_case_hd H); intro Heq; simpl in Heq; rewrite Heq.
    constructor.
    apply stream_eq_coind.
    apply (Cons_case_tl H).
  Qed.
End stream_eq_coind.

Print stream_eq_coind.

Theorem ones_eq'' : stream_eq ones ones'.
  apply (stream_eq_coind (fun s1 s2 => s1 = ones /\ s2 = ones')); crush.
Qed.

Theorem ones_eq_manual : stream_eq ones ones'.
  cofix ones_eq_manual.
  apply (stream_eq_coind (fun s1 s2 => s1 = ones /\ s2 = ones')).
  -
    intros. destruct H. rewrite H. rewrite H0. reflexivity.
  -
    intros. destruct H. rewrite H. rewrite H0. split.
    +
      reflexivity.
    +
      reflexivity.
  -
    split. reflexivity. reflexivity.
Qed.

Require Import Arith.
Print fact.

CoFixpoint fact_slow' (n : nat) : stream nat := Cons (fact n) (fact_slow' (S n)).
Definition fact_slow := fact_slow' 1.

CoFixpoint fact_iter' (n acc : nat) : stream nat := Cons acc (fact_iter' (S n) (n * acc)).
Definition fact_iter := fact_iter' 2 1.

Eval simpl in approx fact_iter 5.
Eval simpl in approx fact_slow 5.

(* Lemma fact_def : forall x n, *)
(*     fact_iter' x (fact n * S n) = fact_iter' x (fact (S n)). *)
(*   simpl. intros. f_equal. ring. *)
(* Qed. *)

(* Hint Resolve fact_def. *)

Lemma fact_eq' : forall n, stream_eq (fact_iter' (S n) (fact n)) (fact_slow' n).
  intros; apply (stream_eq_coind (fun s1 s2 => exists n, s1 = fact_iter' (S n) (fact n) /\ s2 = fact_slow' n)); crush; eauto.
Qed.

Theorem fact_eq : stream_eq fact_iter fact_slow.
  apply fact_eq'.
Qed.

Lemma fact_eq_manual : forall n, stream_eq (fact_iter' (S n) (fact n)) (fact_slow' n).
  intros.
  apply (stream_eq_coind (fun s1 s2 => exists n, s1 = (fact_iter' (S n) (fact n)) /\ s2 = (fact_slow' n))).
  -
    intros. destruct H. destruct H. rewrite H. rewrite H0. reflexivity.
  -
    intros. destruct H. destruct H. rewrite H. rewrite H0.
    exists (S x). split.
    +
      simpl. reflexivity.
    +
      simpl. reflexivity.
  -
    exists n. split. reflexivity. reflexivity.
Qed.

Definition var := nat.

Definition vars := var -> nat.

Definition set (vs : vars) (v : var) (n : nat) : vars :=
  fun v' => if beq_nat v v' then n else vs v.

Inductive exp : Set :=
| Const : nat -> exp
| Var : var -> exp
| Plus : exp -> exp -> exp.

Fixpoint evalExp (vs : vars) (e : exp) : nat :=
  match e with
  | Const n => n
  | Var v => vs v
  | Plus e1 e2 => evalExp vs e1 + evalExp vs e2
  end.

Inductive cmd : Set :=
| Assign : var -> exp -> cmd
| Seq : cmd -> cmd -> cmd
| While : exp -> cmd -> cmd.

CoInductive evalCmd : vars -> cmd -> vars -> Prop :=
| EvalAssign : forall vs v e,
    evalCmd vs (Assign v e) (set vs v (evalExp vs e))
| EvalSeq : forall c1 c2 vs1 vs2 vs3,
    evalCmd vs1 c1 vs2 ->
    evalCmd vs2 c2 vs3 ->
    evalCmd vs1 (Seq c1 c2) vs3
| EvalWhileFalse : forall vs e c,
    evalExp vs e = 0 ->
    evalCmd vs (While e c) vs
| EvalWhileTrue : forall vs1 vs2 vs3 e c,
    evalExp vs1 e <> 0 ->
    evalCmd vs1 c vs2 ->
    evalCmd vs2 (While e c) vs3 ->
    evalCmd vs1 (While e c) vs3.

Section evalCmd_ind.
  Variable R : vars -> cmd -> vars -> Prop.

  Hypothesis AssignCase : forall v e vs1 vs2, R vs1 (Assign v e) vs2 -> vs2 = set vs1 v (evalExp vs1 e).

  Hypothesis SeqCase : forall vs1 vs3 c1 c2, R vs1 (Seq c1 c2) vs3 -> exists vs2, R vs1 c1 vs2 /\ R vs2 c2 vs3.

  Hypothesis WhileCase : forall vs1 vs3 e c, R vs1 (While e c) vs3 -> (evalExp vs1 e = 0 /\ vs1 = vs3) \/ (exists vs2,  evalExp vs1 e <> 0 /\ R vs1 c vs2 /\ R vs2 (While e c) vs3).

  Theorem evalCmd_ind : forall vs1 c vs2, R vs1 c vs2 -> evalCmd vs1 c vs2.
    cofix evalCmd_ind.
    intros. destruct c.
    -
      apply AssignCase in H. rewrite H. apply EvalAssign.
    -
      apply SeqCase in H. destruct H. destruct H. apply EvalSeq with x.
      +
        apply evalCmd_ind. assumption.
      +
        apply evalCmd_ind. assumption.
    -
      apply WhileCase in H. destruct H.
      +
        destruct H. rewrite H0. apply EvalWhileFalse. rewrite <- H0. assumption.
      +
        destruct H.  destruct H. destruct H0. apply EvalWhileTrue with x.
        *
          assumption.
        *
          apply evalCmd_ind in H0. assumption.
        *
          apply evalCmd_ind in H1. assumption.
  Qed.
End evalCmd_ind.

Fixpoint optExp (e : exp) : exp :=
  match e with
  | Plus (Const 0) e => optExp e
  | Plus e1 e2 => Plus (optExp e1) (optExp e2)
  | _ => e
  end.

Eval simpl in (optExp (optExp (Plus (Plus (Const 0) (Const 0)) (Const 5)))).

Fixpoint optCmd (c : cmd) : cmd :=
  match c with
  | Assign v e => Assign v (optExp e)
  | Seq c1 c2 => Seq (optCmd c1) (optCmd c2)
  | While e c => While (optExp e) (optCmd c)
  end.

Lemma optExp_correct : forall vs e, evalExp vs e = evalExp vs (optExp e).
  intros. generalize dependent vs.
  induction e.
  -
    intros. reflexivity.
  -
    intros. reflexivity.
  -
    intros. simpl.
    destruct e1.
    +
      destruct n.
      *
        simpl. apply (IHe2 vs).
      *
        simpl. rewrite IHe2. reflexivity.
    +
      simpl. rewrite IHe2. reflexivity.
    +
      crush.
Qed.

Lemma optCmd_correct1 : forall vs1 c vs2, evalCmd vs1 (optCmd c) vs2 -> evalCmd vs1 c vs2.
  intros. apply (evalCmd_ind (fun vs1 c vs2 => evalCmd vs1 (optCmd c) vs2)).
  -
    intros. simpl in H0. inversion H0. rewrite <- optExp_correct. reflexivity.
  -
    intros. simpl in H0. inversion H0. exists vs5. split.
    +
      assumption.
    +
      assumption.
  -
    intros. simpl in H0. inversion H0.
    +
      left. split. rewrite optExp_correct. assumption. reflexivity.
    +
      right. exists vs5. split.
      *
        rewrite optExp_correct. assumption.
      *
        split. { assumption. } { assumption. }
  -
    assumption.
Qed.

Lemma optCmd_correct2_helper : forall vs1 c vs2, (exists c', c = optCmd c' /\ evalCmd vs1 c' vs2) -> evalCmd vs1 c vs2.
  intros. apply (evalCmd_ind (fun vs1 c vs2 => exists c', c = optCmd c' /\ evalCmd vs1 c' vs2)).
  -
    intros. destruct H0. destruct H0. destruct x.
    +
      simpl in H0. injection H0. intros. inversion H1.
      rewrite H3. rewrite H2. rewrite <- optExp_correct. reflexivity.
    +
      simpl in H0. inversion H0.
    +
      simpl in H0. inversion H0.
  -
    intros. destruct H0. destruct H0. destruct x.
    +
      simpl in H0. inversion H0.
    +
      simpl in H0. injection H0. intros. inversion H1.
      exists vs5. split.
      *
        exists x1. split. assumption. assumption.
      *
        exists x2. split. assumption. assumption.
    +
      simpl in H0. inversion H0.
  -
    intros. destruct H0. destruct H0. destruct x.
    +
      simpl in H0. inversion H0.
    +
      simpl in H0. inversion H0.
    +
      simpl in H0. injection H0. intros.
      inversion H1.
      *
        left. split. rewrite H3. rewrite <- optExp_correct. assumption. reflexivity.
      *
        right. exists vs5. split.
        { rewrite H3. rewrite <- optExp_correct. assumption. }
        { split.
          { exists x. split. assumption. assumption. }
          { exists (While e0 x). split.
           { assumption. }
           { assumption. }}}
  -
    assumption.
Qed.

Lemma optCmd_correct2 : forall vs1 c vs2, evalCmd vs1 c vs2 -> evalCmd vs1 (optCmd c) vs2.
  intros.
  apply (optCmd_correct2_helper ).
  exists c. split. reflexivity. assumption.
Qed.

Lemma optCmd_correct : forall vs1 c vs2, evalCmd vs1 c vs2 <-> evalCmd vs1 (optCmd c) vs2.
  intros. split. apply optCmd_correct2. apply optCmd_correct1.
Qed.