Require Export A005poly.

Theorem silly1 : forall (n m o p : nat),
     n = m ->
     [n;o] = [n;p] ->
     [n;o] = [m;p].
Proof.
  intros n m o p eq1 eq2.
  rewrite <- eq1.
  (* At this point, we could finish with
     "rewrite → eq2. reflexivity." as we have
     done several times above. But we can achieve the
     same effect in a single step by using the
     apply tactic instead: *)
  apply eq2. Qed.

Theorem silly2 : forall (n m o p : nat),
     n = m ->
     (forall (q r : nat), q = r -> [q;o] = [r;p]) ->
     [n;o] = [m;p].
Proof.
  intros n m o p eq1 eq2.
  apply eq2. apply eq1. Qed.

Theorem silly2a : forall (n m : nat),
     (n,n) = (m,m) ->
     (forall (q r : nat), (q,q) = (r,r) -> [q] = [r]) ->
     [n] = [m].
Proof.
  intros n m eq1 eq2.
  apply eq2. apply eq1. Qed.

Theorem silly_ex :
     (forall n, evenb n = true -> oddb (S n) = true) ->
     evenb 3 = true ->
     oddb 4 = true.
Proof.
  intros h1 h2.
  apply h1.
  apply h2.
Qed.

Theorem silly3_firsttry : forall (n : nat),
     true = beq_nat n 5 ->
     beq_nat (S (S n)) 7 = true.
Proof.
  intros n H.
  rewrite H.  (* we cannot us apply here directly *)
  simpl.
  reflexivity.
Qed.

Theorem silly3 : forall (n : nat),
     true = beq_nat n 5 ->
     beq_nat (S (S n)) 7 = true.
Proof.
  intros n H.
  symmetry.
  simpl.
  apply H.
Qed.

Theorem rev_exercise1 : forall (l l' : list nat),
     l = rev l' ->
     l' = rev l.
Proof.
  intros.
  rewrite H.
  symmetry.
  apply rev_involutive.
Qed.

(* Difference between 'rewrite' and 'apply'

1. to use reflexivity you will always finish the goal.
   to use rewrite you will not finish the goal.
   to use apply either finish the goal or not is okay.
2. apply must apply on a hypothesis/lemma/theorem exactly matching the goal or
   exactly matching the simplified goal. where using rewrite it requires only
   that the goal contains the expression of one side of the hypo/lem/theom.
3. you can rewrite from the right hand side of a hypothesis, with the syntax
     rewrite <- xxx.
   while apply only apply hypothesis exactly matching even if it's simply
   swapped both sides of an equality. use 'symmetry' tactic to swap the
   expressions around an equality sign.
*)

Example trans_eq_example : forall (a b c d e f : nat),
     [a;b] = [c;d] ->
     [c;d] = [e;f] ->
     [a;b] = [e;f].
Proof.
  intros a b c d e f eq1 eq2.
  rewrite -> eq1. rewrite -> eq2. reflexivity. Qed.
Theorem trans_eq : forall (X:Type) (n m o : X),
  n = m -> m = o -> n = o.
Proof.
  intros X n m o eq1 eq2. rewrite -> eq1. rewrite -> eq2.
  reflexivity. Qed.

Example trans_eq_example' : forall (a b c d e f : nat),
     [a;b] = [c;d] ->
     [c;d] = [e;f] ->
     [a;b] = [e;f].
Proof.
  intros a b c d e f eq1 eq2.
  (* If we simply tell Coq apply trans_eq at this point,
     it can tell (by matching the goal against the
     conclusion of the lemma) that it should instantiate X
     with [nat], n with [a,b], and o with [e,f].
     However, the matching process doesn't determine an
     instantiation for m: we have to supply one explicitly
     by adding with (m:=[c,d]) to the invocation of
     apply. *)

  apply trans_eq with (m:=[c;d]). apply eq1. apply eq2. Qed.

Example trans_eq_exercise : forall (n m o p : nat),
     m = (minustwo o) ->
     (n + p) = m ->
     (n + p) = (minustwo o).
Proof.
  intros n m o p h1 h2.
  apply trans_eq with (m := m).
  apply h2.
  apply h1.
Qed.

Example inversion_try1 : forall (m n : nat), (S m = S n) -> m = n.
Proof.
  intros.
  inversion H.
  reflexivity.
Qed.

Example sillyex1 : forall (X : Type) (x y z : X) (l j : list X),
     x :: y :: l = z :: j ->
     y :: l = x :: j ->
     x = y.
Proof.
  intros.
  inversion H0.
  reflexivity.
Qed.

Theorem silly6 : forall (n : nat),
     S n = 0 ->
     2 + 2 = 5.
Proof.
  intros.
  inversion H.
Qed.

Theorem silly7 : forall (n m : nat),
     false = true ->
     [n] = [m].
Proof.
  intros n m contra. inversion contra. Qed.

Example sillyex2 : forall (X : Type) (x y z : X) (l j : list X),
     x :: y :: l = [] ->
     y :: l = z :: j ->
     x = z.
Proof.
  intros.
  inversion H.
Qed.

Theorem f_equal : forall (A B : Type) (f: A -> B) (x y: A),
    x = y -> f x = f y.
Proof.
  intros.
  rewrite H.
  reflexivity.
Qed.

Theorem beq_nat_0_l : forall n,
   beq_nat 0 n = true -> n = 0.
Proof.
  intros.
  destruct n.
  reflexivity.
  inversion H.
Qed.

Theorem beq_nat_0_r : forall n,
   beq_nat n 0 = true -> n = 0.
Proof.
  destruct n.
  reflexivity.
  simpl. intro.
  inversion H.
Qed.

Example inversion_try2 : forall (n k k' : nat),
                           (n + k = n + k' -> k = k').
Proof.
  intros n k k'.
  induction n.
  Case "n = 0".
    intro.
    simpl.
    assumption.
  Case "n = S n".
    simpl.
    intro.
    apply IHn.
    inversion H.
    reflexivity.
Qed.

Theorem S_inj : forall (n m : nat) (b : bool),
     beq_nat (S n) (S m) = b ->
     beq_nat n m = b.
Proof.
  intros n m b H. simpl in H. apply H. Qed.

Theorem silly3' : forall (n : nat),
  (beq_nat n 5 = true -> beq_nat (S (S n)) 7 = true) ->
     true = beq_nat n 5 ->
     true = beq_nat (S (S n)) 7.
Proof.
  intros n eq H.
  symmetry in H. apply eq in H. symmetry in H.
  apply H. Qed.

Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  intros n.
  induction n as [| n'].
  Case "n = 0".
    intro.
    destruct m.
    SCase "m = 0". reflexivity.
    SCase "m = S m". intro. inversion H.
  Case "n = S n".
    intro. simpl.
    destruct m.
    SCase "m = 0".
      intro. inversion H.
    SCase "m = S m".
      simpl.
      intro.
      inversion H.
      rewrite <- plus_n_Sm in H1.
      rewrite <- plus_n_Sm in H1.
      inversion H1.
      apply IHn' in H2.
      apply f_equal.
      assumption.
Qed.

Theorem double_injective_try: forall n m, double n = double m -> n = m.
Proof.
  intros n m.
  induction n, m.
  reflexivity.
  intro. inversion H.
  intro. inversion H.
  simpl. intro. inversion H.
Abort.

Theorem double_injective_try: forall n m, double n = double m -> n = m.
Proof.
  intros n.
  induction n.
  Case "n = 0".
    intros m eq. simpl in eq.
    destruct m. reflexivity. inversion eq.
  Case "n = S n".
    intros m eq. simpl in eq.
    destruct m. inversion eq.
    simpl in eq. inversion eq. apply f_equal. apply IHn. assumption.
Qed.

Theorem beq_nat_true : forall n m,
    beq_nat n m = true -> n = m.
Proof.
  intro n.
  induction n.
  Case "n = 0".
    intros m eq.
    induction m.
    SCase "m = 0". reflexivity.
    SCase "m = S m". inversion eq.
  Case "n = S n".
    intros m eq.
    induction m.
    SCase "m = 0".
      inversion eq.
    SCase "m = S m".
      inversion eq.
      apply f_equal.
      apply IHn.
      assumption.
Qed.

Theorem index_after_last: forall (n : nat) (X : Type) (l : list X),
     length l = n ->
     index n l = None.
Proof.
  intros.
  generalize dependent n.
  induction l.
  Case "l = []".
    intros. reflexivity.
  Case "l = x :: l".
    intros n eq.
    induction n.
    SCase "n = 0". inversion eq.
    SCase "n = S n". simpl. apply IHl. simpl in eq. inversion eq. reflexivity.
Qed.

Theorem length_snoc''' : forall (n : nat) (X : Type)
                                (v : X) (l : list X),
                           length l = n ->
                           length (snoc l v) = S n.
Proof.
  intros. generalize dependent n.
  induction l.
  Case "l = []".
    intros. simpl. rewrite <- H. reflexivity.
  Case "l = x :: l".
    simpl. intros.
    destruct n.
    SCase "n = 0". inversion H.
    SCase "n = S n".
      inversion H.
      rewrite H1.
      apply f_equal.
      apply IHl.
      assumption.
Qed.

Theorem app_length_cons : forall (X : Type) (l1 l2 : list X)
                                 (x : X) (n : nat),
     length (l1 ++ (x :: l2)) = n ->
     S (length (l1 ++ l2)) = n.
Proof.
  intros X l1 l2 x.
  induction l1.
  Case "l1 = []". simpl. intros. assumption.
  Case "l1 = x :: l1". simpl. intros.
    destruct n.
      SCase "n = 0". inversion H.
      SCase "n = S n".
        inversion H.
        apply f_equal.
        rewrite H1.
        apply IHl1.
        assumption.
Qed.

Theorem app_length_twice : forall (X:Type) (n:nat) (l:list X),
     length l = n ->
     length (l ++ l) = n + n.
Proof.
  intros X n l. generalize dependent n.
  induction l.
  Case "l1 = []". simpl. intros. rewrite <- H. reflexivity.
  Case "l1 = x : l1". simpl. intros.
  destruct n. inversion H. inversion H. simpl. apply f_equal.
  rewrite <- plus_n_Sm. rewrite H1.
  assert (forall (a b : list X), (length a) + (length b) = length (a ++ b)).
  intros. induction a. reflexivity. simpl. rewrite IHa. reflexivity.
  rewrite <- H0.
  simpl. rewrite <- plus_n_Sm. apply f_equal. rewrite H0. apply IHl.
  assumption.
Qed.

Theorem double_induction: forall (P : nat -> nat -> Prop),
  P 0 0 ->
  (forall m, P m 0 -> P (S m) 0) ->
  (forall n, P 0 n -> P 0 (S n)) ->
  (forall m n, P m n -> P (S m) (S n)) ->
  forall m n, P m n.
Proof.
  intros.
  generalize dependent n.
  induction m.
  intro n.
  induction n.
  assumption.
  apply H1. assumption.
  intro n.
  induction n.
  apply H0.
  apply IHm.
  apply H2.
  apply IHm.
Qed.

Definition sillyfun (n : nat) : bool :=
  if beq_nat n 3 then false
  else if beq_nat n 5 then false
  else false.

Theorem sillyfun_false : forall (n : nat),
  sillyfun n = false.
Proof.
  intros n. unfold sillyfun.
  destruct (beq_nat n 3).
    Case "beq_nat n 3 = true". reflexivity.
    Case "beq_nat n 3 = false". destruct (beq_nat n 5).
      SCase "beq_nat n 5 = true". reflexivity.
      SCase "beq_nat n 5 = false". reflexivity. Qed.

Theorem override_shadow : forall (X:Type) x1 x2 k1 k2 (f : nat -> X),
  (override (override f k1 x2) k1 x1) k2 = (override f k1 x1) k2.
Proof.
  intros.
  unfold override.
  destruct (beq_nat k1 k2).
  reflexivity.
  reflexivity.
Qed.

Theorem combine_split : forall X Y (l : list (X * Y)) l1 l2,
  split l = (l1, l2) ->
  combine l1 l2 = l.
Proof.
  intros X Y l.
  induction l.
  Case "l = []".
    simpl.
    intros.
    inversion H.
    reflexivity.
  Case "l = (x,y) :: l".
    intros.
    simpl in H.
    destruct x.
    destruct (split l).
    inversion H.
    simpl.
    apply f_equal.
    apply IHl.
    reflexivity.
Qed.

Definition sillyfun1 (n : nat) : bool :=
  if beq_nat n 3 then true
  else if beq_nat n 5 then true
  else false.

(*
  My Note: destruct <expr> eqn:<eqn>. is used when the destructed case should be
           used in the following proof.

*)

Theorem bool_fn_applied_thrice :
  forall (f : bool -> bool) (b : bool),
  f (f (f b)) = f b.
Proof.
  intros f b.
  destruct (f b) eqn:f'.
  destruct b eqn:b'.
  Case "b = true, f true = true".
    rewrite f'. assumption.
  Case "b = false, f false = true".
    destruct (f true) eqn:f''.
    SCase "f true = true".
      rewrite f''. reflexivity.
    SCase "f true = false".
      rewrite f'. reflexivity.
  destruct b.
  Case "b = true, f true = false".
    destruct (f false) eqn:f''.
    SCase "f false = true". assumption.
    SCase "f false = false". assumption.
  Case "b = false".
    rewrite f'. assumption.
Qed.

Theorem override_same : forall (X:Type) x1 k1 k2 (f : nat -> X),
  f k1 = x1 ->
  (override f k1 x1) k2 = f k2.
Proof.
  intros.
  unfold override.
  destruct (beq_nat k1 k2) eqn:eq.
  Case "k1 = k2".
    apply beq_nat_true in eq.
    rewrite <- eq. rewrite H. reflexivity.
  Case "k1 /= k2".
    reflexivity.
Qed.

Theorem beq_nat_sym : forall (n m : nat),
  beq_nat n m = beq_nat m n.
Proof.
  intro n.
  induction n as [| n'].
  Case "n = 0".
    intros m.
    destruct m.
    SCase "m = 0". reflexivity.
    SCase "m = S m".
      destruct (beq_nat 0 m).
      SSCase "0 = m". reflexivity.
      SSCase "0 /= m". reflexivity.
  Case "n = S n'".
    destruct m.
    SCase "m = 0". reflexivity.
    SCase "m = S m".
      destruct (beq_nat (S n') (S m)) eqn:eq.
      SSCase "S n = S m".
        simpl in eq. simpl. rewrite <- eq.
        apply IHn'.
      SSCase "S n /= S m".
        simpl in eq. simpl. rewrite <- eq.
        apply IHn'.
Qed.

Theorem beq_nat_trans : forall n m p,
  beq_nat n m = true ->
  beq_nat m p = true ->
  beq_nat n p = true.
Proof.
  intros.
  apply beq_nat_true in H.
  apply beq_nat_true in H0.
  rewrite H. rewrite H0.
  symmetry. apply beq_nat_refl.
Qed.

(*
Definition split_combine_statement : Prop :=
  forall (X : Type) (Y : Type)
         (l1 : list X) (l2 : list Y) (l : list (X * Y)),
      length l1 = length l
   -> length l2 = length l
   -> combine l1 l2 = l
   -> split l = (l1,l2)
*)

Definition split_combine_statement : Prop :=
  forall {X Y} (l1 : list X) (l2 : list Y) (l : list (X * Y)),
    length l1 = length l2 ->
    combine l1 l2 = l ->
    split l = (l1,l2).

Theorem split_combine : split_combine_statement.
Proof.
  unfold split_combine_statement.
  intros.
  generalize dependent l1.
  generalize dependent l2.
  induction l as [| [x y] l' ].

  Case "l = []".
    intros.
    destruct l1,l2.
    reflexivity.
    inversion H. inversion H.
    inversion H0.

  Case "l = (x,y) :: l'".
    intros.
    destruct l1,l2.

    SCase "l1 = l2 = []". inversion H0.
    SCase "l1 = [], l2 = y0::l2". inversion H.
    SCase "l1 = x0::l1, l2 = []". inversion H.
    SCase "l1 = x0::l1, l2 = y0::l2".
      simpl in H0.
      inversion H0.
      simpl.
      simpl in H. inversion H.
      apply IHl' in H5.
      rewrite H4.
      rewrite H5.
      reflexivity.

      SSCase "showing 'combine l1 l2 = l'". assumption.
Qed.

(*
Definition split_combine_statement : Prop :=
  forall {X Y} (l : list (X * Y)) l1 l2,
    (l1,l2) = split l -> combine l1 l2 = l.

Theorem split_combine : split_combine_statement.
Proof.
  unfold split_combine_statement.
  intros X Y l.
  induction l as [| [x y] l'].
  Case "l = []".
    simpl. intros.
    inversion H.
    reflexivity.
  Case "l = (x,y) :: l'".
    simpl. destruct (split l') as [lx ly]. intros.
    inversion H. simpl. apply f_equal. apply IHl'. reflexivity.
Qed.
*)

Theorem override_permute : forall (X:Type) x1 x2 k1 k2 k3 (f : nat -> X),
  beq_nat k2 k1 = false ->
  (override (override f k2 x2) k1 x1) k3 = (override (override f k1 x1) k2 x2) k3.
Proof.
  intros.
  unfold override.
  destruct (beq_nat k2 k3) eqn:eq.
  Case "k2 = k3".
    apply beq_nat_true in eq. rewrite <- eq.
    rewrite beq_nat_sym. rewrite H. reflexivity.
  Case "k2 /= k3".
    reflexivity.
Qed.

Theorem filter_exercise : forall (X : Type) (test : X -> bool)
                             (x : X) (l lf : list X),
     filter test l = x :: lf ->
     test x = true.
Proof.
  intros X test x l.
  induction l as [| x' l'].
  Case "l = []".
    intros.
    inversion H.
  Case "l = x' :: l'".
    destruct (test x') eqn:eq.
    SCase "test x' = true".
      simpl. rewrite eq. intros. inversion H. rewrite <- H1. assumption.
    SCase "test x' = false".
      simpl. rewrite eq. intro lf. apply IHl'.
Qed.

Fixpoint forallb {X} (f : X -> bool) (l : list X) : bool :=
  match l with
    | []       => true
    | x :: xs  => andb (f x) (forallb f xs)
  end.

Fixpoint existsb {X} f (l : list X) : bool :=
  match l with
    | []       => false
    | x :: xs  => orb (f x) (existsb f xs)
  end.

Definition existsb' {X} f (l : list X) := negb (forallb (fun x => negb (f x)) l).

Theorem existsb_variant : forall {X: Type} (f : X -> bool) (l: list X),
                            existsb f l = existsb' f l.
Proof.
  intros.
  induction l.
  Case "l = []".
    reflexivity.
  Case "l = x :: l".
    unfold existsb'.
    simpl.
    unfold existsb' in IHl.
    destruct (f x) eqn:fx.
    reflexivity.
    simpl. assumption.
Qed.


Require Export GeoCoq.Tarski_dev.Ch16_coordinates.

Section PythagoreanFun.

Context `{T2D:Tarski_2D}.
Context `{TE:@Tarski_euclidean Tn TnEQD}.

Lemma Ps_Col : forall O E A, Ps O E A -> Col O E A.
Proof.
intros.
unfold Ps in H.
apply out_col in H;Col.
Qed.

Lemma PythRel_exists : forall O E E', ~ Col O E  E' -> forall A B,
 Col O E A -> Col O E B ->
 exists C, PythRel O E E' A B C.
Proof.
intros.
assert_diffs.
destruct (eq_dec_points O B).
- subst.
 exists A.
 unfold PythRel.
 split.
 unfold Ar2;auto.
 left;auto.
-
destruct (perp_exists O E O) as [X HX].
auto.
destruct (segment_construction_2 X O O B) as [B' [HB1 HB2]].
assert_diffs;auto.
destruct (segment_construction_2 E O A B') as [C [HC1 HC2]].
auto.
exists C.
unfold PythRel.
split.
unfold Ar2.
repeat split;auto.
destruct HC1.
auto using bet_col .
apply bet_col in H3. Col.
right.
exists B'.
split.

assert (Perp O X O B).
apply (perp_col1 O X O E B);Col.
Perp.
assert (Perp O B O B').
 apply (perp_col1 O B O X B').
 intro;treat_equalities.
 intuition.
 Perp.
 destruct HB1.
 apply bet_col in H6. Col.
 apply bet_col in H6. Col.
 Perp.
 split.
 Cong.
 Cong.
Qed.

Lemma opp_same_square : forall O E E' A B A2, Opp O E E' A B -> Prod O E E' A A A2 -> Prod O E E' B B A2.
intros.

assert(~Col O E E').
unfold Prod in H0.
spliter.
unfold Ar2  in H0.
tauto.

assert(exists ME : Tpoint, Opp O E E' E ME).
apply(opp_exists O E E' H1 E); Col;
assert(HH:= opp_prod O E E').
ex_and H2 ME.

assert(HH:= opp_prod O E E' ME A B H3 H).
assert(Prod O E E' B ME A).
apply(opp_prod O E E' ME B A H3).
apply opp_comm; auto.
assert(Prod O E E' ME B A).
apply prod_comm; auto.

assert(HP:=(prod_assoc O E E' A ME B B A A2 HH H4)).
destruct HP.
apply H5.
assumption.
Qed.

(**********)

Lemma PythOK : forall O E E' A B C A2 B2 C2, PythRel O E E' A B C ->
 Prod O E E' A A A2 ->
 Prod O E E' B B B2 ->
 Prod O E E' C C C2 ->
 Sum O E E' A2 B2 C2.
Proof.
intros.

unfold PythRel in H.
spliter.
unfold Ar2 in H.
spliter.

induction H3.
spliter.
subst B.

assert(B2=O).
apply (prod_O_l_eq O E E' O); auto.
subst B2.

assert(A2 = C2).

induction H7.

subst C.
apply (prod_uniqueness O E E' A A); auto.
assert(Prod O E E' C C A2).
apply(opp_same_square O E E' A); auto.
apply (prod_uniqueness O E E' C C); auto.
subst C2.

apply (sum_A_O O E E' ); auto.
unfold Prod in H0.
spliter.
unfold Ar2 in H0; tauto.

(*
ex_and H3 B'.
assert(B2=O).
apply (prod_O_l_eq O E E' O); auto.
subst B2.
apply (sum_A_O O E E' ); auto.
unfold Prod in H0.
spliter.
unfold Ar2 in H0; tauto.
*)

assert(O <> E).
intro.
subst E.
apply H.
Col.

ex_and H3 B'.
assert(Per A O B').
apply l8_2.
apply (per_col _ _ B).
apply perp_distinct in H3.
tauto.
apply perp_in_per.
apply perp_in_comm.
apply perp_perp_in.
Perp.
ColR.

induction(eq_dec_points A O).
subst A.
assert(Cong O B O C).
apply cong_transitivity with O B'; Cong.
assert(B = C \/ Midpoint O B C).
apply l7_20; auto.
ColR.
induction H12.
subst C.
assert(B2 = C2).
apply(prod_uniqueness O E E' B B); auto.
subst C2.
assert(A2=O).
apply(prod_uniqueness O E E' O O); auto.
apply prod_0_l; auto.
subst A2.
apply sum_O_B; Col.
unfold Prod in H2.
spliter.
unfold Ar2 in H2.
tauto.
assert(A2=O).
apply(prod_uniqueness O E E' O O); auto.
apply prod_0_l; auto.
subst A2.
apply (midpoint_opp O E E') in H12;

unfold Midpoint in H12.
assert(C2 = B2).
apply(prod_uniqueness O E E' C C);auto.
apply (opp_same_square O E E' B C); auto.
subst C2.
apply sum_O_B; auto.
unfold Prod in H2.
spliter.
unfold Ar2 in H2.
tauto.
unfold Ar2.
repeat split; auto.

induction(out_dec O A E); induction(out_dec O B E);induction(out_dec O C E).

(****** A>0 ********* B>0 ********** C>0 ********)

apply(pythagoras O E E' A B' O A B C A2 B2 C2); auto.

unfold Length.
repeat split; auto.
unfold LeP.
left.
unfold LtP.
exists C.
split.
apply sum_diff.
apply sum_O_B; Col.
unfold Ps.
assumption.

unfold Length.
repeat split; Cong.
unfold LeP.
left.
unfold LtP.
exists A.
split.
apply sum_diff.
apply sum_O_B; Col.
unfold Ps.
assumption.

unfold Length.
repeat split; Cong.
unfold LeP.
left.
unfold LtP.
exists B.
split.
apply sum_diff.
apply sum_O_B; Col.
unfold Ps.
assumption.

(****** A>0 ********* B>0 ********** C<0 ********)

assert(exists OC : Tpoint, Opp O E E' C OC).
apply(opp_exists O E E' H C).
Col.
ex_and H15 OC.

assert(Ng O E C).
unfold Ng.
repeat split; auto.
intro.
subst C.

apply cong_symmetry in H9.
apply cong_identity in H9.
subst B'.
apply perp_right_comm in H3.
apply perp_not_col in H3.
apply H3.
ColR.
apply not_out_bet in H14.
assumption.
Col.

assert(Ps O E OC).
apply(opp_neg_pos O E E' C OC); auto.
apply(pythagoras O E E' A B' O A B OC A2 B2 C2); auto.

unfold Length.
repeat split; auto.
unfold Ps in H16.
apply out_col in H17.
Col.
unfold LeP.
left.
unfold LtP.
exists OC.
split; auto.
apply diff_A_O; auto.
unfold Ps in H17.
Col.

apply opp_midpoint in H16.
unfold Midpoint in H16.
spliter.
apply cong_transitivity with O C; Cong.

unfold Length.
repeat split; Cong.
unfold LeP.
left.
unfold LtP.
exists A.
split.
apply sum_diff.
apply sum_O_B; Col.
unfold Ps.
assumption.

unfold Length.
repeat split; Cong.
unfold LeP.
left.
unfold LtP.
exists B.
split.
apply sum_diff.
apply sum_O_B; Col.
unfold Ps.
assumption.
apply(opp_same_square O E E' C OC C2 H16 H2).

(****** A>0 ********* B<0 ********** C>0 ********)

assert(exists OB : Tpoint, Opp O E E' B OB).
apply(opp_exists O E E' H B).
Col.
ex_and H15 OB.

assert(Ng O E B).
unfold Ng.
repeat split; auto.
intro.
subst B.

apply cong_identity in H8.
subst B'.
apply perp_distinct in H3.
tauto.
apply not_out_bet in H13.
assumption.
Col.

assert(Ps O E OB).
apply(opp_neg_pos O E E' B OB); auto.
apply(pythagoras O E E' A B' O A OB C A2 B2 C2); auto.

unfold Length.
repeat split; auto.
unfold Ps in H17.
apply out_col in H17.
Col.
unfold LeP.
left.
unfold LtP.
exists C.
split; auto.
apply diff_A_O; auto.
unfold Ps in H17.
Col.

unfold Length.
repeat split; Cong.
unfold LeP.
left.
unfold LtP.
exists A.
split.
apply sum_diff.
apply sum_O_B; Col.
unfold Ps.
assumption.

unfold Length.
repeat split; Cong;
Col.
unfold LeP.
left.
unfold LtP.
exists OB.
split; auto.
apply diff_A_O; auto.
Col.
apply opp_midpoint in H16.
unfold Midpoint in H16.
spliter.
apply cong_transitivity with O B; Cong.
apply(opp_same_square O E E' B OB B2 H16 H1).

(****** A>0 ********* B<0 ********** C<0 ********)

assert(exists OC : Tpoint, Opp O E E' C OC).
apply(opp_exists O E E' H C).
Col.
ex_and H15 OC.

assert(Ng O E C).
unfold Ng.
repeat split; auto.
intro.
subst C.

apply cong_symmetry in H9.
apply cong_identity in H9.
subst B'.
apply perp_right_comm in H3.
apply perp_not_col in H3.
apply H3.
ColR.
apply not_out_bet in H14.
assumption.
Col.

assert(Ps O E OC).
apply(opp_neg_pos O E E' C OC); auto.

assert(exists OB : Tpoint, Opp O E E' B OB).
apply(opp_exists O E E' H B).
Col.
ex_and H18 OB.

assert(Ng O E B).
unfold Ng.
repeat split; auto.
intro.
subst B.

apply cong_identity in H8.
subst B'.
apply perp_distinct in H3.
tauto.
apply not_out_bet in H13.
assumption.
Col.

assert(Ps O E OB).
apply(opp_neg_pos O E E' B OB); auto.
apply(pythagoras O E E' A B' O A OB OC A2 B2 C2); auto.

unfold Length.
repeat split; auto.
unfold Ps in H17.
apply out_col in H17.
Col.
unfold LeP.
left.
unfold LtP.
exists OC.
split; auto.
apply diff_A_O; auto.
unfold Ps in H17.
Col.
apply opp_midpoint in H16.
unfold Midpoint in H16.
spliter.
apply cong_transitivity with O C; Cong.

unfold Length.
repeat split; Cong.
unfold LeP.
left.
unfold LtP.
exists A.
split.
apply sum_diff.
apply sum_O_B; Col.
unfold Ps.
assumption.

unfold Length.
repeat split; Cong;
Col.
unfold LeP.
left.
unfold LtP.
exists OB.
split; auto.
apply diff_A_O; auto.
Col.
apply opp_midpoint in H19.
unfold Midpoint in H19.
spliter.
apply cong_transitivity with O B; Cong.
apply(opp_same_square O E E' B OB B2 H19 H1).
apply(opp_same_square O E E' C OC C2 H16 H2).

(****** A<0 ********* B>0 ********** C>0 ********)

assert(exists OA : Tpoint, Opp O E E' A OA).
apply(opp_exists O E E' H A).
Col.
ex_and H15 OA.

assert(Ng O E A).
unfold Ng.
repeat split; auto.
apply not_out_bet in H12;auto.
Col.

apply(pythagoras O E E' A B' O OA B C A2 B2 C2); auto.

unfold Length.
repeat split; auto.
unfold LeP.
left.
unfold LtP.
exists C.
split.
apply sum_diff.
apply sum_O_B; Col.
unfold Ps.
assumption.

assert(Col O E OA).
unfold Opp in H16.
unfold Sum in H16.
spliter.
unfold Ar2 in H16.
tauto.

unfold Length.
repeat split; auto.
unfold LeP.
left.
unfold LtP.
exists OA.
split.
apply sum_diff.
apply sum_O_B; Col.
unfold Ps.
apply opp_midpoint in H16.
unfold Midpoint in H16.
spliter.
apply not_out_bet in H12.
assert(HP:=l5_2 A O E OA H11 H12 H16).
unfold Out.
repeat split; auto.
intro.
subst OA.
apply cong_identity in H18.
contradiction.
induction HP.
right; auto.
left; auto.
Col.

unfold Opp in H16.
apply opp_midpoint in H16.
unfold Midpoint in H16.
unfold Sum in H16.
spliter.
Cong.

unfold Length.
repeat split; Cong.
unfold LeP.
left.
unfold LtP.
exists B.
split.
apply sum_diff.
apply sum_O_B; Col.
unfold Ps.
assumption.
apply(opp_same_square O E E' A OA A2 H16 H0).

(****** A<0 ********* B>0 ********** C<0 ********)

assert(exists OC : Tpoint, Opp O E E' C OC).
apply(opp_exists O E E' H C).
Col.
ex_and H15 OC.

assert(Ng O E C).
unfold Ng.
repeat split; auto.
intro.
subst C.

apply cong_symmetry in H9.
apply cong_identity in H9.
subst B'.
apply perp_right_comm in H3.
apply perp_not_col in H3.
apply H3.
ColR.
apply not_out_bet in H14.
assumption.
Col.

assert(Ps O E OC).
apply(opp_neg_pos O E E' C OC); auto.

assert(exists OA : Tpoint, Opp O E E' A OA).
apply(opp_exists O E E' H A).
Col.
ex_and H18 OA.
assert(Ng O E A).
unfold Ng.
repeat split; auto.
apply not_out_bet in H12;auto.
Col.

assert(Col O E OA).
unfold Opp in H19.
unfold Sum in H19.
spliter.
unfold Ar2 in H19.
tauto.

apply(pythagoras O E E' A B' O OA B OC A2 B2 C2); auto.

unfold Length.
repeat split; auto.
unfold Ps in H17.
apply out_col in H17.
Col.
unfold LeP.
left.
unfold LtP.
exists OC.
split; auto.
apply diff_A_O; auto.
unfold Ps in H17.
Col.
apply opp_midpoint in H16.
unfold Midpoint in H16.
spliter.
apply cong_transitivity with O C; Cong.

unfold Length.
repeat split; auto.
unfold LeP.
left.
unfold LtP.
exists OA.
split.
apply sum_diff.
apply sum_O_B; Col.
unfold Ps.
apply opp_midpoint in H19.
unfold Midpoint in H19.
spliter.
apply not_out_bet in H12.
assert(HP:=l5_2 A O E OA H11 H12 H19).
unfold Out.
repeat split; auto.
intro.
subst OA.
apply cong_identity in H21.
contradiction.
induction HP.
right; auto.
left; auto.
Col.
apply opp_midpoint in H19.
unfold Midpoint in H19.
spliter.
Cong.

unfold Length.
repeat split; Cong.
unfold LeP.
left.
unfold LtP.
exists B.
split.
apply sum_diff.
apply sum_O_B; Col.
unfold Ps.
assumption.
apply(opp_same_square O E E' A OA A2 H19 H0).
apply(opp_same_square O E E' C OC C2 H16 H2).

(****** A<0 ********* B<0 ********** C>0 ********)

assert(exists OB : Tpoint, Opp O E E' B OB).
apply(opp_exists O E E' H B).
Col.
ex_and H15 OB.

assert(Ng O E B).
unfold Ng.
repeat split; auto.
intro.
subst B.

apply cong_identity in H8.
subst B'.
apply perp_distinct in H3.
tauto.
apply not_out_bet in H13.
assumption.
Col.

assert(Ps O E OB).
apply(opp_neg_pos O E E' B OB); auto.

assert(exists OA : Tpoint, Opp O E E' A OA).
apply(opp_exists O E E' H A).
Col.
ex_and H18 OA.
assert(Ng O E A).
unfold Ng.
repeat split; auto.
apply not_out_bet in H12;auto.
Col.

assert(Col O E OA).
unfold Opp in H19.
unfold Sum in H19.
spliter.
unfold Ar2 in H19.
tauto.

apply(pythagoras O E E' A B' O OA OB C A2 B2 C2); auto.

unfold Length.
repeat split; auto.
unfold LeP.
left.
unfold LtP.
exists C.
split.
apply sum_diff.
apply sum_O_B; Col.
auto.

unfold Length.
repeat split; auto.
unfold LeP.
left.
unfold LtP.
exists OA.
split.
apply sum_diff.
apply sum_O_B; Col.
unfold Ps.
apply opp_midpoint in H19.
unfold Midpoint in H19.
spliter.
apply not_out_bet in H12.
assert(HP:=l5_2 A O E OA H11 H12 H19).
unfold Out.
repeat split; auto.
intro.
subst OA.
apply cong_identity in H21.
contradiction.
induction HP.
right; auto.
left; auto.
Col.
apply opp_midpoint in H19.
unfold Midpoint in H19.
spliter.
Cong.

unfold Length.
repeat split; Cong;
Col.
unfold LeP.
left.
unfold LtP.
exists OB.
split; auto.
apply diff_A_O; auto.
Col.
apply opp_midpoint in H16.
unfold Midpoint in H16.
spliter.
apply cong_transitivity with O B; Cong.
apply(opp_same_square O E E' A OA A2 H19 H0).
apply(opp_same_square O E E' B OB B2 H16 H1).

(****** A<0 ********* B<0 ********** C<0 ********)

assert(exists OC : Tpoint, Opp O E E' C OC).
apply(opp_exists O E E' H C).
Col.
ex_and H15 OC.

assert(Ng O E C).
unfold Ng.
repeat split; auto.
intro.
subst C.

apply cong_symmetry in H9.
apply cong_identity in H9.
subst B'.
apply perp_right_comm in H3.
apply perp_not_col in H3.
apply H3.
ColR.
apply not_out_bet in H14.
assumption.
Col.

assert(Ps O E OC).
apply(opp_neg_pos O E E' C OC); auto.

assert(exists OA : Tpoint, Opp O E E' A OA).
apply(opp_exists O E E' H A).
Col.
ex_and H18 OA.
assert(Ng O E A).
unfold Ng.
repeat split; auto.
apply not_out_bet in H12;auto.
Col.

assert(Col O E OA).
unfold Opp in H19.
unfold Sum in H19.
spliter.
unfold Ar2 in H19.
tauto.

assert(exists OB : Tpoint, Opp O E E' B OB).
apply(opp_exists O E E' H B).
Col.
ex_and H21 OB.

assert(Ng O E B).
unfold Ng.
repeat split; auto.
intro.
subst B.

apply cong_identity in H8.
subst B'.
apply perp_distinct in H3.
tauto.
apply not_out_bet in H13.
assumption.
Col.

assert(Ps O E OB).
apply(opp_neg_pos O E E' B OB); auto.

apply(pythagoras O E E' A B' O OA OB OC A2 B2 C2); auto.

unfold Length.
repeat split; auto.
unfold Ps in H17.
apply out_col in H17.
Col.
unfold LeP.
left.
unfold LtP.
exists OC.
split; auto.
apply diff_A_O; auto.
unfold Ps in H17.
Col.
apply opp_midpoint in H16.
unfold Midpoint in H16.
spliter.
apply cong_transitivity with O C; Cong.

unfold Length.
repeat split; auto.
unfold LeP.
left.
unfold LtP.
exists OA.
split.
apply sum_diff.
apply sum_O_B; Col.
unfold Ps.
apply opp_midpoint in H19.
unfold Midpoint in H19.
spliter.
apply not_out_bet in H12.
assert(HP:=l5_2 A O E OA H11 H12 H19).
unfold Out.
repeat split; auto.
intro.
subst OA.
apply cong_identity in H24.
contradiction.
induction HP.
right; auto.
left; auto.
Col.
apply opp_midpoint in H19.
unfold Midpoint in H19.
spliter.
Cong.

unfold Length.
repeat split; Cong;
Col.
unfold LeP.
left.
unfold LtP.
exists OB.
split; auto.
apply diff_A_O; auto.
Col.
apply opp_midpoint in H22.
unfold Midpoint in H22.
spliter.
apply cong_transitivity with O B; Cong.
apply(opp_same_square O E E' A OA A2 H19 H0).
apply(opp_same_square O E E' B OB B2 H22 H1).
apply(opp_same_square O E E' C OC C2 H16 H2).
Qed.

Lemma PythRel_uniqueness : forall O E E' A B C1 C2,
 PythRel O E E' A B C1 ->
 PythRel O E E' A B C2 ->
 ((Ps O E C1 /\ Ps O E C2) \/ C1 = O)->
 C1 = C2.

Proof.
intros.
unfold PythRel in *.
spliter.
unfold Ar2 in *.
spliter.
clean_duplicated_hyps;
induction H2; induction H3.
spliter.
subst B.

induction H4; induction H3.
subst C1.
subst C2.
auto.
subst A.
induction H1.
spliter.
unfold Opp in H3.
apply sum_comm in H3; auto.

assert(HP:=sum_pos_pos O E E' C1 C2 O H1 H2 H3).
assert(HQ:=O_not_positive O E).
contradiction.

subst C1.
unfold Opp in H3.

apply (sum_A_O_eq O E E') in H3; auto.

subst C2.
induction H1.
spliter.
unfold Opp in H2.
assert(HP:=sum_pos_pos O E E' C1 A O H1 H3 H2).
assert(HQ:=O_not_positive O E).
contradiction.

subst C1.
unfold Opp in H2.
apply(sum_O_B_eq O E E') in H2; auto.
unfold Opp in *.
eapply (sum_uniquenessA O E E' H A C1 C2 O); auto.

ex_and H2 B'.
spliter.
subst B.
apply perp_distinct in H2.
tauto.
ex_and H0 B'.
spliter.
subst B.
apply perp_distinct in H0.
tauto.

ex_and H0 B1.
ex_and H2 B2.
assert(Cong O B1 O B2).
apply cong_transitivity with O B; Cong.

assert (O <> E).
intro.
subst E.
apply H;Col.

assert(HH:= perp2__col O B1 B2 O B H0 H2).

assert(B1 = B2 \/ Midpoint O B1 B2).
apply l7_20; Col.

induction H13.
subst B2.
clean_duplicated_hyps.
clean_trivial_hyps.

assert(Cong O C2 O C1).
apply cong_transitivity with A B1; Cong.

assert(C1 = C2 \/ Midpoint O C1 C2).
apply l7_20.
ColR.
Cong.
induction H5.
assumption.

induction H1.

unfold Ps in H1.
unfold Ps in H2.
spliter.
assert(Out O C1 C2).
apply (l6_7 _ _ E); Out.
unfold Midpoint in H5.
spliter.
apply l6_4_1 in H5; auto.
tauto.

subst C1.
unfold Midpoint in H5.
spliter.
apply cong_symmetry in H5.
apply (cong_identity O C2 O);auto.

induction(eq_dec_points A O).
subst A.

assert(Cong O C1 O C2).
apply cong_transitivity with O B2; trivial.
apply cong_transitivity with O B1; Cong.
assert(C1 = C2 \/ Midpoint O C1 C2).
apply l7_20; eCol.

induction H15.
assumption.

induction H1.

unfold Ps in H1.
unfold Ps in H2.
spliter.
assert(Out O C1 C2).
apply (l6_7 _ _ E); Out.
unfold Midpoint in H15.
spliter.
apply l6_4_1 in H15; auto.
tauto.

subst C1.
apply cong_symmetry in H5.
apply (cong_identity O C2 O);auto.
Cong.

assert(Per A O B1).
apply perp_in_per.
apply perp_in_comm.
apply perp_perp_in.

apply (perp_col O B ).
auto.
Perp.
ColR.

unfold Per in H15.
ex_and H15 B2'.
assert(B2 = B2').
apply (symmetric_point_uniqueness B1 O); auto.
subst B2'.

assert(Cong O C1 O C2).
apply cong_transitivity with A B2; trivial.
apply cong_transitivity with A B1; Cong.

assert(C1 = C2 \/ Midpoint O C1 C2).
apply l7_20.
ColR.
Cong.

induction H18.
assumption.

induction H1.
spliter.

unfold Ps in H1.
unfold Ps in H19.
assert(Out O C1 C2).
apply (l6_7 _ _ E); Out.
unfold Midpoint in H18.
spliter.
apply l6_4_1 in H18; auto.
tauto.

subst C1.
apply cong_symmetry in H17.
apply (cong_identity O C2 O);auto.
Qed.

End PythagoreanFun.


Require Import Cpdt.CpdtTactics.

Set Implicit Arguments.

(* 1 *)
CoInductive itree (A : Type) : Type :=
| Node : A -> itree A -> itree A -> itree A.

CoFixpoint everywhere {A : Type} (x : A) : itree A :=
  Node x (everywhere x) (everywhere x).

CoFixpoint map {A B C : Type} (f : A -> B -> C)
    (t1 : itree A) (t2 : itree B) :=
  match (t1, t2) with
  | (Node x l1 r1, Node y l2 r2) =>
      Node (f x y) (map f l1 l2) (map f r1 r2)
  end.

CoFixpoint falses := everywhere false.
CoFixpoint trues := everywhere true.

CoFixpoint true_false : itree bool := let ft := Node false true_false true_false in
  Node true ft ft.

CoFixpoint true_false' : itree bool :=
  Node true false_true' false_true'
with false_true' : itree bool :=
  Node false true_false' true_false'.

CoInductive itree_eq {A : Type} : itree A -> itree A ->Prop :=
  | ITree_eq : forall x l1 l2 r1 r2, itree_eq l1 l2 -> itree_eq r1 r2 ->
      itree_eq (Node x l1 r1) (Node x l2 r2).

Definition u {A : Type} (t : itree A) :=
  match t with
  | Node x l r => Node x l r
  end.

Theorem uiu : forall {A : Type} (t : itree A), t = u t.
Proof.
  intros; destruct t; reflexivity.
Qed.

Definition value {A : Type} (t : itree A) : A :=
  match t with
  | Node x _ _ => x
  end.

Definition left {A : Type} (t : itree A) : itree A :=
  match t with
  | Node _ l _ => l
  end.

Definition right {A : Type} (t : itree A) : itree A :=
  match t with
  | Node _ _ r => r
  end.

Section itree_eq_coind.
  Variable A : Type.
  Variable R : itree A -> itree A -> Prop.

  Hypothesis Value_case : forall t1 t2, R t1 t2 -> value t1 = value t2.
  Hypothesis Left_case : forall t1 t2, R t1 t2 -> R (left t1) (left t2).
  Hypothesis Right_case : forall t1 t2, R t1 t2 -> R (right t1) (right t2).

  Theorem itree_eq_coind : forall t1 t2, R t1 t2 -> itree_eq t1 t2.
  Proof.
    cofix; destruct t1; destruct t2; intros.
    generalize (Value_case H); intro; simpl in H0; rewrite <- H0.
    constructor; apply itree_eq_coind; [ apply (Left_case H) | apply (Right_case H) ].
  Qed.
End itree_eq_coind.

Require Import Bool.
Check itree_eq_coind.

Theorem false_is_fixp : forall b, b || false = b.
Proof.
  destruct b; reflexivity.
Qed.

Hint Rewrite false_is_fixp.

Theorem falses_is_fixp : forall t, itree_eq t (map orb t (everywhere false)).
Proof.
  cofix; destruct t; rewrite (uiu (map _ _ _)); crush;
  constructor; apply falses_is_fixp.
Qed.

Theorem true_false_or : itree_eq true_false (map orb true_false (everywhere false)).
Proof.
  cofix; apply (falses_is_fixp true_false).
Qed.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)
(* Construction of a pseudorangom generator from a one-way permutations on bit vector with an associated hard core predicate. *)

Set Implicit Arguments.

Require Import FCF.FCF.
Require Import FCF.SemEquiv.

Section OneWayPermutation.

  Variable n : nat.

  Variable f : Bvector n -> Bvector n.
  Variable f_inv : Bvector n -> Bvector n.

  Hypothesis f_inv1 : forall v, f (f_inv v) = v.
  Hypothesis f_inv2 : forall v, f_inv (f v) = v.

  Variable A : Bvector n -> Comp (Bvector n).

  Definition OWP_G :=
    c <-$ {0, 1} ^ n;
    a <-$ A (f c);
    ret (eqb a c).

  Definition OWP_Advantage := | (Pr[OWP_G])  - (1 / (2 ^ n)) |.

End OneWayPermutation.

Section HardCorePredicate.

  Variable n : nat.
  Variable f : Bvector n -> Bvector n.
  Variable b : Bvector n -> bool.

  Variable A : Bvector n -> bool -> Comp bool.

  Definition HCP_G1 :=
    r <-$ {0, 1} ^ n;
    g <-$ (A (f r) (b r));
    ret g.

  Definition HCP_G2 :=
    rb <-$ {0, 1};
    r <-$ {0, 1} ^ n;
    g <-$ (A (f r) rb);
    ret g.

  Definition HCP_Advantage := | (Pr[HCP_G1]) - (Pr[HCP_G2]) | .

End HardCorePredicate.

Definition vector_firstPart_h(A : Set)(m1 m2 : nat)(v : Vector.t A (m1 + m2)) : {ls : list A | length ls = m1}.
refine (exist _ (firstn m1 (Vector.to_list v)) _).
eapply eq_trans.
apply firstn_length.
rewrite to_list_length.
eapply min_l.
lia.
Defined.

Definition firstPart(A : Set)(m1 m2 : nat)(v : Vector.t A (m1 + m2)) : Vector.t A m1 :=
  of_sig_list (vector_firstPart_h m1 m2 v).

Theorem skipn_length : forall (A : Set) n0 (ls : list A),
  length (skipn n0 ls) = (length ls) - n0.

  induction n0; intuition; simpl in *.

  destruct ls; simpl.
  trivial.
  eauto.
Qed.

Definition vector_secondPart_h(A : Set)(m1 m2 : nat)(v : Vector.t A (m1 + m2)) : {ls : list A | length ls = m2}.
refine (exist _ (skipn m1 (Vector.to_list v)) _).
rewrite skipn_length.
rewrite to_list_length.
lia.
Defined.

Definition secondPart(A : Set)(m1 m2 : nat)(v : Vector.t A (m1 + m2)) : Vector.t A m2 :=
  of_sig_list (vector_secondPart_h m1 m2 v).

Section OWP_impl_HCP.

  Variable n : nat.

  (* f is a one-way permutation *)
  Variable f : Bvector n -> Bvector n.
  Variable f_inv : Bvector n -> Bvector n.

  Hypothesis f_inv1 : forall v, f (f_inv v) = v.
  Hypothesis f_inv2 : forall v, f_inv (f v) = v.

  Variable A : Bvector (n + n) -> bool -> Comp bool.

  Definition dotProduct(n : nat)(v1 v2 : Bvector n) :=
    Vector.fold_left2 (fun acc b1 b2 => (xorb acc (andb b1 b2))) false v1 v2.

  (* f' is a one-way function for vectors of length n + n *)
  Definition f'(v : Bvector (n + n)) :=
    Vector.append (f (firstPart n n v)) (secondPart n n v).
  Definition b(v : Bvector (n + n)) := (dotProduct (firstPart n n v) (secondPart n n v)).

  Definition OWP_HCP_B(v : Bvector n) : Comp (Bvector n) :=
    ret v.

  Theorem OWP_HCP :
    HCP_Advantage f' b A <= (OWP_Advantage f OWP_HCP_B).

  Abort.

End OWP_impl_HCP.

Section PseudorandomGenerator.

  Variable n1 : nat.
  Variable n2 : nat.
  Variable f : Bvector n1 -> Bvector n2.
  Hypothesis n2_greater : n2 > n1.

  Variable A : Bvector n2 -> Comp bool.

  Definition PRG_G1 :=
    r <-$ {0, 1} ^ n1;
    g <-$ (A (f r));
    ret g.

  Definition PRG_G2 :=
    r <-$ {0, 1} ^ n2;
    g <-$ (A r);
    ret g.

  Definition PRG_Advantage := | (Pr[PRG_G1]) - (Pr[PRG_G2]) |.
End PseudorandomGenerator.

Require Import FCF.DetSem.

Section OWP_HCP_Impl_PRG.

  Variable n : nat.
  Hypothesis n_pos : n > 0.

  (* f is a one-way permutation *)
  Variable f : Bvector n -> Bvector n.
  Variable f_inv : Bvector n -> Bvector n.

  Hypothesis f_inv1 : forall v, f (f_inv v) = v.
  Hypothesis f_inv2 : forall v, f_inv (f v) = v.

  (* b is a hard-core predicate for f *)
  Variable b : Bvector n -> bool.

  Definition OWP_HCP_PRG_fun(v : Bvector n) :=
    (b v) :: (f v).

  (* The PRG distinguisher adversary. *)
  Variable A : Bvector (S n) -> Comp bool.
  Hypothesis wf_A : forall v, well_formed_comp (A v).

  Definition B (v : Bvector n)(b : bool) : Comp bool :=
    (A (b :: v)).

  (* Something equivalent to the following is in the library already, right? *)
  Lemma rnd_concat_eq : forall (v : Bvector (S n)),
    evalDist ({0, 1} ^ (S n)) v ==
    evalDist (rb <-$ {0, 1}; r <-$ {0, 1} ^ n; ret (rb :: r)) v.

    intuition.
    dist_inline_first.
    eapply det_eq_impl_dist_sem_eq; wftac.
    unfold evalDet_equiv.
    intuition.

    inversion H; clear H; subst.
    inversion H0; clear H0; subst.
    simpl in *.
    case_eq (shiftOut s (S n)); intuition.
    rewrite H in H4.
    destruct p.
    inversion H4; clear H4; subst.
    simpl in *.
    inversion H5; clear H5; subst.
    destruct s; simpl in *; try congruence.
    case_eq (shiftOut s n); intuition;
    rewrite H0 in H; try congruence.
    destruct p.
    inversion H; clear H; subst.
    econstructor.
    eapply evalDet_steps_trans.
    eapply evalDet_steps_bind_done.
    econstructor.
    eauto.
    simpl.

    rewrite shiftOut_0.
    econstructor.
    eauto.
    simpl.
    econstructor.
    eapply evalDet_steps_trans.
    eapply evalDet_steps_bind_done.
    econstructor.
    eauto.
    simpl.
    econstructor.
    eapply evalDet_steps_trans.
    eapply evalDet_steps_bind_done.
    econstructor.
    eauto.
    simpl.
    rewrite H0.
    econstructor.
    eauto.
    simpl.
    econstructor.
    econstructor.
    eauto.
    simpl.
    econstructor.

    rewrite H in H4.
    inversion H4; clear H4; subst.

    inversion H0; clear H0; subst.
    simpl in *.
    destruct s; simpl in *.
    econstructor.
    econstructor.
    eauto.
    simpl.
    econstructor.

    case_eq (shiftOut s n); intuition.
    rewrite H in H4.
    destruct p.
    inversion H4; clear H4; subst.
    simpl in *.
    inversion H5; clear H5; subst.
    rewrite H in H4.
    econstructor.
    econstructor.
    eauto.
    simpl.
    rewrite shiftOut_0.
    econstructor.
    eauto.
    simpl.
    econstructor.
    eauto.
    simpl.
    econstructor.
    eauto.
    simpl.
    rewrite H.
    econstructor.

    inversion H; clear H; subst.
    inversion H0; clear H0; subst.
    simpl in *.
    case_eq (shiftOut s 1); intuition;
    rewrite H in H4.
    destruct p.
    inversion H4; clear H4; subst.
    simpl in *.
    inversion H5; clear H5; subst.
    simpl in *.
    inversion H4; clear H4; subst.
    simpl in *.
    case_eq (shiftOut b1 n); intuition;
    rewrite H0 in H5.
    destruct p.
    inversion H5; clear H5; subst.
    simpl in *.
    inversion H6; clear H6; subst.
    simpl in *.
    inversion H5; clear H5; subst.
    econstructor.
    econstructor.
    eauto.
    simpl.
    destruct s; simpl in *; try discriminate.
    rewrite shiftOut_0 in H.
    inversion H; clear H; subst.
    rewrite H0.
    econstructor.
    eauto.
    simpl.
    econstructor.
    inversion H5.
    inversion H4.

    inversion H0; clear H0; subst.
    simpl in *.
    destruct s.
    simpl in *.
    econstructor.
    econstructor.
    eauto.
    simpl.
    econstructor.

    simpl in *.
    rewrite shiftOut_0 in H4.
    inversion H4; clear H4; subst.
    simpl in *.
    inversion H3; clear H3; subst.
    simpl in *.
    inversion H4; clear H4; subst.
    simpl in *.
    case_eq (shiftOut s n); intuition;
    rewrite H in H3.
    destruct p.
    inversion H3; clear H3; subst.
    simpl in *.
    inversion H5; clear H5; subst.
    simpl in *.
    inversion H4.

    econstructor.
    econstructor.
    eauto.
    simpl.
    rewrite H.
    econstructor.
  Qed.

  Theorem OWP_HCP_PRG :
    PRG_Advantage OWP_HCP_PRG_fun A <= (HCP_Advantage f b B).

    unfold OWP_HCP_PRG_fun, PRG_Advantage, PRG_G1, PRG_G2, HCP_Advantage, HCP_G1, HCP_G2, B.

    eapply eqRat_impl_leRat.
    eapply ratDistance_eqRat_compat.
    intuition.

    eapply eqRat_trans.
    eapply evalDist_seq_eq.

    eapply rnd_concat_eq.
    intuition.
    eapply eqRat_refl.

    dist_inline_first.
    comp_skip.
    comp_simp.
    inline_first.

    eapply (distro_iso_eq f f_inv); intuition.
    simpl; eauto using in_getAllBvectors.

    apply uniformity.

    comp_simp.

    intuition.

  Qed.

End OWP_HCP_Impl_PRG.

Print Assumptions OWP_HCP_PRG.


(* https://danilafe.com/blog/coq_palindrome/ *)

From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.

Section Pal.

  Variable X : Type.

  Inductive palindrome : seq X -> Prop :=
  | palindrome_nil : palindrome [::]
  | palindrome_x : forall (x : X), palindrome [:: x]
  | palindrome_xs : forall (x : X) (l : seq X),
      palindrome l -> palindrome (x :: l ++ [:: x]).
  Hint Constructors palindrome.

  Theorem pal_rev (l : seq X) : palindrome l -> l = rev l.
  Proof.
    elim=> //= x l' H IHpalindrome.
    rewrite -cat_cons -cat1s !rev_cat.
      by rewrite -IHpalindrome.
  Qed.

  Inductive seq_alt : seq X -> Prop :=
  | seq_alt_base : seq_alt [::]
  | seq_alt_x : forall (x : X), seq_alt [:: x]
  | seq_alt_xy : forall (x y : X)
                        (l : seq X), seq_alt l -> seq_alt (x :: l ++ [:: y]).
  Hint Constructors seq_alt.

  Lemma seq_alt_cons (x : X) (l : seq X) : seq_alt l -> seq_alt (x::l).
  Proof.
    elim=> //= [y |x' y l' H IHseq_alt].
    - have -> : [:: x ; y] = x :: [::] ++ [:: y] by [].
        by apply: seq_alt_xy.
    - inversion IHseq_alt; subst; clear IHseq_alt; move=> /=.
      + have -> : [:: x; x'; y] = [:: x] ++ [:: x'] ++ [:: y] by [].
          by apply: seq_alt_xy.
      + have -> :
          x' :: (l0 ++ [:: y0]) ++ [:: y] = (x' :: (l0 ++ [:: y0])) ++ [::y] by [].
        by do 2!apply: seq_alt_xy.
  Qed.

  Lemma seq_alt_correct : forall (l : seq X), seq_alt l.
  Proof.
    elim.
    - by apply seq_alt_base.
    - by apply seq_alt_cons.
  Qed.

  Lemma alt_list_ind (P : seq X -> Prop) :
    P [::] ->
    (forall (x : X), P [:: x]) ->
    (forall (l : seq X), P l -> forall (x y : X), P (x :: (l ++ [:: y]))) ->
    forall (ln : seq X), P ln.
  Proof.
    move=> Hb1 Hb2 Hss ln.
    elim: (seq_alt_correct ln) => //= x y l IHl H.
      by apply: Hss.
  Qed.

  Lemma rev_one (x : X) : rev [:: x] = [:: x].
  Proof.
    done.
  Qed.

(*
  Lemma app_injective (l1 l2 s : seq X) : l1 ++ s = l2 ++ s -> l1 = l2.
  Proof.
  Admitted.                                 (*  *)

  (* これは証明できなかったので *)
  Theorem rev_pal' (l : seq X) : l = rev l -> palindrome l.
  Proof.
    elim/alt_list_ind : l => //= l IH x y H.
    rewrite -cat_cons rev_cat /= in H.
    inversion H.                 (* injection H as H1 *)
    (* H1 : x = y *)
    (* H2 : l ++ [:: y] = rev (y :: l) *)
    rewrite -H1 -[x :: l]cat1s rev_cat rev_one in H2.
    rewrite -H1.
    apply: palindrome_xs.
    apply: IH.
    move/(@app_injective l (rev l) [:: x]) in H2. (* XXX *)
    done.
  Abort.
*)

  (* revK (= rev_injective) の特別なかたちとして、次を用意した。 *)
  Lemma rev_injective' (l1 l2 : seq X) : l1 = rev l2 -> rev l1 = l2.
  Proof.
    move=> H.
    rewrite -(revK l2).
      by rewrite -H.
  Qed.

  Theorem rev_pal' (l : seq X) : l = rev l -> palindrome l.
  Proof.
    elim/alt_list_ind : l => //= l IH x y H.
    rewrite -cat_cons rev_cat /= in H.
    (* H : x :: l ++ [:: y] = y :: rev (x :: l) *)
    inversion H.
    (* H1 : x = y *)
    (* H2 : l ++ [:: y] = rev (y :: l) *)

    rewrite -H1.

    rewrite -H1 -[x :: l]cat1s in H2.
    move/rev_injective' in H2.
    rewrite cat1s rev_cat rev_one cat_cons in H2.
    (* H2 : x :: [::] ++ rev l = x :: l *)
    inversion H2.
    (* H3 : revl = l *)

    apply: palindrome_xs.
    rewrite H3.
      by apply: IH.
  Qed.

End Pal.

(* END *)


(* ---------------------------------------------------------------------

   This file is part of a repository containing the definitions and
   proof scripts related to the formalization of context-free language
   theory in Coq. Specifically, the following results were obtained:

   (i) languages square, prime and anbncn are not context-free;
   (ii) context-free languages are not closed under intersection.

   More information can be found in the paper "Some Applications of the
   Formalization of the Pumping Lemma for Context-Free Languages",
   submitted to LSFA 2018 by Marcus Vinícius Midena Ramos, Ruy J. G. B.
   de Queiroz, Nelma Moreira and José Carlos Bacelar Almeida.
   Also, in the thesis "Formalization of
   Context-Free Language Theory", submitted to the Informatics
   Center of the Pernambuco Federal University (CIn/UFPE) in
   Brazil.

   The file README.md describes the contents of each file and
   provides instructions on how to compile them.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

Require Import List.
Require Import Ring.
Require Import Omega.
Require Import NPeano.

Require Import misc_arith.
Require Import misc_list.
Require Import cfg.
Require Import cfl.
Require Import pumping.

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

Import ListNotations.
Open Scope list_scope.

(* --------------------------------------------------------------------- *)
(* PUMPING LEMMA EXAMPLE                                                 *)
(* --------------------------------------------------------------------- *)

Require misc_ssrprime.
Notation is_prime n := (is_true (prime.prime n)).

Section Pumping_Prime.

Inductive terminal: Type:=
| a.

Definition prime_lang: lang terminal:=
fun (s: list terminal) =>
exists i: nat,
is_prime i /\
length s = i.

Fixpoint build (k: nat): list terminal:=
match k with
| 0 => []
| S k => a :: build k
end.

Lemma build_length:
forall k: nat,
length (build k) = k.
Proof.
induction k.
- simpl.
  reflexivity.
- simpl.
  rewrite IHk.
  reflexivity.
Qed.

Lemma sentence_exists:
forall n: nat,
exists w: list terminal,
length w >= n /\ prime_lang w.
Proof.
intros n.
destruct n.
- exists [a;a].
  split.
  + simpl.
    omega.
  + unfold prime_lang.
    exists 2.
    split.
    * simpl.
      auto.
    * simpl.
      reflexivity.
- assert (H1: exists m: nat, m >= S n /\ is_prime m).
    {
    apply (misc_ssrprime.prime_exists n).
    }
  destruct H1 as [m [H1 H2]].
  exists (build m).
  split.
  + rewrite build_length.
    exact H1.
  + unfold prime_lang.
    exists m.
    split.
    * exact H2.
    * rewrite build_length.
      reflexivity.
Qed.

Lemma not_cfl_prime: ~ cfl prime_lang.
Proof.
intros H1.
assert (H2: ~ contains_empty prime_lang).
  {
  unfold contains_empty.
  unfold prime_lang.
  intros H2.
  destruct H2 as [i [H2 H3]].
  simpl in H3.
  rewrite <- H3 in H2.
  simpl in H2.
  generalize (misc_ssrprime.prime_gt0 0 H2); auto.
  }
assert (H3: contains_non_empty prime_lang).
  {
  unfold contains_non_empty.
  exists [a;a].
  unfold prime_lang.
  split.
  - exists 2.
    simpl. auto.
  - intros H3.
    inversion H3.
  }
apply pumping_lemma in H1.
- destruct H1 as [n H1].
  assert (H4: exists (s: list terminal), (length s >= n+2) /\ prime_lang s).
    {
    apply sentence_exists.
    }
  destruct H4 as [s [H4 H5]].
  assert (H6: length s >= n) by omega.
  specialize (H1 s H5 H6).
  destruct H1 as [u [v [w [x [y [H11 [H12 [H13 [H14 H15]]]]]]]]].
  clear H2 H3 H6.
  specialize (H15 (length (u++w++y))).
  unfold prime_lang in H15.
  destruct H15 as [i [H15 H16]].
  rewrite <- H16  in H15.
  clear H16.
  repeat rewrite app_length in H15.
  repeat rewrite iter_length in H15.
  replace (length u + ((length u + (length w + length y)) * length v + (length w + ((length u + (length w + length y)) * length x + length y)))) with
          ((length u + length w + length y) * (1 + (length v + length x))) in H15.
  + rewrite H11 in H4.
    repeat rewrite app_length in H12, H13.
    repeat rewrite app_length in H14.
    repeat rewrite app_length in H4.
    assert (H6: length v + length x <= n) by omega.
    assert (H7: 1 + (length v + length x) >= 2) by omega.
    assert (H8: length u + length w + length y >= 2) by omega.
    apply (misc_ssrprime.mult_primeN _ _ H8 H7); assumption.
  + replace (length u + (length w + length y)) with (length (u++w++y)).
    * rewrite mult_plus_distr_l.
      rewrite mult_1_r.
      {
      replace (length u + length w + length y) with (length (u++w++y)).
      - rewrite mult_plus_distr_l.
        replace (length (u ++ w ++ y)) with (length u + length w + length y) at 1.
        + omega.
        + repeat rewrite app_length.
          rewrite plus_assoc.
          reflexivity.
      - repeat rewrite app_length.
          rewrite plus_assoc.
          reflexivity.
      }
    * repeat rewrite app_length.
      reflexivity.
- split.
  + right.
    exact H2.
  + left.
    exact H3.
Qed.

End Pumping_Prime.


From ZornsLemma Require Export Families.
From ZornsLemma Require Export Image.
From ZornsLemma Require Import ImageImplicit.
From ZornsLemma Require Import FiniteTypes.
From ZornsLemma Require Export EnsemblesTactics.

Set Implicit Arguments.

Section IndexedFamilies.

Variable A T:Type.
Definition IndexedFamily := A -> Ensemble T.
Variable F:IndexedFamily.

Inductive IndexedUnion : Ensemble T :=
  | indexed_union_intro: forall (a:A) (x:T),
    In (F a) x -> In IndexedUnion x.

Inductive IndexedIntersection : Ensemble T :=
  | indexed_intersection_intro: forall (x:T),
    (forall a:A, In (F a) x) -> In IndexedIntersection x.

End IndexedFamilies.

(* unions and intersections over subsets of the index set *)
Lemma sub_indexed_union: forall {A B T:Type} (f:A->B)
  (F:IndexedFamily B T),
  let subF := (fun a:A => F (f a)) in
    Included (IndexedUnion subF) (IndexedUnion F).
Proof.
unfold Included.
intros.
destruct H.
apply indexed_union_intro with (f a).
assumption.
Qed.

Lemma sub_indexed_intersection: forall {A B T:Type} (f:A->B)
  (F:IndexedFamily B T),
  let subF := (fun a:A => F (f a)) in
    Included (IndexedIntersection F) (IndexedIntersection subF).
Proof.
unfold Included.
intros.
constructor.
destruct H.
intro.
apply H.
Qed.

Lemma empty_indexed_intersection: forall {T:Type}
  (F:IndexedFamily False T),
  IndexedIntersection F = Full_set.
Proof.
intros.
apply Extensionality_Ensembles; red; split; red; intros;
  auto with sets.
constructor.
destruct a.
Qed.

Lemma empty_indexed_union: forall {T:Type}
  (F:IndexedFamily False T),
  IndexedUnion F = Empty_set.
Proof.
intros.
apply Extensionality_Ensembles; red; split; red; intros.
- destruct H.
  destruct a.
- destruct H.
Qed.

Lemma finite_indexed_union {A T : Type} {F : IndexedFamily A T} :
  FiniteT A ->
  (forall a, Finite (F a)) ->
  Finite (IndexedUnion F).
Proof.
intro H.
induction H;
  intros.
- replace (IndexedUnion F) with (@Empty_set T).
  + constructor.
  + extensionality_ensembles.
    destruct a.
- replace (IndexedUnion F) with (Union (IndexedUnion (fun t => In (F (Some t)))) (F None)).
  + apply Union_preserves_Finite.
    * apply IHFiniteT.
      intro.
      apply H0.
    * apply H0.
  + extensionality_ensembles.
    * econstructor.
      eassumption.
    * econstructor.
      eassumption.
    * destruct a.
      ** left.
         econstructor.
         eassumption.
      ** now right.
- replace (IndexedUnion F) with (IndexedUnion (fun x => F (f x))).
  + apply IHFiniteT.
    intro.
    apply H1.
  + extensionality_ensembles.
    * econstructor.
      eassumption.
    * destruct H0.
      rewrite <- (H3 a) in H2.
      econstructor.
      eassumption.
Qed.

Lemma Complement_IndexedUnion {A T : Type} {F : IndexedFamily A T} :
  Ensembles.Complement (IndexedUnion F) =
  IndexedIntersection (fun a:A => Ensembles.Complement (F a)).
Proof.
apply Extensionality_Ensembles; split; red; intros.
- constructor. intros.
  red; red; intro.
  contradiction H.
  exists a. assumption.
- destruct H.
  red; red; intro.
  destruct H0.
  contradiction (H a).
Qed.

Lemma Complement_IndexedIntersection {A T : Type} {F : IndexedFamily A T} :
  Ensembles.Complement (IndexedIntersection F) =
  IndexedUnion (fun a:A => Ensembles.Complement (F a)).
Proof.
apply Extensionality_Ensembles; split; red; intros.
- red in H; red in H.
  apply NNPP. intro.
  contradict H.
  constructor. intros.
  apply NNPP. intro.
  contradict H0.
  exists a.
  assumption.
- destruct H.
  red; red; intro.
  apply H.
  destruct H0.
  apply H0.
Qed.

Lemma IndexedIntersection_option_Intersection
      {X A : Type} (V : IndexedFamily (option X) A) :
  IndexedIntersection V =
  Intersection (IndexedIntersection (fun a => V (Some a))) (V None).
Proof.
apply Extensionality_Ensembles; split; red; intros.
- destruct H.
  constructor.
  + constructor. intros. apply H.
  + apply H.
- destruct H. destruct H.
  constructor. intros.
  destruct a; auto.
Qed.

Lemma IndexedIntersection_surj_fn
      {X A B : Type} (V : IndexedFamily A X) (f : B -> A) :
  surjective f ->
  IndexedIntersection V = IndexedIntersection (fun x => V (f x)).
Proof.
intros.
apply Extensionality_Ensembles; split; red; intros.
- destruct H0. constructor. intros. apply H0.
- destruct H0. constructor. intros. destruct (H a).
  subst. apply H0.
Qed.

Lemma image_indexed_union (X Y I : Type) (F : IndexedFamily I X) (f : X -> Y) :
  Im (IndexedUnion F) f = IndexedUnion (fun i => Im (F i) f).
Proof.
apply Extensionality_Ensembles; split; red; intros.
- inversion H; subst; clear H.
  inversion H0; subst; clear H0.
  exists a.
  exists x0.
  all: auto.
- inversion H; subst; clear H.
  inversion H0; subst; clear H0.
  exists x0; [|reflexivity].
  exists a. assumption.
Qed.

Section IndexedFamilyToFamily.

(* relation to families of subsets of T *)
Variable T:Type.
Variable A:Type.
Variable F:IndexedFamily A T.

Definition ImageFamily : Family T :=
  Im Full_set F.

Lemma indexed_to_family_union: IndexedUnion F = FamilyUnion ImageFamily.
Proof.
apply Extensionality_Ensembles.
unfold Same_set.
unfold Included.
intuition.
- destruct H.
  apply family_union_intro with (F a).
  + apply Im_intro with a; auto with sets.
  + assumption.
- destruct H.
  destruct H.
  apply indexed_union_intro with x0.
  rewrite <- H1.
  assumption.
Qed.

Lemma indexed_to_family_intersection:
  IndexedIntersection F = FamilyIntersection ImageFamily.
Proof.
apply Extensionality_Ensembles.
unfold Same_set.
unfold Included.
intuition.
- constructor.
  intros.
  destruct H.
  destruct H0.
  rewrite H1.
  apply H.
- constructor.
  intro.
  destruct H.
  apply H.
  apply Im_intro with a;
    auto with sets.
Qed.

End IndexedFamilyToFamily.


Require Import Nijn.Prelude.Checks.
Require Import Nijn.Prelude.Basics.Lemmas.
Require Import Nijn.Prelude.Relations.WellfoundedRelation.
Require Import Nijn.Prelude.Orders.CompatibleRelation.
Require Import Nijn.Prelude.Orders.MonotonicMaps.
Require Import Lia.

Declare Scope compat.
Open Scope compat.

(** * Exmaples of compatible relations *)

(** The unit type *)
Definition unit_CompatRel : CompatRel
  := {| carrier := unit ;
        gt _ _ := False ;
        ge _ _ := True |}.

(** This relation is well-founded *)
Proposition unit_Wf : Wf (fun (x y : unit_CompatRel) => x > y).
Proof.
  intro z.
  apply acc.
  cbn.
  contradiction.
Qed.

Global Instance unit_isCompatRel : isCompatRel unit_CompatRel.
Proof.
  unshelve esplit ; cbn ; auto ; try (apply _).
Qed.

Definition unit_strict_minimal_element
  : strict_minimal_element unit_CompatRel.
Proof.
  simple refine (make_strict_min_el _ _ _).
  - exact tt.
  - intros y Hx.
    induction y.
    contradiction.
Defined.

Definition unit_minimal_element
  : minimal_element unit_CompatRel
  := is_minimal_to_strict_minimal unit_strict_minimal_element.

(** Product of compatible relations *)
Definition prod_CompatRel
           (X Y : CompatRel)
  : CompatRel
  := {| carrier := X * Y ;
        gt x y := fst x > fst y /\ snd x > snd y ;
        ge x y := fst x >= fst y /\ snd x >= snd y |}.

Notation "X * Y" := (prod_CompatRel X Y) : compat.

(** The product of well-founded orders is again well-founded *)
Definition isWf_pair
           (X Y : CompatRel)
           {x : X} {y : Y}
           (Hx : isWf (@gt X) x)
           (Hy : isWf (@gt Y) y)
  : isWf (@gt _) ((x , y) : prod_CompatRel X Y).
Proof.
  revert Hy.
  revert y.
  induction Hx as [x Hx IHx].
  intros y HY.
  induction HY as [y Hy].
  apply acc.
  intros [z1 z2] [Hz1 Hz2] ; simpl in *.
  apply IHx.
  - assumption.
  - apply Hy.
    assumption.
Qed.

Proposition Wf_prod
            (X Y : CompatRel)
            (HX : Wf (@gt X))
            (HY : Wf (@gt Y))
  : Wf (@gt (X * Y)).
Proof.
  intros x.
  destruct x as [x y].
  apply isWf_pair.
  - apply HX.
  - apply HY.
Qed.

Global Instance prod_isCompatRel
       (X Y : CompatRel)
       `{isCompatRel X}
       `{isCompatRel Y}
  : isCompatRel (X * Y).
Proof.
  unshelve esplit ; cbn ; try (intros ; apply _).
  - intros x y z p q ; split.
    + refine (gt_trans _ _).
      * apply p.
      * apply q.
    + refine (gt_trans _ _).
      * apply p.
      * apply q.
  - intros x y z p q ; split.
    + refine (ge_trans _ _).
      * apply p.
      * apply q.
    + refine (ge_trans _ _).
      * apply p.
      * apply q.
  - intros x ; split ; apply ge_refl.
  - intros x y p ; split ; apply compat ; apply p.
  - intros x y z p q.
    split.
    + refine (ge_gt _ _).
      * apply p.
      * apply q.
    + refine (ge_gt _ _).
      * apply p.
      * apply q.
  - intros x y z p q.
    split.
    + refine (gt_ge _ _).
      * apply p.
      * apply q.
    + refine (gt_ge _ _).
      * apply p.
      * apply q.
Qed.

Definition prod_minimal_element
           {X Y : CompatRel}
           (x : minimal_element X)
           (y : minimal_element Y)
  : minimal_element (X * Y).
Proof.
  simple refine (make_min_el _ _ _).
  - exact (min_el _ x , min_el _ y).
  - intro z.
    split ; cbn.
    + apply is_minimal.
    + apply is_minimal.
Defined.

(** Compatible relations of tuples *)
Definition tuple_CompatRel
          (X : CompatRel)
          (Y : QuasiRel)
  : CompatRel
  := {| carrier := X * Y ;
        gt x y := fst x > fst y /\ (snd x >= snd y)%qr ;
        ge x y := fst x >= fst y /\ (snd x >= snd y)%qr |}.

Global Instance tuple_isCompatRel
              (X : CompatRel)
              `{isCompatRel X}
              (Y : QuasiRel)
              `{isQuasiRel Y}
  : isCompatRel (tuple_CompatRel X Y).
Proof.
  unshelve esplit ; cbn ; try (intros ; apply _).
  - intros x y z [ p1 p2 ] [ q1 q2 ].
    split.
    + exact (gt_trans p1 q1).
    + exact (ge_qr_trans p2 q2).
  - intros x y z [ p1 p2 ] [ q1 q2 ].
    split.
    + exact (ge_trans p1 q1).
    + exact (ge_qr_trans p2 q2).
  - intros x.
    split.
    + apply ge_refl.
    + apply ge_qr_refl.
  - intros x y [ p1 p2 ].
    split.
    + exact (compat p1).
    + exact p2.
  - intros x y z [ p1 p2 ] [ q1 q2 ].
    split.
    + exact (ge_gt p1 q1).
    + exact (ge_qr_trans p2 q2).
  - intros x y z [ p1 p2 ] [ q1 q2 ].
    split.
    + exact (gt_ge p1 q1).
    + exact (ge_qr_trans p2 q2).
Qed.

Definition isWf_pair_tuple
           (X : CompatRel)
           (Y : QuasiRel)
           {x : X} {y : Y}
           (Hx : isWf (@gt X) x)
  : isWf (@gt _) ((x , y) : tuple_CompatRel X Y).
Proof.
  revert y.
  induction Hx as [x Hx IHx].
  intros y.
  apply acc.
  intros [z1 z2] [Hz1 Hz2] ; simpl in *.
  apply IHx.
  assumption.
Qed.

Proposition Wf_tuple
           (X : CompatRel)
           (Y : QuasiRel)
           (HX : Wf (@gt X))
  : Wf (@gt (tuple_CompatRel X Y)).
Proof.
  intros x.
  destruct x as [x y].
  apply isWf_pair_tuple.
  apply HX.
Qed.

(** Dependent product of well-founded relations *)
Definition depprod_CompatRel
           {X : Type}
           (Y : X -> CompatRel)
  : CompatRel
  := {| carrier := (forall (x : X), Y x) ;
        gt f g := forall (x : X), f x > g x ;
        ge f g := forall (x : X), f x >= g x |}.

Notation "∏ Y" := (depprod_CompatRel Y) (at level 10).

Global Instance depprod_isCompatRel
           {X : Type}
           (Y : X -> CompatRel)
           `{forall (x : X), isCompatRel (Y x)}
  : isCompatRel (∏ Y).
Proof.
  unshelve esplit ; cbn ; try (intros ; apply _).
  - intros f g h p q x.
    exact (gt_trans (p x) (q x)).
  - intros f g h p q x.
    exact (ge_trans (p x) (q x)).
  - intros f x.
    exact (ge_refl (f x)).
  - intros f g p x.
    exact (compat (p x)).
  - intros f g h p q x.
    exact (ge_gt (p x) (q x)).
  - intros f g h p q x.
    exact (gt_ge (p x) (q x)).
Qed.

Definition depprod_minimal_element
           {X : Type}
           (Y : X -> CompatRel)
           (y : forall (x : X), minimal_element (Y x))
  : minimal_element (∏ Y).
Proof.
  simple refine (make_min_el _ _ _).
  - exact (fun x => y x).
  - intros z x.
    apply is_minimal.
Defined.

(** The power of well-founded relations *)
Fixpoint power_CompatRel
         (X : CompatRel)
         (n : nat)
  : CompatRel
  := match n with
     | 0 => unit_CompatRel
     | S n => X * power_CompatRel X n
     end.

Notation "X ^ n" := (power_CompatRel X n).

Global Instance power_isCompatRel
       (X : CompatRel)
       (n : nat)
       `{isCompatRel X}
  : isCompatRel (X ^ n).
Proof.
  induction n as [ | n IHn ] ; cbn.
  - apply _.
  - apply _.
Qed.

Definition power_minimal_element
           (X : CompatRel)
           (n : nat)
           (x : minimal_element X)
  : minimal_element (X ^ n).
Proof.
  induction n as [ | n IHn ].
  - apply unit_minimal_element.
  - apply prod_minimal_element.
    + exact x.
    + exact IHn.
Defined.

(** The natural numbers have the structure of well-founded relation *)
Definition nat_CompatRel
  : CompatRel
  := {| carrier := nat ;
        gt n m := n > m ;
        ge n m := n >= m |}%nat.

(** The strict order is well-founded *)
Proposition nat_Wf : Wf (@gt nat_CompatRel).
Proof.
  intro n.
  induction n as [ | n IHn ].
  - apply acc.
    intros ; simpl in *.
    lia.
  - inversion IHn.
    apply acc.
    intros y Hy.
    assert (n > y \/ n = y)%nat as X by (simpl in * ; lia).
    destruct X.
    + apply H.
      assumption.
    + subst.
      exact IHn.
Qed.

Global Instance nat_isCompatRel
  : isCompatRel nat_CompatRel.
Proof.
  unshelve esplit ; cbn ; intros ; try lia ; try (apply _).
Qed.

Definition nat_strict_minimal_element
  : strict_minimal_element nat_CompatRel.
Proof.
  simple refine (make_strict_min_el _ _ _).
  - exact 0.
  - intros n Hn.
    cbn.
    lia.
Defined.

Definition nat_minimal_element
  : minimal_element nat_CompatRel
  := is_minimal_to_strict_minimal nat_strict_minimal_element.

(** Function spaces of weakly monotonic maps *)
Definition fun_CompatRel
           (X Y : CompatRel)
  : CompatRel
  := {| carrier := weakMonotoneMap X Y ;
        gt f g := forall (x : X), f x > g x ;
        ge f g := forall (x : X), f x >= g x  |}.

Notation "X →wm Y" := (fun_CompatRel X Y) (at level 99).

Global Instance fun_isCompatRel
       (X Y : CompatRel)
       `{isCompatRel Y}
  : isCompatRel (X →wm Y).
Proof.
  unshelve esplit ; cbn ; try (intros ; apply _).
  - intros f g h p q x.
    exact (gt_trans (p x) (q x)).
  - intros f g h p q x.
    exact (ge_trans (p x) (q x)).
  - intros f x.
    exact (ge_refl (f x)).
  - intros f g p x.
    exact (compat (p x)).
  - intros f g h p q x.
    exact (ge_gt (p x) (q x)).
  - intros f g h p q x.
    exact (gt_ge (p x) (q x)).
Qed.

(** The function space is well-founded if we can find an element of the domain *)
Proposition fun_Wf
            (X Y : CompatRel)
            (x : X)
            (HY : Wf (fun (x y : Y) => x > y))
  : Wf (fun (f g : fun_CompatRel X Y) => f > g).
Proof.
  simple refine (fiber_Wf HY _ _).
  - exact (fun f => f x).
  - intros f g p ; simpl.
    apply p.
Qed.

(** Function space of strongly monotonic maps *)
Definition strong_fun_CompatRel
           (X Y : CompatRel)
  : CompatRel
  := {| carrier := strongMonotoneMap X Y ;
        gt f g := forall (x : X), f x > g x ;
        ge f g := forall (x : X), f x >= g x  |}.

Notation "X →s Y" := (strong_fun_CompatRel X Y) (at level 99).

Global Instance strong_fun_isCompatRel
       (X Y : CompatRel)
       `{isCompatRel Y}
  : isCompatRel (X →s Y).
Proof.
  unshelve esplit ; cbn ; try (intros ; apply _).
  - intros f g h p q x.
    exact (gt_trans (p x) (q x)).
  - intros f g h p q x.
    exact (ge_trans (p x) (q x)).
  - intros f x.
    exact (ge_refl (f x)).
  - intros f g p x.
    exact (compat (p x)).
  - intros f g h p q x.
    exact (ge_gt (p x) (q x)).
  - intros f g h p q x.
    exact (gt_ge (p x) (q x)).
Qed.

(** The function space is well-founded if we can find an element of the domain *)
Proposition strong_fun_Wf
            (X Y : CompatRel)
            (x : X)
            (HY : Wf (fun (x y : Y) => x > y))
  : Wf (fun (f g : strong_fun_CompatRel X Y) => f > g).
Proof.
  simple refine (fiber_Wf HY _ _).
  - exact (fun f => f x).
  - intros f g p ; simpl.
    apply p.
Qed.

(** * Examples of weakly monotone maps *)

(** The constant functions *)
Global Instance const_weakMonotone
       (X Y : CompatRel)
       `{isCompatRel Y}
       (y : Y)
  : weakMonotone (fun (_ : X) => y).
Proof.
  intros x1 x2 p.
  apply ge_refl.
Qed.

Definition const_wm
           {X Y : CompatRel}
           `{isCompatRel Y}
           (y : Y)
  : X →wm Y
  := make_monotone (fun (_ : X) => y) _.

Definition min_el_fun_space
           {X : CompatRel}
           {Y : CompatRel}
           `{isCompatRel Y}
           (m : minimal_element Y)
  : minimal_element (X →wm Y).
Proof.
  simple refine (make_min_el _ _ _).
  - exact (const_wm m).
  - intros f x.
    apply m.
Defined.

(** The identity function *)
Global Instance id_strictMonotone (X : CompatRel)
  : strictMonotone (@id X).
Proof.
  intros x y p.
  exact p.
Qed.

Global Instance id_weakMonotone (X : CompatRel)
  : weakMonotone (@id X).
Proof.
  intros x y p.
  exact p.
Qed.

Definition id_wm
           {X : CompatRel}
  : X →wm X
  := make_monotone id _.

Definition id_strong_monotone
           {X : CompatRel}
  : X →s X
  := make_strong_monotone id _ _.

(** The composition *)
Global Instance comp_strictMonotone
       {X Y Z : CompatRel}
       (f : X -> Y)
       (g : Y -> Z)
       `{strictMonotone _ _ f}
       `{strictMonotone _ _ g}
  : strictMonotone (g o f).
Proof.
  intros x y p ; cbn.
  do 2 apply map_gt.
  assumption.
Qed.

Global Instance comp_weakMonotone
       {X Y Z : CompatRel}
       (f : X -> Y)
       (g : Y -> Z)
       `{weakMonotone _ _ f}
       `{weakMonotone _ _ g}
  : weakMonotone (g o f).
Proof.
  intros x y p ; cbn.
  do 2 apply map_ge.
  assumption.
Qed.

Definition comp_wm
           {X Y Z : CompatRel}
           (f : X →wm Y)
           (g : Y →wm Z)
  : X →wm Z
  := make_monotone (g o f) _.

Notation "g ∘wm f" := (comp_wm f g) (at level 40).

Definition comp_strong_monotone
           {X Y Z : CompatRel}
           (f : X →s Y)
           (g : Y →s Z)
  : X →s Z
  := make_strong_monotone (g o f) _ _.

(** The first projection *)
Global Instance fst_strictMonotone
       {X Y : CompatRel}
  : @strictMonotone (X * Y) X fst.
Proof.
  intros x y p.
  apply p.
Qed.

Global Instance fst_weakMonotone
       {X Y : CompatRel}
  : @weakMonotone (X * Y) X fst.
Proof.
  intros x y p.
  apply p.
Qed.

Definition fst_wm
           {X Y : CompatRel}
  : X * Y →wm X
  := make_monotone _ _.

Definition fst_strong_monotone
           {X Y : CompatRel}
  : (X * Y) →s X
  := make_strong_monotone _ _ _.

(** The second projection *)
Global Instance snd_strictMonotone
       {X Y : CompatRel}
  : @strictMonotone (X * Y) Y snd.
Proof.
  intros x y p.
  apply p.
Qed.

Global Instance snd_weakMonotone
       {X Y : CompatRel}
  : @weakMonotone (X * Y) Y snd.
Proof.
  intros x y p.
  apply p.
Qed.

Definition snd_wm
           {X Y : CompatRel}
  : X * Y →wm Y
  := make_monotone _ _.

Definition snd_strong_monotone
           {X Y : CompatRel}
  : (X * Y) →s Y
  := make_strong_monotone _ _ _.

(** The pairing of weakly monotone maps *)
Global Instance pair_weakMonotone
       {X Y Z : CompatRel}
       (f : X -> Y)
       (g : X -> Z)
       `{weakMonotone _ _ f}
       `{weakMonotone _ _ g}
  : @weakMonotone X (Y * Z) (fun x => (f x , g x)).
Proof.
  intros x y p.
  split.
  - simpl.
    apply map_ge.
    assumption.
  - simpl.
    apply map_ge.
    assumption.
Qed.

Global Instance pair_strictMonotone
       {X Y Z : CompatRel}
       (f : X -> Y)
       (g : X -> Z)
       `{strictMonotone _ _ f}
       `{strictMonotone _ _ g}
  : @strictMonotone X (Y * Z) (fun x => (f x , g x)).
Proof.
  intros x y p.
  split.
  - simpl.
    apply map_gt.
    assumption.
  - simpl.
    apply map_gt.
    assumption.
Qed.

Definition pair_wm
           {X Y Z : CompatRel}
           (f : X →wm Y)
           (g : X →wm Z)
  : X →wm (Y * Z)
  := @make_monotone X (Y * Z) (fun x => (f x , g x)) _.

Notation "⟨ f , g ⟩" := (pair_wm f g).

Definition pair_strong_monotone
           {X Y Z : CompatRel}
           (f : X →s Y)
           (g : X →s Z)
  : X →s (Y * Z)
  := @make_strong_monotone X (Y * Z) (fun x => (f x , g x)) _ _.

(** Lambda abstraction *)
Global Instance lambda_abs_on_X_monotone
       {X Y Z : CompatRel}
       `{isCompatRel X}
       (f : Y * X →wm Z)
       (x : X)
  : weakMonotone (fun y => f (y , x)).
Proof.
  intros z1 z2 p.
  apply map_ge.
  split.
  - exact p.
  - apply ge_refl.
Qed.

Definition lambda_abs_on_X
           {X Y Z : CompatRel}
           `{isCompatRel X}
           (f : Y * X →wm Z)
           (x : X)
  : Y →wm Z
  := make_monotone (fun y => f (y , x)) _.

Global Instance lambda_abs_mon
       {X Y Z : CompatRel}
       `{isCompatRel X}
       `{isCompatRel Y}
       (f : X * Y →wm Z)
  : weakMonotone (fun x => lambda_abs_on_X f x).
Proof.
  intros x y p z ; cbn.
  apply map_ge.
  split.
  - apply ge_refl.
  - exact p.
Qed.

Definition lambda_abs
            {X Y Z : CompatRel}
            `{isCompatRel X}
            `{isCompatRel Y}
            (f : Y * X →wm Z)
  : X →wm (Y →wm Z)
  := make_monotone (fun x : X => lambda_abs_on_X f x) _.

Notation "'λwm' f" := (lambda_abs f) (at level 10).

(** Addition *)
Global Instance plus_isWeakMonotone
                {A : CompatRel}
                (f g : A -> nat_CompatRel)
                `{Hf : weakMonotone _ _ f}
                `{Hg : weakMonotone _ _ g}
  : weakMonotone (fun a => (f a + g a : nat_CompatRel)).
Proof.
  intros a1 a2 p.
  pose (Hf _ _ p).
  pose (Hg _ _ p).
  cbn in *.
  nia.
Qed.

Definition plus_wm
  : nat_CompatRel * nat_CompatRel →wm nat_CompatRel
  := @make_monotone
       (nat_CompatRel * nat_CompatRel)
       nat_CompatRel
       (fun x => fst x + snd x)
       _.

Global Instance plus_isStrictMonotone
                {A : CompatRel}
                (f g : A -> nat_CompatRel)
                `{Hf : strictMonotone _ _ f}
                `{Hg : strictMonotone _ _ g}
  : strictMonotone (fun a => (f a + g a : nat_CompatRel)).
Proof.
  intros a1 a2 p.
  pose (Hf a1 a2 p).
  pose (Hg a1 a2 p).
  cbn in *.
  nia.
Qed.

Definition plus_fun_wm
           {A : CompatRel}
           (f g : A →wm nat_CompatRel)
  : A →wm nat_CompatRel
  := make_monotone (fun a => (f a + g a : nat_CompatRel)) _.

Definition plus_strong_monotone
           {A : CompatRel}
           (f g : A →s nat_CompatRel)
  : A →s nat_CompatRel
  := make_strong_monotone (fun a => (f a + g a : nat_CompatRel)) _ _.

(** Multiplication *)
Global Instance mult_isWeakMonotone
                {A : CompatRel}
                (f g : weakMonotoneMap A nat_CompatRel)
  : weakMonotone (fun a => (f a * g a : nat_CompatRel)%nat).
Proof.
  intros a1 a2 p.
  pose (is_weak_monotone _ _ f _ _ p).
  pose (is_weak_monotone _ _ g _ _ p).
  cbn in *.
  nia.
Qed.

Definition mult_fun_wm
           {A : CompatRel}
           (f g : weakMonotoneMap A nat_CompatRel)
  : weakMonotoneMap A nat_CompatRel
  := make_monotone (fun a => (f a * g a : nat_CompatRel)%nat) _.

Global Instance app_isWeakMonotone
                {A B C : CompatRel}
                `{isCompatRel C}
                (f : A →wm (B →wm C))
                (x : A →wm B)
  : weakMonotone (fun a : A => f a (x a)).
Proof.
  intros a1 a2 p.
  refine (ge_trans
            (is_weak_monotone _ _ f _ _ p (x a1))
            _).
  exact (is_weak_monotone _ _ (f a2) _ _ (is_weak_monotone _ _ x _ _ p)).
Qed.

(** Application *)
Definition app_wm
           {X Y Z : CompatRel}
           `{isCompatRel Z}
           (f : X →wm (Y →wm Z))
           (x : X →wm Y)
  : X →wm Z
  := make_monotone (fun a => f a (x a)) _.

Notation "f '·wm' x" := (app_wm f x) (at level 20, left associativity).

Global Instance strong_app_isWeakMonotone
                {A B C : CompatRel}
                `{isCompatRel C}
                (f : A →s (B →s C))
                (x : A →s B)
  : weakMonotone (fun a : A => f a (x a)).
Proof.
  intros a1 a2 p.
  refine (ge_trans
            (strong_is_weak _ _ f _ _ p (x a1))
            _).
  exact (strong_is_weak _ _ (f a2) _ _ (strong_is_weak _ _ x _ _ p)).
Qed.

Global Instance strong_app_isStrictMonotone
                {A B C : CompatRel}
                `{isCompatRel C}
                (f : A →s (B →s C))
                (x : A →s B)
  : strictMonotone (fun a : A => f a (x a)).
Proof.
  intros a1 a2 p.
  refine (gt_trans
            (strong_is_strict _ _ f _ _ p (x a1))
            _).
  exact (strong_is_strict _ _ (f a2) _ _ (strong_is_strict _ _ x _ _ p)).
Qed.

Definition app_strong_monotone
           {A B C : CompatRel}
           `{isCompatRel C}
           (f : A →s (B →s C))
           (x : A →s B)
  : A →s C
  := make_strong_monotone (fun a => f a (x a)) _ _.

(** Application to a fixed element *)
Global Instance apply_el_is_weak_monotone
                {A₁ A₂ : CompatRel}
                (x : A₁)
  : @weakMonotone (A₁ →wm A₂) A₂ (fun f => f x).
Proof.
  intros h₁ h₂ p.
  apply p.
Qed.

Definition apply_el_wm
           {X Y : CompatRel}
           (x : X)
  : (X →wm Y) →wm Y
  := @make_monotone
       (X →wm Y)
       Y
       (fun f => f x)
       _.


(** * FFact.v : a faulty factorial function *)
(** Source : Abstraction, refinement and proof for probabilistic systems
    A. McIver and C. Morgan, Springer *)
Add Rec LoadPath "../src" as ALEA.

Require Export Cover.
Require Export Misc.
Require Export DistrTactic.
Require Export Bernoulli.
Require Export Arith.

(* begin hide *)
Set Implicit Arguments.
Open Local Scope U_scope.
Open Local Scope O_scope.

(* end hide *)

(** ** Program trying to compute fact
but with a faulty decreasing function *)
Section Fact.

Variable p : U.
Hypothesis ppos : 0 < p.

(**
<<
let rec ffact n f =
        match n with O => Munit f
                 | S p => if bernoulli p then ffact p (f*n)
                          else ffact (S n) (f*n)
        end
>>*)

Instance Ffact_mon : monotonic
    (fun (df:(nat*nat)-> distr nat) =>
         fun nf : nat*nat =>
           match nf with (O,f) => Munit f
                 | (S m,f) => Mif (bernoulli p) (df (m,f*(S m))%nat)
                                  (df (S (S m),f*(S m))%nat)
           end).
intros df dg H (n,f).
destruct n; auto.
Save.

Definition Ffact : ((nat*nat)-> distr nat) -m> ((nat*nat)-> distr nat)
    := mon  (fun (df:(nat*nat)-> distr nat) =>
         fun nf : nat*nat =>
           match nf with (O,f) => Munit f
                 | (S m,f) => Mif (bernoulli p) (df (m,f*(S m))%nat)
                                  (df (S (S m),f*(S m))%nat)
           end).

Lemma Ffact_simpl : forall df nf,
Ffact df nf = match nf with (O,f) => Munit f
                 | (S m,f) => Mif (bernoulli p) (df (m,f*(S m))%nat)
                                  (df (S (S m),f*(S m))%nat)
              end.
trivial.
Save.

Definition ffact : (nat*nat)-> distr nat := Mfix Ffact.

Instance Ffact_cont : continuous Ffact.
intros fn nf.
rewrite Ffact_simpl.
destruct nf; destruct n; auto.
transitivity ((Ffact @ fn) O (O, n0)).
simpl; auto.
apply (le_lub (Ffact @ fn) O (O, n0)).
setoid_rewrite Mif_lub_eq2;
apply lub_le_compat; intro m; auto.
Save.
Hint Resolve Ffact_cont.

Lemma ffact_eq
  : forall nf, ffact nf == match nf with (O,f) => Munit f
                 | (S m,f) => Mif (bernoulli p) (ffact (m,f*(S m))%nat)
                                  (ffact (S (S m),f*(S m))%nat)
              end.
unfold ffact; intro nf; apply Mfix_eq; auto.
Save.

Lemma fact_Sn_mult_simpl :
forall n f, (fact (S n) * f = fact n * (f * (S n)))%nat.
intros; simpl; ring.
Save.

Lemma ffact_fact :
    forall n f, p ^ n <= mu (ffact (n,f)) (carac_eq (fact n * f)).
induction n; intros.
rewrite ffact_eq.
simpl.
rewrite carac_eq_one; auto.
rewrite ffact_eq.
rewrite Mif_bernoulli_choice.
rewrite Mchoice_simpl.
transitivity
  (p * (mu (ffact (n, (f * S n)%nat))) (carac_eq (fact (S n) * f))).
rewrite (fact_Sn_mult_simpl n f).
rewrite <- (IHn (f * S n)%nat); auto.
auto.
Save.

End Fact.


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

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

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

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

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

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

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Theorem append_nil: forall (l: lst), append l Nil = l.
Proof.
   induction l.
   { simpl. f_equal. assumption. }
   { simpl. reflexivity. }
Qed.

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


(* begin hide *)
Require Import CoList.
Require Import CoTree.
Require Import PArith.
Require Import NArith.
Require Import QArith.
Require Import Recdef.
(* end hide *)

(** * Enumerating The Rationals: The Stern-Brocot Tree *)

(** _Current Status: while the implementation of the tree and the deforestation
    algorithm function perfectly, it is quite hard to prove properties such as the
    equivalence of our euclidian [gcd] and the implementation of the binary [gcd]
    algorithm that Coq's standard library uses_.
  *)

(** The second approach of enumerating the rationals explored in the paper is the
    construction and deforestation of the Stern-Brocot tree, explointing the relation
    between [igcd] and [ungcd] and the usage of [gcd] in the reduction algorithm for
    rational numbers.

    The Stern-Brocot tree maps the execution traces of the Euclidian [gcd] to reduced
    rational numbers. The first few levels of the tree can be seen below.

  #
    <img style="width:100%;" alt="The Stern-Brocot Tree" src="stern_brocot.png" />
  #

    Below we will construct the Stern-Brocot tree, but first we'll prove a few lemmas
    on natural numbers.
  *)

Module SternBrocot.

  (** ** Additional Proofs on Natural Numbers *)
  (** In order to construct the Stern-Brocot tree, we required
      some simple lemmas on the natural numbers [N]. We use these
      lemmas to guarantee that [next] never generates a rational
      number with [0] as a denumerator. See below.
    *)

  Section N_properties.

    Local Open Scope N_scope.

    (** Since we'll be working with natural numbers, we'll want
        to be able to easily convert them to rational numbers.
        The below definitions take care of that.

        Given a proof that [n] is not zero, [N_pos] will allow us to
        safely convert it to a [positive] number.
       *)

    Definition N_pos (n:N) : n<>0 -> positive.
      refine (match n as n' return n'<>0 -> positive with
                | 0      => fun h => _
                | Npos p => fun h => p
              end).
      exfalso; auto.
    Defined.

    (** Since any natural number is also an integer, we can always
        convert members of [N] to members of [Z].
      *)

    Definition N_Z (n:N) : Z :=
      match n with
        | 0      => Z0
        | Npos n => Zpos n
      end.

    (** Furthermore, for the propagation of the nonzero proofs over
        the [next] function below, it is important to know that given
        a nonzero natural [n], we'll need the fact that the sum of [n]
        and some other natural number [m] is also nonzero.
      *)

    Lemma Npos_over_Nplus_l : forall n m : N,
      n <> 0 -> n + m <> 0.
    Proof.
      intros n m H; destruct n as [|n].
      - exfalso; auto.
      - destruct m as [|m]; simpl; discriminate.
    Qed.

    Lemma Npos_over_Nplus_r : forall n m : N,
      m <> 0 -> n + m <> 0.
    Proof.
      intros; rewrite Nplus_comm; apply Npos_over_Nplus_l; assumption.
    Qed.

    Theorem Npos_over_Nplus : forall n m : N,
      n <> 0 \/ m <> 0 -> n + m <> 0.
    Proof.
      intros n m H; elim H; [apply Npos_over_Nplus_l|apply Npos_over_Nplus_r].
    Qed.

  End N_properties.

  (** ** Construction of the Tree *)

  Section enum_def.

    Local Open Scope N_scope.

    (** The main issue with constructing the Stern-Brocot tree is that the [next]
        function passes along "pseudo"-rationals, such as $\frac{1}{0}$#1/0# and
        $\frac{1}{0}$#0/1#. In order to safely be able to construct rationals using
        these pseudo-rationals, we pass along proofs of the fact that the denumerator
        can never be zero.

        We call these pairs of pseudo-rationals [Qpair]s.
      *)

    Inductive Qpair : Type :=
    | qpair (a b c d : N) (HL: a<>0 \/ c<>0) (HR: b<>0 \/ d<>0) : Qpair.

    (** The [next] function that is used to unfold the tree can be seen
        as follows (adapted from the paper), where [Qpair] is shorthand
        for the type [((Integer,Integer),(Integer,Integer))].
<<
    next :: Qpair -> (Qpair,Rational,Qpair)
    next ((m, n), (m', n')) = ((mm', n), mm' / nn', (m, nn'))
      where mm' = m + m'
            nn' = n + n'
>>
        Our translation of this stepper function to Coq can be seen below.
      *)

    Definition next (q:Qpair) : Qpair*Q*Qpair.
      refine (match q with
                | qpair a b c d HL HR =>
                  let ac := a + c in
                  let bd := b + d in
                  let l  := qpair a  b  ac bd _ _ in
                  let r  := qpair ac bd  c  d _ _ in
                  let q  := N_Z ac # N_pos bd _ in
                  (l,q,r)
              end).
      - right; unfold ac; apply Npos_over_Nplus in HL; assumption.
      - right; unfold bd; apply Npos_over_Nplus in HR; assumption.
      - left ; unfold ac; apply Npos_over_Nplus in HL; assumption.
      - left ; unfold bd; apply Npos_over_Nplus in HR; assumption.
      - unfold bd; apply Npos_over_Nplus in HR; assumption.
    Defined.

    (** Finally, we can construct the Stern-Brocot tree and enumeration,
        using the algorithm referred to as [rats4] in the original paper.
<<
    rats4 :: [Rational]
    rats4 = bf (unfold next ((0, 1), (1, 0)))
>>
        Below we first construct the tree, and later in the definition of
        [enum] we deforest this tree to an enumeration using a breadth-first
        traversal.
      *)

    Definition tree : cotree Q.
      refine (CoTree.unfold next (qpair 0 1 1 0 _ _)).
      - right ; discriminate.
      - left  ; discriminate.
    Defined.

    Definition enum : colist Q := CoTree.bf tree.

  End enum_def.

  (** ** Relation with the Greatest Common Divisor *)

  (** The paper initially explores the relation between the paths in the
      Stern-Brocot tree and the execution traces of the Euclidian algorithm
      for calculating the greatest common divisor (or gcd).

      An 'instrumental' version of the [gcd] algorithm is introduced.
<<
    igcd :: (Integer,Integer) -> (Integer,[Bool])
    igcd (m,n) =
      if m<n then step False (igcd (m,n−m)) else
      if m>n then step True  (igcd (m−n,n)) else (m,[ ])
      where step b (d,bs) = (d,b:bs)
>>
      In our implementation we use the [path] datatype for indexing [cotree]s
      instead of binary sequences, as the paper does. Our implementation of
      the [igcd] function and its derivatives [gcd] and [pgcd] can be found below.
    *)

  Section gcd_def.

    Local Open Scope positive_scope.

    (** First, however, we require a few lemmas to prove termination of the
        [igcd] algorithm. We prove its termination based on the decreasing of
        the _sum_ of its arguments, using [pairsum]. *)

    Section igcd_lemma.

      Definition pairsum (p: positive*positive) :=
        match p with
          | (m,n) => Pos.to_nat (m + n)
        end.

      Local Open Scope nat_scope.

      Lemma igcd_lemma1 : forall m n, m<>0 -> n<>0 -> m<n -> (m + (n - m)) < (m + n).
      Proof. intros m n Om On Hlt; omega. Qed.

      Lemma igcd_lemma2 : forall m n, m<>0 -> n<>0 -> (m - n + n) < (m + n).
      Proof. intros m n Om On; omega. Qed.

      Lemma igcd_lemma3 : forall n, Pos.to_nat n <> 0.
      Proof.
        intro n; pose proof (Pos2Nat.is_pos n) as H.
        simpl; apply not_eq_sym,lt_O_neq,Pos2Nat.is_pos.
      Qed.

    End igcd_lemma.

    Definition step (ps: path -> path) (acc: positive*path) :=
      match acc with (d,p0) => (d,ps p0) end.

    Function igcd (p: positive*positive) {measure pairsum p} :=
      match p with (m,n) =>
        if (m <? n) then step CoTree.Left  (igcd (m,(n - m))) else
        if (n <? m) then step CoTree.Right (igcd ((m - n),n)) else
        (m, CoTree.Here)
      end.
    Proof.
      (* prove termination for the first recursive call *)
      intros p m n Hp Hltb.
      pose proof (Pos.ltb_spec m n) as Hlt; destruct Hlt as [Hlt|Hlt].
      pose proof (Pos2Nat.is_pos m) as Om.
      pose proof (Pos2Nat.is_pos n) as On.
      simpl; rewrite 2!Pos2Nat.inj_add, 1!Pos2Nat.inj_sub. apply igcd_lemma1.
      - apply igcd_lemma3.
      - apply igcd_lemma3.
      - apply Pos2Nat.inj_lt; auto.
      - auto.
      - inversion Hltb.

      (* prove termination for the second recursive call *)
      - intros p m n Hp _ Hltb.
        pose proof (Pos.ltb_spec n m) as Hlt; destruct Hlt as [Hlt|Hlt].
        simpl; rewrite 2!Pos2Nat.inj_add; rewrite 1!Pos2Nat.inj_sub. apply igcd_lemma2.
        * apply igcd_lemma3.
        * apply igcd_lemma3.
        * auto.
        * inversion Hltb.
    Defined.

    (** The [gcd] function returns the first result of [igcd], i.e. the gcd. *)

    Definition gcd (x y: positive) := fst (igcd (x,y)).

    (** The [pgcd] function returns the second result of [igcd], i.e. the execution trace. *)

    Definition pgcd (x y: positive) := snd (igcd (x,y)).

    (** We would like to be able to prove equivalence between our Euclidian [gcd]
        algorithm, and the binary [gcd] in the Coq standard libraries, as this would
        allow us to use useful theorems such as [gcd_divide_l] and [gcd_divide_r].
      *)

    Theorem gcd_equiv : forall x y, Pos.gcd x y = gcd x y.
    Admitted.

    (** The [ungcd] algorithm presented in the paper translates effortlessly to Coq.
<<
    ungcd::(Integer,[Bool]) -> (Integer,Integer)
    ungcd (d,bs) = foldr undo (d,d) bs
      where
      undo False (m,n) = (m,n+m)
      undo True  (m,n) = (m+n,n)
>>
        Our translation of the algorithm can be seen below. We have inlined the [undo]
        function, and are using the recursion in our [path] structure instead of the
        [fold] function on binary sequences.
      *)

    Fixpoint ungcd_acc (p: path) (m n: positive) : positive*positive :=
      match p with
        | CoTree.Here    => (m,n)
        | CoTree.Left  p => ungcd_acc p m (n + m)
        | CoTree.Right p => ungcd_acc p (n + m) n
      end.

    Definition ungcd (p: positive*path) : positive*positive :=
      let g := fst p in ungcd_acc (snd p) g g.

    (** Lastly, we have explored a few claims stated in the paper,
        such as the relation between [igcd] and [ungcd].
      *)

    Theorem igcd_ungcd : forall m n, ungcd (igcd (m,n)) = (m,n).
    Proof.
      intros m n.
      induction m as [|m] using Pos.peano_ind.
      - induction n as [|n] using Pos.peano_ind.
        * reflexivity.
    Admitted.

    (** And the claim that all [path]s map to a unqiue rational number. *)

    Theorem ungcd_unique : forall p q,
      ungcd p = ungcd q -> p = q.
    Proof.
      intros p q H.
      case p as [x p].
      case q as [y q].
      induction p as [|p|p].
      - induction q as [|q|q].
        * replace x with y. reflexivity.
          apply (f_equal (@fst positive positive)) in H.
          compute in H.
          symmetry.
          assumption.
        * clear IHq; exfalso.
    Admitted.

    (** And the claim that if two rationals map to the same path, their
        reductions are also equal. *)

    Definition qred (m n: positive) : positive*positive.
    Admitted.

    Theorem pgcd_unique : forall m n m' n',
      pgcd m n = pgcd m' n' -> qred m n = qred m' n'.
    Admitted.

  End gcd_def.

End SternBrocot.