Require Export DFA.

Section Normalization.

Context {State Symbol : Type}.
Hypothesis State_eq_dec : forall (x1 x2:State), { x1 = x2 } + { x1 <> x2 }.
Hypothesis Symbol_eq_dec : forall (x1 x2:Symbol), { x1 = x2 } + { x1 <> x2 }.
Definition NFA := @NFA State Symbol.

Definition Det_state := ListSet State.

Lemma Det_state_eq_dec : forall (x1 x2:Det_state), { x1 = x2 } + { x1 <> x2 }.
Proof.
  apply list_eq_dec, State_eq_dec.
Qed.

(* Normalize the set states of a NFA *)
Fixpoint normalize_nfa (g cp:@NFA.NFA Det_state Symbol) :=
  let normalize_state := fun q => get_set State State_eq_dec q (states cp) in

  match g with
  | state q::g => state (normalize_state q)::normalize_nfa g cp
  | start q::g => start (normalize_state q)::normalize_nfa g cp
  | accept q::g => accept (normalize_state q)::normalize_nfa g cp
  | transition q1 a q2::g => transition (normalize_state q1) a (normalize_state q2)::normalize_nfa g cp
  | x::g => x::normalize_nfa g cp
  | nil => nil
  end.

(* The resulting states *)
Lemma normalize_states g cp q :
  In q (states (normalize_nfa g cp)) ->
  exists q', q = get_set State State_eq_dec q' (states cp) /\
  In q' (states g).
Proof.
  intro H.
  induction g as [|c g IH].
  contradiction.
  assert (forall A (x:A) l, x::l = [x] ++ l).
  simpl; intuition.
  simpl in H; destruct c.
  2: intuition.
  - rewrite H0 in H; apply in_states_app in H.
    destruct H.
    2: apply IH in H; destruct H as [q' H]; exists q'; split; try right; intuition.
    destruct H.
    2: contradiction.
    symmetry in H; exists q0; split; try left; intuition.
  (* same code from above: *)
  - rewrite H0 in H; apply in_states_app in H.
    destruct H.
    2: apply IH in H; destruct H as [q' H]; exists q'; split; try right; intuition.
    destruct H.
    2: contradiction.
    symmetry in H; exists q0; split; try left; intuition.
  (* same code from above: *)
  - rewrite H0 in H; apply in_states_app in H.
    destruct H.
    2: apply IH in H; destruct H as [q' H]; exists q'; split; try right; intuition.
    destruct H.
    2: contradiction.
    symmetry in H; exists q0; split; try left; intuition.
  - rewrite H0 in H; apply in_states_app in H.
    destruct H.
    2: apply IH in H; destruct H as [q' H]; exists q'; split; try right; intuition.
    destruct H.
    symmetry in H; exists q1; split; try left; intuition.
    destruct H.
    2: contradiction.
    symmetry in H; exists q2; split; try (right; left); intuition.
Qed.

(* The resulting start state *)
Lemma normalize_start_states_singleton g cp Q :
  let normalize_state := fun q => get_set State State_eq_dec q (states cp) in

  start_states g = [Q] -> start_states (normalize_nfa g cp) = [normalize_state Q].
Proof.
  intros f H.
  assert (start_states (normalize_nfa g cp) = map f (start_states g)).
  2: rewrite H in H0; intuition.
  clear H.
  induction g as [|c g IH].
  intuition.
  destruct c.
  1,2,4,5: intuition.
  simpl; rewrite IH; intuition.
Qed.

(* The resulting accept states *)
Lemma normalize_accept_states g cp q :
  In q (accept_states (normalize_nfa g cp)) ->
  exists q', q = get_set State State_eq_dec q' (states cp) /\
  In q' (accept_states g).
Proof.
  intro H.
  induction g as [|c g IH].
  contradiction.
  simpl in H; destruct c.
  1-3,5: intuition.
  assert (forall A (x:A) l, x::l = [x] ++ l).
  simpl; intuition.
  rewrite H0 in H.
  apply in_accept_states_app in H.
  destruct H.
  2: apply IH in H; destruct H as [q' H]; exists q'; split; try right; intuition.
  destruct H.
  2: contradiction.
  exists q0; split.
  symmetry; intuition.
  left; intuition.
Qed.

(* The resulting transitions *)
Lemma normalize_states_transitions1 g cp q1 a q2 :
  In (transition q1 a q2) (normalize_nfa g cp) ->
  exists q1' q2', equiv_sets State q1 q1' /\ equiv_sets State q2 q2' /\
  In (transition q1' a q2') g /\ q1 = get_set State State_eq_dec q1' (states cp) /\
  q2 = get_set State State_eq_dec q2' (states cp).
Proof.
  intro H.
  induction g as [|c g IH].
  contradiction.
  simpl in H; destruct c.
  1-4: simpl in H; destruct H; try discriminate; apply IH in H;
  destruct H as [q1' [q2' [H0 [H1 [H2 [H3 H4]]]]]];
  exists q1', q2'; repeat split; try right; intuition; try apply H0; try apply H1.
  destruct H.
  2: apply IH in H; destruct H as [q1' [q2' [H0 [H1 [H2 [H3 H4]]]]]];
  exists q1', q2'; repeat split; try right; intuition; try apply H0; try apply H1.
  injection H; intros; subst; exists q0, q3; split.
  2: split.
  3: split.
  3,4: intuition.
  remember (get_set State State_eq_dec q0 (states cp)) eqn:H0.
  2: remember (get_set State State_eq_dec q3 (states cp)) eqn:H0.
  1,2: symmetry in H0; apply get_set_equiv in H0; apply equiv_sets_comm;
  intuition.
Qed.

Lemma normalize_states_transitions2 g cp q1 a q2 :
  let normalize_state := fun q => get_set State State_eq_dec q (states cp) in

  In (transition q1 a q2) g ->
  In (transition (normalize_state q1) a (normalize_state q2)) (normalize_nfa g cp).
Proof.
  intros f H.
  induction g as [|c g IH].
  contradiction.
  simpl in H; destruct c.
  1-4: destruct H; try discriminate; right; intuition.
  destruct H.
  injection H; intros; subst; left; intuition.
  right; intuition.
Qed.

Lemma normalize_equiv_set_states g cp q1 q2 :
  (subset (ListSet State) (states g) (states cp)) ->
  In q1 (states (normalize_nfa g cp)) ->
  In q2 (states (normalize_nfa g cp)) ->
  equiv_sets State q1 q2 -> q1 = q2.
Proof.
  intros H H0 H1 H2.
  apply normalize_states in H0, H1.
  destruct H0 as [q1' [H0 H3]]; destruct H1 as [q2' [H1 H4]].
  apply H in H3, H4; clear H.
  remember (states cp) as s eqn:H5.
  assert (q1 = get_set State State_eq_dec q1' s).
  rewrite H5; intuition.
  clear H0.
  assert (q2 = get_set State State_eq_dec q2' s).
  rewrite H5; intuition.
  clear H1 H5 cp.
  induction s as [|q s IH].
  contradiction.
  destruct H3, H4; subst.
  intuition.
  1,2: apply get_equiv_sets; intuition.
  simpl; simpl in H2, IH.
  destruct (equiv_sets_dec State State_eq_dec q q1') as [H4|H4];
  destruct (equiv_sets_dec State State_eq_dec q q2') as [H5|H5].
  1,4: intuition.
  - remember (get_set State State_eq_dec q2' s) as q' eqn:H6; symmetry in H6; apply get_set_equiv in H6.
    assert (False).
    2: intuition.
    apply H5.
    apply equiv_sets_trans with q'.
    2: apply equiv_sets_comm.
    1,2: intuition.
  - remember (get_set State State_eq_dec q1' s) as q' eqn:H6; symmetry in H6; apply get_set_equiv in H6.
    assert (False).
    2: intuition.
    apply H4.
    apply equiv_sets_trans with q'.
    1,2: apply equiv_sets_comm; intuition.
Qed.

End Normalization.


From Coq Require Lia.
From Coq Require Import Relations Wellfounded.
Set Implicit Arguments.

Section star.
Unset Implicit Arguments.
Variable A:Type.
Variable R : A -> A -> Prop.
Inductive star (x:A) : A -> Prop :=
| star_refl : star x x
| star_step : forall y, star x y -> forall z, R y z -> star x z
.

Lemma star_trans: forall x y z, star x y -> star y z -> star x z.
Proof.
intros x y z H H1;revert x H;
induction H1.

tauto.
intros.
econstructor 2 with y0;auto.
Qed.

Lemma star_R : forall x y, R x y -> star x y.
Proof.
intros x y H;constructor 2 with x;[constructor|assumption].
Qed.

Lemma star_ind2 : forall  x (P:A -> Prop),
  (P x) ->
  (forall y, P y -> forall z, R y z -> P z) ->
  forall a, star x a -> P a.
Proof.
  intros x P H H0 a H1.
  induction H1.
  exact H.
  apply H0 with (y:=y);assumption.
Qed.

End star.

Ltac prove_star :=
  match goal with
    | |- star _ _ ?t ?t => exact rt_refl
    | H:star _ _ ?t' ?t |- star _ _ ?t' ?t =>  assumption
    | H:star _ _ ?t'' ?t |- star _ _ ?t' ?t =>
      (apply star_trans with t'';[prove_star|exact H]) ||
        (clear H;prove_star)
    | H:star _ _ ?t' ?t'' |- star _ _ ?t' ?t =>
      (apply star_trans with t'';[exact H|prove_star]) ||
        (clear H;prove_star)
    | H:?R ?t' ?t |- star _ _ ?t' ?t =>  apply star_R;exact H
    | H:?R ?t'' ?t |- star _ _ ?t' ?t =>
      (apply star_trans with t'';[prove_star|apply star_R;exact H]) ||
        (clear H;prove_star)
    | H:?R ?t' ?t'' |- star _ _ ?t' ?t =>
      (apply star_trans with t'';[apply star_R;exact H|prove_star]) ||
        (clear H;prove_star)
    | _ => solve [eauto]
  end.


Require Export Coq.Unicode.Utf8.
Require Import Coq.micromega.Lia.

Lemma S_le {n m} : S n ≤ m → exists m', m = S m' ∧ n ≤ m'.
Proof.
  intros le; destruct m; [exfalso|exists m]; lia.
Qed.

Lemma lt_inv_plus {n m} : n < m → exists r, m = n + S r.
Proof.
  induction 1.
  - exists 0; lia.
  - destruct IHle as [r ?]; subst.
    exists (S r); lia.
Qed.

Lemma le_inv_plus {n m} : n ≤ m → exists r, m = n + r.
Proof.
  induction 1.
  - exists 0; lia.
  - destruct IHle as [r ?]; subst.
    exists (S r); lia.
Qed.


From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat. Import Nat.
From Coq Require Import Lia.
From Coq Require Import Lists.List. Import ListNotations.
From Coq Require Import Strings.String.
From LF Require Export Maps.

Module AExp.
  (* Abstract syntax *)
  Inductive aexp : Type :=
  | ANum (n : nat)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp).

  (* Bool expression *)
  Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2 : aexp)
  | BNEq (a1 a2 : aexp)
  | BLe (a1 a2 : aexp)
  | BGt (a1 a2 : aexp)
  | BNot (b : bexp)
  | BOr (b1 b2 : bexp)
  | BAnd (b1 b2 : bexp).

  Fixpoint aeval (a : aexp) : nat :=
    match a with
    | ANum n => n
    | APlus a1 a2 => (aeval a1) + (aeval a2)
    | AMinus a1 a2 => (aeval a1) - (aeval a2)
    | AMult a1 a2 => (aeval a1) * (aeval a2)
    end.

  Example test_aeval :
    aeval (APlus (ANum 2) (ANum 2)) = 4.
  Proof.
    simpl.
    reflexivity.
  Qed.

  Fixpoint beval (b : bexp) : bool :=
    match b with
    | BTrue => true
    | BFalse => false
    | BEq a1 a2 => (aeval a1) =? (aeval a2)
    | BNEq a1 a2 => negb ((aeval a1) =? (aeval a2))
    | BLe a1 a2 => (aeval a1) <=? (aeval a2)
    | BGt a1 a2 => negb ((aeval a1) <=? (aeval a2))
    | BNot b => negb (beval b)
    | BAnd b1 b2 => andb (beval b1) (beval b1)
    | BOr b1 b2 => orb (beval b1) (beval b1)
    end.

  Fixpoint optimize_0plus (a : aexp) : aexp :=
    match a with
    | ANum n => ANum n
    | APlus (ANum 0) a2 => optimize_0plus a2
    (* | APlus a1 (ANum 0) => optimize_0plus a1 *)
    | APlus a1 a2 => APlus (optimize_0plus a1) (optimize_0plus a2)
    | AMinus a1 a2 => AMinus (optimize_0plus a1) (optimize_0plus a2)
    | AMult a1 a2 => AMult (optimize_0plus a1) (optimize_0plus a2)
    end.

  Example test_optimize_0plus :
    optimize_0plus (APlus (ANum 2)
                      (APlus (ANum 0)
                        (APlus (ANum 0) (ANum 1))))
    = APlus (ANum 2) (ANum 1).
  Proof.
    simpl.
    reflexivity.
  Qed.

  Theorem optimize_0plus_sound:
    forall a : aexp, aeval (optimize_0plus a) = aeval a.
  Proof.
    intros a.
    induction a.
    - simpl.
      reflexivity.
    - destruct a1 eqn: E1.
      + destruct n eqn: En.
        * simpl.
          rewrite IHa2.
          reflexivity.
        * simpl.
          rewrite IHa2.
          reflexivity.
      + simpl.
        simpl in IHa1.
        rewrite IHa1.
        rewrite IHa2.
        reflexivity.
      + simpl.
        rewrite IHa2.
        simpl in IHa1.
        rewrite IHa1.
        reflexivity.
      + simpl.
        rewrite IHa2.
        simpl in IHa1.
        rewrite IHa1.
        reflexivity.
    - simpl.
      rewrite IHa1.
      rewrite IHa2.
      reflexivity.
    - simpl.
      rewrite IHa1.
      rewrite IHa2.
      reflexivity.
Qed.

Theorem silly1 :
  forall ae, aeval ae = aeval ae.
Proof.
  try reflexivity.
Qed.

Theorem silly2 :
  forall (P : Prop), P -> P.
Proof.
  intros P H.
  try reflexivity.
  apply H.
Qed.

Lemma foo : forall n, 0 <=? n = true.
Proof.
  intros.
  destruct n.
  - simpl.
    reflexivity.
  - simpl.
    reflexivity.
Qed.

Lemma foo' : forall n, 0 <=? n = true.
Proof.
  intros.
  destruct n;
  simpl;
  reflexivity.
Qed.

Theorem optimize_0plus_sound': forall a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros a.
  induction a;
  try (simpl; rewrite IHa1; rewrite IHa2; reflexivity).
  - reflexivity.
  - destruct a1 eqn: Ea1;
    try (simpl; simpl in IHa1; rewrite IHa1; rewrite IHa2; reflexivity).
    + destruct n eqn : En;
      simpl; rewrite IHa2; reflexivity.
Qed.

Theorem optimize_0plus_sound'': forall a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros a.
  induction a;
  try (simpl; rewrite IHa1; rewrite IHa2; reflexivity).
  try reflexivity.
  - destruct a1;
    try (simpl; simpl in IHa1; rewrite IHa1; rewrite IHa2; reflexivity).
    + destruct n;
      try (simpl; rewrite IHa2; reflexivity).
Qed.

Theorem In10 : In 10 [1;2;3;4;5;6;7;8;9;10].
Proof.
  repeat (try (left; reflexivity); right).
Qed.

Theorem In10' : In 10 [1;2;3;4;5;6;7;8;9;10].
Proof.
  (* left. *)
  right.
  right.
  right.
  right.
  right.
  right.
  right.
  right.
  right.
  left.
  reflexivity.
Qed.

Theorem In10'' : In 10 [1;2;3;4;5;6;7;8;9;10].
Proof.
  repeat simpl.
  repeat (left; reflexivity).
  repeat (right; try (left; reflexivity)).
Qed.

Theorem repeat_loop : forall (m n : nat),
  m + n = n + m.
Proof.
  intros m n.
  (* repeat rewrite Nat.add_comm. *)
  repeat (rewrite Nat.add_comm; reflexivity).
Qed.

Fixpoint optimize_0plus_b (b : bexp) : bexp :=
  match b with
  | BTrue => BTrue
  | BFalse => BFalse
  | BEq a1 a2 => BEq (optimize_0plus a1) (optimize_0plus a2)
  | BNEq a1 a2 => BNEq (optimize_0plus a1) (optimize_0plus a2)
  | BLe a1 a2 => BLe (optimize_0plus a1) (optimize_0plus a2)
  | BGt a1 a2 => BGt (optimize_0plus a1) (optimize_0plus a2)
  | BNot b => BNot (optimize_0plus_b b)
  | BOr b1 b2 => BOr (optimize_0plus_b b1) (optimize_0plus_b b2)
  | BAnd b1 b2 => BAnd (optimize_0plus_b b1) (optimize_0plus_b b2)
  end.

Theorem optimize_0plus_b_sound : forall b,
  beval (optimize_0plus_b b) = beval b.
  Proof.
    intros b.
    induction b;
    simpl;
    repeat reflexivity;
    repeat (rewrite optimize_0plus_sound;
            rewrite optimize_0plus_sound; reflexivity);
    repeat (rewrite IHb; reflexivity);
    repeat (rewrite IHb1; reflexivity).
Qed.

(** TODO
  Design exercise: The optimization implemented by our optimize_0plus
  function is only one of many possible optimizations on arithmetic
  and boolean expressions. Write a more sophisticated optimizer and
  prove it correct. (You will probably find it easiest to start small
  -- add just a single, simple optimization and its correctness proof
  -- and build up incrementally to something more interesting.)
*)

Ltac invert H := inversion H; subst; clear H.

Lemma invert_example1:
  forall {a b c: nat}, [a ;b] = [a;c] -> b = c.
Proof.
  intros.
  invert H.
  reflexivity.
Qed.

Lemma invert_example1':
  forall {a b c: nat}, [a ;b] = [a;c] -> b = c.
Proof.
  intros.
  inversion H. subst. clear H.
  reflexivity.
Qed.

Example silly_presburger_example :
  forall m n o p : nat, m + n <= n + O /\ O + 3 = p + 3 -> m <= p.
Proof.
  intros.
  lia.
Qed.

Example add_comm__lia : forall m n,
    m + n = n + m.
Proof.
  intros.
  lia.
Qed.

Example add_assoc__lia : forall m n p,
    m + (n + p) = m + n + p.
Proof.
  intros.
  lia.
Qed.

Module aevalR_first_try.

  Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum (n : nat) : aevalR (ANum n) n
  | E_APlus (e1 e2 : aexp) (n1 n2 : nat) :
    aevalR e1 n1 -> aevalR e2 n2 -> aevalR (APlus e1 e2) (n1 + n2)
  | E_AMinus (e1 e2 : aexp) (n1 n2 : nat) :
    aevalR e1 n1 -> aevalR e2 n2 -> aevalR (AMinus e1 e2) (n1 - n2)
  | E_AMult (e1 e2 : aexp) (n1 n2 : nat) :
    aevalR e1 n1 -> aevalR e2 n2 -> aevalR (AMult e1 e2) (n1 * n2).

  Module HypothesisNames.
    Inductive aevalR : aexp -> nat -> Prop :=
    | E_ANum (n : nat) : aevalR (ANum n) n
    | E_APlus (e1 e2 : aexp) (n1 n2 : nat)
      (H1 : aevalR e1 n1) (H2 : aevalR e2 n2) :
      aevalR (APlus e1 e2) (n1 + n2)
    | E_AMinus (e1 e2 : aexp) (n1 n2 : nat)
      (H1 : aevalR e1 n1) (H2 : aevalR e2 n2) :
      aevalR (AMinus e1 e2) (n1 - n2)
    | E_AMult (e1 e2 : aexp) (n1 n2 : nat)
      (H1 : aevalR e1 n1) (H2 : aevalR e2 n2) :
      aevalR (AMult e1 e2) (n1 * n2).
  End HypothesisNames.

  Notation "e '==>' n" :=
    (aevalR e n)
    (at level 90, left associativity)
    : type_scope.

End aevalR_first_try.

Reserved Notation "e '==>' n"
  (at level 90, left associativity).

Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum (n : nat) : (ANum n) ==> n
  | E_APlus (e1 e2 : aexp) (n1 n2 : nat) :
    (e1 ==> n1) -> (e2 ==> n2) ->
    (APlus e1 e2) ==> (n1 + n2)
  | E_AMinus (e1 e2 : aexp) (n1 n2 : nat) :
    (e1 ==> n1) -> (e2 ==> n2) ->
    (AMinus e1 e2) ==> (n1 - n2)
  | E_AMult (e1 e2 : aexp) (n1 n2 : nat) :
    (e1 ==> n1) -> (e2 ==> n2) ->
    (AMult e1 e2) ==> (n1 * n2)
  where "e '==>' n" := (aevalR e n) : type_scope.

  Theorem aeval_iff_aevalR :
    forall a n, (a ==> n) <-> aeval a = n.
  Proof.
    intros a n.
    split.
    - intros H.
      induction H; simpl;
      (try rewrite IHaevalR1; try rewrite IHaevalR2; reflexivity).
    - intros H.
      generalize dependent n.
      induction a; simpl; intros; subst.
      + apply E_ANum.
      + apply E_APlus.
        apply IHa1. reflexivity.
        apply IHa2. reflexivity.
      + apply E_AMinus.
        apply IHa1. reflexivity.
        apply IHa2. reflexivity.
      + apply E_AMult.
        apply IHa1. reflexivity.
        apply IHa2. reflexivity.
  Qed.

  Theorem aeval_iff_aevalR' :
    forall a n, (a ==> n) <-> aeval a = n.
  Proof.
    split.
    - intros H.
      induction H; subst; reflexivity.
    - generalize dependent n.
      induction a; simpl; intros; subst; constructor;
      try apply IHa1; try apply IHa2; reflexivity.
  Qed.

  Reserved Notation "e '==>b' b" (at level 90, left associativity).

  Inductive bevalR : bexp -> bool -> Prop :=
    | E_BTrue : BTrue ==>b true
    | E_BFalse : BFalse ==>b false
    | E_BEq (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 ==> n1) -> (a2 ==> n2) ->
      BEq a1 a2 ==>b (n1 =? n2)
    | E_BNeq (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 ==> n1) -> (a2 ==> n2) ->
      BNEq a1 a2 ==>b negb (n1 =? n2)
    | E_BLe (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 ==> n1) -> (a2 ==> n2) ->
      BLe a1 a2 ==>b (n1 <=? n2)
    | E_BGt (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 ==> n1) -> (a2 ==> n2) ->
      BGt a1 a2 ==>b negb (n1 <=? n2)
    | E_BNot (e : bexp) (b : bool) :
      (e ==>b b) ->
      BNot e ==>b negb b
    | E_BAnd (e1 e2 : bexp) (b1 b2 : bool) :
      (e1 ==>b b1) -> (e2 ==>b b2) ->
      BAnd e1 e2 ==>b andb b1 b2
    | E_BOr (e1 e2 : bexp) (b1 b2 : bool) :
      (e1 ==>b b1) -> (e2 ==>b b2) ->
      BOr e1 e2 ==>b orb b1 b2
    where "e '==>b' b" := (bevalR e b) : type_scope.

  Lemma beval_iff_bevalR :
    forall b bv, b ==>b bv <-> beval b = bv.
  Proof.
  Admitted.

End AExp.

Module aevalR_division.
  Inductive aexp : Type :=
  | ANum (n : nat)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp)
  | ADiv (a1 a2 : aexp).

  Reserved Notation "e '==>' n"
    (at level 90, left associativity).

    Inductive aevalR : aexp -> nat -> Prop :=
    | E_ANum (n : nat) :
      (ANum n) ==> n
    | E_APlus (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 ==> n1) -> (a2 ==> n2) ->
      (APlus a1 a2) ==> (n1 + n2)
    | E_AMinus (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 ==> n1) -> (a2 ==> n2) ->
      (AMinus a1 a2) ==> (n1 - n2)
    | E_AMult (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 ==> n1) -> (a2 ==> n2) ->
      (AMult a1 a2) ==> (n1 * n2)
    | E_ADiv (a1 a2 : aexp) (n1 n2 n3 : nat) :
      (a1 ==> n1) -> (a2 ==> n2) -> (n2 > 0) ->
      (mult n2 n3 = n1) ->
      (ADiv a1 a2) ==> n3
    where "e '==>' n" := (aevalR e n) : type_scope.
End aevalR_division.

Module aevalR_extended.
  Reserved Notation "e '==>' n" (at level 90, left associativity).

  Inductive aexp : Type :=
  | AAny
  | ANum (n : nat)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp).

  Inductive aevalR : aexp -> nat -> Prop :=
  | E_AAny (n : nat) :
    AAny ==> n
  | E_ANum (n : nat) :
    (ANum n) ==> n
  | E_APlus (a1 a2 : aexp) (n1 n2 : nat) :
    (a1 ==> n1) -> (a2 ==> n2) ->
    (APlus a1 a2) ==> (n1 + n2)
  | E_AMinus (a1 a2 : aexp) (n1 n2 : nat) :
    (a1 ==> n1) -> (a2 ==> n2) ->
    (AMinus a1 a2) ==> (n1 - n2)
  | E_AMult (a1 a2 : aexp) (n1 n2 : nat) :
    (a1 ==> n1) -> (a2 ==> n2) ->
    (AMult a1 a2) ==> (n2 * n2)
  where "e '==>' n" := (aevalR e n) : type_scope.

End aevalR_extended.

Definition state := total_map nat.

Inductive aexp : Type :=
| ANum (n : nat)
| AId (x : string)
| APlus (a1 a2 : aexp)
| AMinus (a1 a2 : aexp)
| AMult (a1 a2 : aexp).

Definition W : string := "W".
Definition X : string := "X".
Definition Y : string := "Y".
Definition Z : string := "Z".

Inductive bexp : Type :=
| BTrue
| BFalse
| BEq (a1 a2 : aexp)
| BNEq (a1 a2 : aexp)
| BLe (a1 a2 : aexp)
| BGt (a1 a2 : aexp)
| BNot (b : bexp)
| BOr (b1 b2 : bexp)
| BAnd (b1 b2 : bexp).

Coercion AId : string >-> aexp.
Coercion ANum : nat >-> aexp.

Declare Custom Entry com.
Declare Scope com_scope.

Notation "<{ e }>" :=
  (e)
  (at level 0, e custom com at level 99)
  : com_scope.
Notation "( x )" :=
  (x)
  (in custom com, x at level 99)
  : com_scope.
Notation "x" :=
  (x)
  (in custom com at level 0, x constr at level 0)
  : com_scope.
Notation "f x .. y" :=
  (.. (f x) .. y)
  (in custom com at level 0, only parsing,
   f constr at level 0, x constr at level 9,
   y constr at level 9)
  : com_scope.
Notation "x + y" :=
  (APlus x y)
  (in custom com at level 50, left associativity).
Notation "x - y" :=
  (AMinus x y)
  (in custom com at level 50, left associativity).
Notation "x * y" :=
  (AMult x y)
  (in custom com at level 40, left associativity).
Notation "'true'" :=
  (true)
  (at level 1).
Notation "'false'" :=
  (false)
  (at level 1).
Notation "'true'" :=
  (BTrue)
  (in custom com at level 1).
Notation "'false'" :=
  (BFalse)
  (in custom com at level 1).
Notation "x <= y" :=
  (BLe x y)
  (in custom com at level 70, no associativity).
Notation "x > y" :=
  (BGt x y)
  (in custom com at level 70, no associativity).
Notation "x = y" :=
  (BEq x y)
  (in custom com at level 70, no associativity).
Notation "x <> y" :=
  (BNEq x y)
  (in custom com at level 70, no associativity).
Notation "x '&&' y" :=
  (BAnd x y)
  (in custom com at level 80, left associativity).
Notation "x '||' y" :=
  (BOr x y)
  (in custom com at level 80, left associativity).
Notation "'~' y" :=
  (BNot y)
  (in custom com at level 75, right associativity).

Open Scope com_scope.

Definition example_aexp : aexp := <{ 3 + (X * 2) }>.
Definition example_bexp : bexp := <{ true && ~(X <= 4)}>.

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x
  | <{a1 + a2}> => (aeval st a1) + (aeval st a2)
  | <{a1 - a2}> => (aeval st a1) - (aeval st a2)
  | <{a1 * a2}> => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue => true
  | BFalse => false
  | <{ a1 = a2}> => (aeval st a1) =? (aeval st a2)
  | <{ a1 <> a2}> => negb ((aeval st a1) =? (aeval st a2))
  | <{ a1 <= a2}> => (aeval st a1) <=? (aeval st a2)
  | <{ a1 > a2}> => negb ((aeval st a1) <=? (aeval st a2))
  | <{ ~b }> => negb (beval st b)
  | <{b1 && b2}> => andb (beval st b1) (beval st b2)
  | <{b1 || b2}> => orb (beval st b1) (beval st b2)
  end.

Definition empty_st := (_ !-> 0).

Notation "x '!->' v" := (x !-> v; empty_st) (at level 100).

Example aexp1 :
  aeval (X !-> 5) <{3 + (X * 2)}> = 13.
Proof.
  reflexivity.
Qed.

Example aexp2 :
    aeval (X !-> 5 ; Y !-> 4) <{ Z + (X * Y) }>
  = 20.
Proof.
  reflexivity.
Qed.

Example bexp1 :
    beval (X !-> 5) <{ true && ~(X <= 4) }>
  = true.
Proof.
  reflexivity.
Qed.

Inductive com : Type :=
| CSkip
| CAsgn (x : string) (a : aexp)
| CSeq (c1 c2 : com)
| CIf (b : bexp) (c1 c2 : com)
| CWhile (b : bexp) (c : com).

Notation "'skip'" :=
  (CSkip)
  (in custom com at level 0)
  : com_scope.
Notation "x ':=' y" :=
  (CAsgn x y)
  (in custom com at level 0, x constr at level 0,
   y at level 85, no associativity)
  : com_scope.
Notation "x ';' y" :=
  (CSeq x y)
  (in custom com at level 90, right associativity)
  : com_scope.
Notation "'if' x 'then' y 'else' z 'end'" :=
  (CIf x y z)
  (in custom com at level 89, x at level 99,
   y at level 99, z at level 99)
  : com_scope.
Notation "'while' x 'do' y 'end'" :=
  (CWhile x y)
  (in custom com at level 89, x at level 99, y at level 99)
  : com_scope.

Definition fact_in_coq : com :=
  <{
    Z := X;
    Y := 1;
    while Z <> 0 do
      Y := Y * Z;
      Z := Z - 1
    end
  }>.

Print fact_in_coq.

Unset Printing Notations.
Print fact_in_coq.
Set Printing Notations.

Print example_bexp.
Set Printing Coercions.
Print example_bexp.
Print fact_in_coq.
Unset Printing Coercions.

Locate aexp.
Locate "&&".
Locate "||".
Locate ";".
Locate "while".

Definition plus2 : com :=
  <{ X := X + 2 }>.

Definition XtimesYinZ : com :=
  <{ Z := X * Y }>.

Definition substract_slowly_body : com :=
  <{
    Z := Z - 1;
    X := X -1
  }>.

Definition substract_slowly : com :=
  <{
    while X <> 0 do
      substract_slowly_body
    end
  }>.

Definition substract_3_from_5_slowly : com :=
  <{
    X := 3;
    Z := 5;
    substract_slowly
  }>.

Definition loop : com :=
  <{
    while true do
      skip
    end
  }>.

Fixpoint ceval_fun_not_while (st : state) (c : com) : state :=
  match c with
  | <{ skip }>
    => st
  | <{ x := a }>
    => (x !-> (aeval st a); st)
  | <{ c1 ; c2 }>
    => let st' := ceval_fun_not_while st c1 in
       ceval_fun_not_while st' c2
  | <{ if b then c1 else c2 end }>
    => if (beval st b) then ceval_fun_not_while st c1
       else ceval_fun_not_while st c2
  | <{ while b do c end }>
    => st (* TODO *)
  end.

Reserved Notation "st '=[' c ']=>' st'"
  (at level 40, c custom com at level 99,
   st constr, st' constr at next level).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st, st =[ skip ]=> st
  | E_Asgn : forall st a n x,
             aeval st a = n ->
             st =[ x := a ]=> (x !-> n; st)
  | E_Seq : forall st st' st'' c1 c2,
             st =[ c1 ]=> st' ->
             st' =[ c2 ]=> st'' ->
             st =[c1 ; c2]=> st''
  | E_IfTrue : forall st st' b c1 c2,
             beval st b = true ->
             st =[ c1 ]=> st' ->
             st =[if b then c1 else c2 end]=> st'
  | E_IfFalse : forall st st' b c1 c2,
             beval st b = false ->
             st =[ c2 ]=> st' ->
             st =[if b then c1 else c2 end]=> st'
  | E_WhileFalse : forall st b c,
             beval st b = false ->
             st =[while b do c end]=> st
  | E_WhileTrue : forall st st' st'' b c,
             beval st b = true ->
             st =[ c ]=> st' ->
             st' =[while b do c end]=> st'' ->
             st =[while b do c end]=> st''
  where "st '=[' c ']=>' st'" := (ceval c st st').

Example ceval_example1 :
  empty_st =[
    X := 2;
    if (X <= 1) then Y := 3
    else Z := 4
    end
  ]=> (Z !-> 4; X !-> 2).
Proof.
  apply E_Seq with (X !-> 2). (* The intermidiate state *)
  - apply E_Asgn.
    reflexivity.
  - apply E_IfFalse.
    reflexivity.
    apply E_Asgn.
    reflexivity.
Qed.

Example ceval_example2:
  empty_st =[
    X := 0;
    Y := 1;
    Z := 2
  ]=> (Z !-> 2 ; Y !-> 1 ; X !-> 0).
Proof.
  apply E_Seq with (X !-> 0).
  - apply E_Asgn.
    reflexivity.
  - apply E_Seq with (Y !-> 1; X !-> 0).
    + apply E_Asgn.
      reflexivity.
    + apply E_Asgn.
      reflexivity.
Qed.

Set Printing Implicit.
Check @ceval_example2.

Definition pup_to_n : com :=
  <{
    Y := 0;
    while X <> 0 do
      Y := Y + X;
      X := X - 1
    end
  }>.

Theorem pup_to_2_ceval :
  (X !-> 2) =[
    pup_to_n
  ]=> (X !-> 0 ; Y !-> 3 ; X !-> 1 ; Y !-> 2 ; Y !-> 0 ; X !-> 2).
Proof.
  unfold pup_to_n.
  apply E_Seq with (Y !-> 0 ; X !-> 2).
  - apply E_Asgn.
    reflexivity.
  - apply E_WhileTrue with (X !-> 1 ;Y !-> 2; Y !-> 0; X !-> 2).
    + reflexivity.
    + apply E_Seq with (Y !-> 2; Y !-> 0; X !-> 2).
      * apply E_Asgn.
        reflexivity.
      * apply E_Asgn.
        reflexivity.
    + apply E_WhileTrue with (X !-> 0 ;Y !-> 3 ;X !-> 1 ;Y !-> 2; Y !-> 0; X !-> 2).
      * reflexivity.
      * apply E_Seq with (Y !-> 3 ;X !-> 1 ;Y !-> 2; Y !-> 0; X !-> 2).
        ** apply E_Asgn.
           reflexivity.
        ** apply E_Asgn.
           reflexivity.
      * apply E_WhileFalse.
        reflexivity.
Qed.

Theorem ceval_deterministic: forall c st st1 st2,
     st =[ c ]=> st1 ->
     st =[ c ]=> st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2.
  induction E1; intros st2 E2; inversion E2; subst.
  - reflexivity.
  - reflexivity.
  - rewrite (IHE1_1 st'0 H1) in *.
    apply IHE1_2.
    assumption.
  - apply IHE1.
    assumption.
  - apply IHE1.
    rewrite H in H5.
    discriminate.
  - apply IHE1.
    rewrite H in H5.
    discriminate.
  - apply IHE1.
    apply H6.
  - reflexivity.
  - rewrite H in H2.
    discriminate.
  - rewrite H in H4.
    discriminate.
  - rewrite (IHE1_1 st'0 H3) in *.
    apply IHE1_2.
    assumption.
Qed.

Theorem plus2_spec : forall st n st',
  st X = n ->
  st =[ plus2 ]=> st' ->
  st' X = n + 2.
Proof.
  intros.
  inversion H0.
  subst.
  simpl.
  apply t_update_eq.
Qed.

Module StackMachine.
  Inductive sinstr : Type :=
  | SPush (n : nat)
  | SLoad (x : string)
  | SPlus
  | SMinus
  | SMult.

  Fixpoint s_execute (st : state) (stack : list nat) (prog : list sinstr)
          : list nat :=
  match prog with
  | [] => stack
  | (SPush n) :: prog' => s_execute st (n :: stack) prog'
  | (SLoad x) :: prog' => s_execute st ((st x) :: stack) prog'
  | SPlus :: prog' =>
    let stack'' := match stack with
    | [] => []
    | [a] => [a]
    | a :: b :: stack' => (a + b) :: stack'
    end in
    s_execute st stack'' prog'
  | SMinus :: prog' =>
    let stack'' := match stack with
    | [] => []
    | [a] => [a]
    | a :: b :: stack' => (b - a) :: stack'
    end in
    s_execute st stack'' prog'
  | SMult :: prog' =>
    let stack'' := match stack with
    | [] => []
    | [a] => [a]
    | a :: b :: stack' => (a * b) :: stack'
    end in
    s_execute st stack'' prog'
  end.

  Check s_execute.

  Example s_execute1 :
    s_execute empty_st []
    [SPush 5; SPush 3; SPush 1; SMinus]
    = [2; 5].
  Proof.
    simpl.
    reflexivity.
  Qed.

  Example s_execute2 :
    s_execute (X !-> 3) [3;4]
    [SPush 4; SLoad X; SMult; SPlus]
    = [15; 4].
  Proof.
    simpl.
    reflexivity.
  Qed.

  Fixpoint s_compile (e : aexp) : list sinstr :=
    match e with
    | ANum n => [SPush n]
    | AId x => [SLoad x]
    | <{ a1 + a2}> =>
      (s_compile a1) ++ (s_compile a2) ++ [SPlus]
    | <{ a1 - a2 }> =>
      (s_compile a1) ++ (s_compile a2) ++ [SMinus]
    | <{ a1 * a2 }> =>
      (s_compile a1) ++ (s_compile a2) ++ [SMult]
    end.

  Example s_compile1 :
    s_compile <{ X - (2 * Y) }>
    = [SLoad X; SPush 2; SLoad Y; SMult; SMinus].
  Proof.
    simpl.
    reflexivity.
  Qed.

  Lemma s_compile_correct_aux : forall st e stack,
    s_execute st stack (s_compile e) = aeval st e :: stack.
  Proof.
    intros st e.
    induction e.
    - simpl.
      reflexivity.
    - simpl.
      reflexivity.
    - intros stack.
      simpl.
  Admitted.

  Theorem s_compile_correct : forall (st : state) (e : aexp),
    s_execute st [] (s_compile e) = [ aeval st e ].
  Proof.
  Admitted.

End StackMachine.

Module BreakImp.

  Inductive com : Type :=
  | CSKip
  | CBreak
  | CAsgn (x : string) (a : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CWhile (b : bexp) (c : com).

  Notation "'break'" :=
    (CBreak)
    (in custom com at level 0)
    : com_scope.
  Notation "'skip'" :=
    (CSkip)
    (in custom com at level 0)
    : com_scope.
  Notation "x ':=' y" :=
    (CAsgn x y)
    (in custom com at level 0, x constr at level 0,
     y at level 85, no associativity)
    : com_scope.
  Notation "x ; y" :=
    (CSeq x y)
    (in custom com at level 90, right associativity)
    : com_scope.
  Notation "'if' x 'then' y 'else' z 'end'" :=
    (CIf x y z)
    (in custom com at level 89, x at level 99,
     y at level 99, z at level 99)
    : com_scope.
  Notation "'while' x 'do' y 'end'" :=
    (CWhile x y)
    (in custom com at level 89,
     x at level 99, y at level 99)
    : com_scope.

  Inductive result : Type :=
  | SContinue
  | SBreak.

  Reserved Notation "st '=[' c ']=>' st' '/' s"
    (at level 40, c custom com at level 99,
     st' constr at next level).

  Inductive ceval : com -> state -> result -> state -> Prop :=
    | E_Skip : forall st,
      st =[ CSKip ]=> st / SContinue
    where "st '=[' c ']=>' st' '/' s" := (ceval c st s st').

End BreakImp.


From mathcomp Require Import all_ssreflect.
Require Import ssromega.
Require Import Recdef.                      (* Function *)
Require Import Wf_nat.                      (* wf *)
Require Import Program.Wf.                  (* Program wf *)
(* Import Program とすると、リストなど余計なものがついてくるので、Wfだけにする。 *)

Require Import Extraction.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(* Set Print All. *)

(**
# 連分数 Continued fraction

有限単純連分数 または 有限正則連分数 (finite regular continued fraction)
これは、分子が全て 1 の連分数で、有限回で表現できるもの。有理数を表す。

また、ここでは、正数のみ考えるが、1以上であってもよい。
 *)
Section CF.

(**
## （正の）有理数と有限正則連分数 の相互変換

-（正の）有理数は、自然数のpairで表現する。既約である必要はない。
- 有限正則連分数は、自然数のリストで表現する。
*)

(**
### 正則連分数から有理数

得られた有理数は、結果として既約になる。ただし証明が必要。
*)
  Fixpoint cf2f (sa : seq nat)  : (nat * nat) :=
    match sa with
    | a :: sa' =>
      (a * (cf2f sa').1 + (cf2f sa').2, (cf2f sa').1)
    (* let (p1, p2) := cf2f sa' in (a * p1 + p2, p1) *)
    | [::] => (1, 0)
    end.

  Compute cf2f [:: 3; 3; 1; 2].             (* (36, 11) *)
  Compute cf2f [:: 0; 1; 1; 1; 1; 1; 1].
  Compute cf2f [:: 1; 2; 2; 2; 2; 2; 2].

(**
### 有理数から正則連分数
*)
  Program Fixpoint f2cf'p (n d : nat) {wf lt d} : (seq nat) := (* notu *)
    match d with
    | 0 => [::]
    | _ => (n %/ d) :: f2cf'p d (n %% d)
    end.
  Obligation 1.
  Proof.
    apply/ltP/ltn_pmod.
    move/Lt.neq_0_lt in H.
    apply/ltP/H.
  Qed.
  Compute f2cf'p 36 11.                     (* [:: 3; 3; 1; 2] *)

  Function f2cf' (n d : nat) {wf lt d} : (seq nat) :=
    match d with
    | 0 => [::]
    | _ => (n %/ d) :: f2cf' d (n %% d)
    end.
  Proof.
    - move=> n d d0 _.
      apply/ltP.
        by rewrite ltn_mod.
    - by apply: lt_wf.
  Defined.                                (* Defined が必要である。 *)
(**
- Coq は停止性が判定できないので、Function コマンドを使う。
第2引数（分母側）が、割り算の余りを求めることによって小さくなることを示す。

- Function コマンドにより、カスタムインダクションが可能になる
(functional inducntion タクティクが使えるようになる）。

- Function コマンドにより、不動点を示す等式 f2cf'_equation が定義される。
 *)

  Definition f2cf (p : (nat * nat)) : (seq nat) := f2cf' p.1 p.2.
  Compute f2cf (36, 11).                    (* = [:: 3; 3; 1; 2] *)

  Compute cf2f (f2cf (36, 11)).             (* (36, 11) *)
  Compute cf2f (f2cf (72, 22)).             (* (36, 11) *)

(**
## 有理数→正則連分数→有理数 の変換
*)
  Goal forall p, cf2f (f2cf p) = p.
  Proof.
    case=> n d.
    functional induction (f2cf' n d).
    - rewrite /=.
      (* (1, 0) = (n, 0) .... p は既約になるので。 *)
      admit.
    - case: d y IHl => [H IHl | d H IHl].
      + done.
      + admit.
(**
  IHl : cf2f (f2cf (d.+1, n %% d.+1)) = (d.+1, n %% d.+1)
  ============================
  cf2f (f2cf (n, d.+1)) = (n, d.+1)
 *)
  Admitted.                                 (* OK *)

(**
## 正則連分数→有理数→正則連分数 の変換

cf2f (f2cf p) = p は証明できない（pが約分される）ので、
f2cf (cf2f s) = s を証明する。
*)
  Lemma f2cfE (n d : nat) : d != 0 -> f2cf' n d = (n %/ d) :: f2cf' d (n %% d).
  Proof.
    case: d => //= n' Hd.
      by apply: f2cf'_equation.
  Qed.

  Lemma div_d__n n d r : 0 < d -> r < d -> (n * d + r) %/ d = n.
  Proof.
    move=> Hd Hrd.
    rewrite divnMDl; last done.
    rewrite divn_small; last done.
      by rewrite addn0.
  Qed.

  Lemma mod_d__r n d r : r < d -> (n * d + r) %% d = r.
  Proof.
    move=> Hrd.
    Check modnMDl.                     (* (p * d + m) %% d = m %% d *)
    rewrite modnMDl.
    rewrite modn_small; last done.
    done.
  Qed.

  Goal forall s, f2cf (cf2f s) = s.
  Proof.
    elim => // n s IHs /=.
    rewrite /f2cf /=.
    - rewrite f2cfE /=.
      + rewrite div_d__n.
        * rewrite mod_d__r.
          -- rewrite /f2cf in IHs.
               by rewrite IHs.
          -- admit.                      (* (cf2f s).2 < (cf2f s).1 *)
        * admit.                         (* 0 < (cf2f s).1 *)
        * admit.                         (* (cf2f s).2 < (cf2f s).1 *)
    - admit.                             (* (cf2f s).1 != 0 *)
  Admitted.

End CF.

(**
# continuant polynomial

文献[1] では Gauss が定義してものとして、H(・) と表記されている。
リストの前に追加する。consによる定義。

文献[2] では、Eulerが研究したものとして、 K(・) と表記されている。
リストの後に追加する。rconsによる定義。
 *)
Section CP.

(**
## Gauss の H関数

### Gauss の H関数の定義

```
H() = 1
H(x_1) = x_1
H(x_1 ... x_n) = x_1 * K(x_2 ... x_n) + K(x_3 ... x_n)
```
*)
  Program Fixpoint GaussHp (s : seq nat) {measure (size s)} : nat := (* notu *)
    match s with
    | [::] => 1
    | [:: n] => n
    | n0 :: n1 :: s' => n0 * GaussHp (n1 :: s') + GaussHp s'
    end.
  Obligation 2.
  Proof.
    apply/ltP => //=.
  Qed.

  Function GaussH (s : seq nat) {measure size s} : nat :=
    match s with
    | [::] => 1
    | [:: n] => n
    | n0 :: n1 :: s' => n0 * GaussH (n1 :: s') + GaussH s'
    end.
  Proof.
    - move=> s n0 l n1 s' H1 H2.
      apply/ltP => /=.
        by ssromega.
    - move=> s n0 l n1 s' H1 H2.
      apply/ltP => /=.
        by ssromega.
  Defined.

  Compute GaussH [:: 3; 3; 1; 2].           (* 36 *)
  Compute GaussH [:: 3; 1; 2].              (* 11 *)
  Compute cf2f [:: 3; 3; 1; 2].             (* (36, 11) *)

(**
### 連分数とcontinuant

有限正則連分数 s が、有理数 ``n / d`` を示すとする。

- H(s)は、有理数の分子 n である。
- H(behead s)は、有理数の分母 d である。

```n / d = H(x1 x2 x3 ... ) / H(x2 x3 ...) = [x1; x2, x3 ...]```
のように表される（文献 [3]）。
*)
  Lemma cf2fE n0 n1 s :
    (cf2f [:: n0, n1 & s]).1 = n0 * (cf2f (n1 :: s)).1 + (cf2f s).1.
  Proof. done. Qed.

  Lemma num_GaussH s : (cf2f s).1 = GaussH s.
  Proof.
    functional induction (GaussH s) => //.
    - by rewrite /cf2f muln1 addn0.
    - rewrite -IHn -IHn0.
      rewrite -cf2fE.
      done.
  Qed.

  Lemma den_GaussH n s : (cf2f (n :: s)).2 = GaussH s.
  Proof.
    functional induction (GaussH s) => //.
    - by rewrite /cf2f muln1 addn0.
    - rewrite -IHn0 -IHn1.
      rewrite -cf2fE.
      done.
  Qed.

(**
### continuant の性質
*)

  Compute GaussH [:: 1;2;3;4;5].                       (* 225 *)
  Compute GaussH [:: 5;4;3;2;1].                       (* 225 *)
  Compute 5 * GaussH [:: 1;2;3;4] + GaussH [:: 1;2;3]. (* 225 *)

  Compute (GaussH [:: 1;2;3] * GaussH [:: 4;5]) + (GaussH [:: 1;2] * GaussH [:: 5]).
  (* 225 *)

  Lemma GaussH1 : GaussH [::] = 1.
  Proof. done. Qed.

  Lemma GaussHn n : GaussH [:: n] = n.
  Proof. done. Qed.

  Lemma GaussHE (n0 n1 : nat) (s : seq nat) :
    GaussH (n0 :: n1 :: s) = n0 * GaussH (n1 :: s) + GaussH s.
  Proof.
    by rewrite GaussH_equation.
  Qed.

  Lemma GaussHEr (n0 n1 : nat) (s : seq nat) :
    GaussH (rcons (rcons s n1) n0) = n0 * GaussH (rcons s n1) + GaussH s.
  Proof.
    functional induction (GaussH s).
    - rewrite GaussHE /GaussH /=.
      by rewrite mulnC.
    - rewrite GaussHE /GaussH /=.
    (* n * (n1 * n0 + 1) + n0 = n0 * (n * n1 + 1) + n *)
      rewrite !mulnDr !mulnA !muln1.
      rewrite ?addnA addnAC.                (* n を最後に。 *)
      rewrite ?mulnA mulnAC.                (* n1 を最後に。 *)
      rewrite -?mulnA mulnCA.               (* n0 を最初に。 *)
      done.
    - rewrite /=.
      rewrite GaussHE IHn0 /=.
      rewrite GaussHE IHn /=.
      rewrite !mulnDr.
      rewrite ?addnA.
      rewrite [n2 * (n0 * GaussH (n3 :: rcons s' n1))]mulnCA.
        by ssromega.
  Qed.

  Lemma GaussH__GaussH_rev s : GaussH s = GaussH (rev s).
  Proof.
    functional induction (GaussH s) => //.
    rewrite !rev_cons.
    rewrite GaussHEr.
    rewrite -rev_cons.
    rewrite IHn IHn0.
    done.
  Qed.

(**
## Euler の K関数

### Euler の K関数の定義

```
K() = 1
K(x_1) = x_1
K(x_1 ... x_n) = K(x_1 ... x_n-1) * x_n + K(x_1 ... x_n-2)
```
*)

(*
  Fixpoint tail (s : seq nat) : nat :=
    match s with
    | [::] => 0
    | [:: a] => a
    | a :: s => tail s
    end.

  Fixpoint body (s : seq nat) : seq nat :=
    match s with
    | [::] => [::]
    | [:: a] => [::]
    | a :: s => a :: body s
    end.
 *)
  Definition tail (s : seq nat) : nat := head 0 (rev s).
  Compute tail [:: 1; 2; 3].                (* 3 *)

  Definition body (s : seq nat) : seq nat := rev (drop 1 (rev s)).
  Compute body [:: 1; 2; 3].                (* [:: 1; 2] *)

  Lemma tail_rcons s n : tail (rcons s n) = n.
  Proof.
      by rewrite /tail rev_rcons.
  Qed.

  Lemma body_rcons s n : body (rcons s n) = s.
  Proof.
      by rewrite /body rev_rcons /= drop0 revK.
  Qed.

  Lemma size_body_1 s : 1 <= size s -> size (body s) < size s.
  Proof.
    case/lastP : s => // s n Hs.
    rewrite body_rcons size_rcons.
    done.
  Qed.

  Lemma size_body_21 s : 2 <= size s -> size (body (body s)) < size (body s).
  Proof.
    case/lastP : s => // s n Hs.
    rewrite body_rcons.
    apply: size_body_1.
    rewrite size_rcons in Hs.
      by ssromega.
  Qed.

  Lemma size_body_2 s : 2 <= size s -> size (body (body s)) < size s.
  Proof.
    move=> Hs.
    Check @ltn_trans (size (body s)) (size (body (body s))) (size s).
    apply: (@ltn_trans (size (body s)) (size (body (body s))) (size s)).
    - by apply: (@size_body_21 s).
    - apply: size_body_1.
        by ssromega.
  Qed.

  Lemma tail_rev n s : tail (rev (n :: s)) = n.
  Proof.
    rewrite rev_cons.
      by rewrite tail_rcons.
  Qed.

  Lemma body_rev n s : body (rev (n :: s)) = rev s.
  Proof.
    rewrite rev_cons.
      by rewrite body_rcons.
  Qed.

  Function EulerK (s : seq nat) {measure size s} : nat :=
    match s with
    | [::] => 1
    | [:: n] => n
    | _ => tail s * EulerK (body s) + EulerK (body (body s))
    end.
  - move=> s n s' n' s'' H1 H2.
    apply/ltP.
    Check @size_body_2 [:: n, n' & s''].
    apply: (@size_body_2 [:: n, n' & s'']).
    done.
  - move=> s n s' n' s'' H1 H2.
    apply/ltP.
    Check @size_body_1 [:: n, n' & s''].
    apply: (@size_body_1 [:: n, n' & s'']).
    done.
  Defined.

  Compute EulerK  [:: 3; 3; 1; 2].          (* 36 *)
  Compute EulerK  [:: 3; 1; 2].             (* 11 *)

(**
### EulerK と GaussH が同じ
*)
  Lemma EulerKE s :
    2 <= size s ->
    EulerK s = tail s * EulerK (body s) + EulerK (body (body s)).
  Proof.
    case: s => //= n0 s.
    case: s.
    + done.
    + move=> n1 s Hs.
        by rewrite EulerK_equation.
  Qed.

  Lemma EulerK_rev__GaussH s : EulerK (rev s) = GaussH s.
  Proof.
    functional induction (GaussH s) => [//= | //= |].
    rewrite EulerKE.
    - rewrite tail_rev 2!body_rev.
      rewrite IHn -IHn0.
      done.
    - rewrite size_rev.
      done.
  Qed.

  Lemma EulerK_GaussH s : EulerK s = GaussH s.
  Proof.
    rewrite -(revK s).
    rewrite EulerK_rev__GaussH GaussH__GaussH_rev.
    rewrite revK.
    done.
  Qed.

(**
# 連分数とフィボナッチ数（と黄金数）

```n/d = (a2 / a1) = 3/2 = H(1, 1, 1) / H(1, 1) = [1; 1, 1] = (fib 4 / fib 3)```

``(a_n / a_n-1) = [1をn個] = H(1をn個)/H(1をn-1個) = (fib n+1 / fib n)```

文献[4]。このことから、1をn個の連分数は、``fib n.+1`` に等しい。

- H(1; 1; 1) = fib 4
- H(nseq n 1) = fib n.+1
*)
  Compute GaussH [::].                      (*      1 = fib 1 *)
  Compute GaussH [:: 1].                    (* a0 = 1 = fib 2 *)
  Compute GaussH [:: 1; 1].                 (* a1 = 2 = fib 3 *)
  Compute GaussH [:: 1; 1; 1].              (* a2 = 3 = fib 4 *)
  Compute GaussH (nseq 3 1).

  Function fib (n : nat) : nat :=
    match n with
    | 0 => 0
    | 1 => 1
    | (m.+1 as pn).+1 => fib m + fib pn (* fib n.-2 + fib n.-1 *)
    end.

  Lemma fibE n : fib n.+2 = fib n + fib n.+1.
  Proof. done. Qed.

  Lemma GaussH_fib n : GaussH (nseq n 1) = fib n.+1.
  Proof.
    functional induction (fib n) => [//= | //= |].
    rewrite fibE -IHn0 -IHn1.
    rewrite [nseq _.+2 1]/=.
    rewrite GaussHE mul1n.
    rewrite [nseq _.+1 1]/=.
      by rewrite addnC.
  Qed.

(**
（参考）フィボナッチ数列の隣接2項の商は、黄金数φに収束する。
*)

End CP.

(**
# 文献

[1] 有澤健治、平方根の連分数とペル方程式, 第1章
https://leo.aichi-u.ac.jp/~keisoken/research/books/book51/book51.pdf

[2] Ronald L. Graham, Donald E. Knuth, Oren Patashnik, Concrete Mathematics,
6.7 CONTINUANTS

[3] Wikipedia, Continuant (mathematics),
https://en.wikipedia.org/wiki/Continuant_(mathematics)
Properties 「Ratios of continuants represent (convergents to)
continued fractions as follows:」

[4] Wikipedia, 連分数
https://ja.wikipedia.org/wiki/連分数
連分数の性質「なお数列an が全て 1 の場合、数列pn, qn はともにフィボナッチ数列
(F0 = 0, F1 = 1) である」
 *)

(* END *)


(* See github.com/andrejbaur for more details on getting started. *)

Definition P (A : Type) := A -> Prop.

Notation "{ x : A | P }" := (fun x : A => P).

Definition singleton {A : Type} (x : A) := {y:A | x = y}.

Definition subset {A : Type} (u v : P A) :=
  forall x : A, u x -> v x.

Notation "u <= v" := (subset u v).

Definition disjoint {A : Type} (u v : P A) :=
  forall x, ~(u x /\ v x).

Notation "'all' x : U , P" := (forall x, U x -> P) (at level 20, x at level 99).

Notation "'some' x : U , P" := (exists x, U x /\ P) (at level 20, x at level 99).

Definition union {A : Type} (S : P (P A)) :=
  {x : A | some U : S, U x }.

Definition inter {A : Type} (u v : P A) :=
  {x : A | u x /\ v x}.

Notation "u * v" := (inter u v).

Definition empty {A : Type} := { x : A | False}.
Definition full {A : Type} := { x : A | True}.

Structure topology (A : Type) :=
  {
    open :> P A -> Prop ;
    empty_open : open empty ;
    full_open : open full;
    inter_open : all u : open, all v :open, open (u * v);
    union_open : forall S, S<= open -> open (union S)
  }.

Definition discrete (A : Type) : topology A.
Proof.
  exists full ; firstorder.
Defined.

Definition T1 {A : Type} (T : topology A) :=
  forall x y : A,
    x <> y ->
    some u : T, (u x /\ ~(u y)).

Definition hausdorff {A : Type} (T : topology A) :=
  forall x y : A,
    x <> y ->
    some u : T, some v : T,
  (u x /\ v y /\ disjoint u v).

Lemma discrete_hausdorff {A : Type} : hausdorff (discrete A).
Proof.
  intros x y N.
  exists { z : A | x = z}; split ; [exact I | idtac].
  exists { z : A | y = z}; split ; [exact I | idtac].
  repeat split ; auto.
  intros z [? ?].
  absurd (x = y); auto.
  transitivity z ; auto.
Qed.

Lemma hausdorff_is_T1 {A : Type} (T : topology A):
  hausdorff T -> T1 T.
Proof.
  intros H x y N.
  destruct (H x y N) as [u [? [v [? [? [? G]]]]]].
  exists u ; repeat split ; auto.
  intro.
  absurd (u y /\ v y); auto.
Qed.

Definition indiscrete (A : Type) : topology A.
Proof.
  exists { u : P A | forall x : A, u x -> (forall y : A, u y) }; firstorder.
Defined.

Lemma indiscrete_least (A : Type) (T : topology A) :
  (forall (X : Type) (s t : P X), s <= t -> t <= s -> s = t) ->
  indiscrete A <= T.
Proof.
  intros ext u H.
  assert (G : (u = union { v : P A | T v /\ some x : v, u x })).
  - apply ext.
    + intros x ?. exists full; firstorder using full_open.
    + intros x [v [[? [y [? ?]]] ?]] ; now apply (H y).
  - rewrite G ; apply union_open ; firstorder.
Qed.

Definition particular {A : Type} (x : A) : topology A.
Proof.
  exists { u : P A | (exists y, u y) -> u x } ; firstorder.
Qed.

(* the topology generated by a family B of subsets that are
   closed under finite intersections. *)
Definition base {A : Type} (B : P (P A)) :
  B full -> (all u : B, all v : B, B (u * v)) -> topology A.
Proof.
  intros H G.
  exists { u : P A | forall x, u x <-> some v : B, (v x /\ v <= u) }.
  - firstorder.
  - firstorder.
  - intros u Hu v Hv x.
    split.
    + intros [Gu Gv].
      destruct (proj1 (Hu x) Gu) as [u' [? [? ?]]].
      destruct (proj1 (Hv x) Gv) as [v' [? [? ?]]].
      exists (u' * v') ; firstorder.
    + intros [w [? [? ?]]].
      split ; now apply H2.
  - intros S K x.
    split.
    + intros [u [H1 H2]].
      destruct (K u H1 x) as [L1 _].
      destruct (L1 H2) as [v ?].
      exists v; firstorder.
    + firstorder.
Defined.

Require Import List.

(* The intersection of a finite list of subsets. *)
Definition inters {A : Type} (us : list (P A)) : P A :=
  {x : A | Forall (fun u => u x) us }.

(* The closure of a family of sets by finite intersections. *)
Definition inter_close {A : Type} (S : P (P A)) :=
  { v : P A | some us : Forall S, (forall x, v x <-> inters us x) }.

Lemma Forall_app {A : Type} (l1 l2 : list A) (P : A -> Prop):
  Forall P l1 -> Forall P l2 -> Forall P (l1 ++ l2).
Proof.
  induction l1 ; simpl ; auto.
  intro H.
  inversion H; auto.
Qed.

Lemma Forall_app1 {A : Type} (l1 l2 : list A) (P : A -> Prop) :
  Forall P (l1 ++ l2) -> Forall P l1.
Proof.
  induction l1; simpl ; auto.
  intro H.
  inversion H; auto.
Qed.

Lemma Forall_app2 {A : Type} (l1 l2 : list A) (P : A -> Prop):
  Forall P (l1 ++ l2) -> Forall P l2.
Proof.
  induction l1; simpl ; auto.
  intros H.
  inversion H; auto.
Qed.

(* The topology generated by a subbase S. *)
Definition subbase {A : Type} (S : P (P A)) : topology A.
Proof.
  apply (base (inter_close S)).
  - exists nil ; firstorder using Forall_nil.
  - intros u [us [Hu Gu]] v [vs [Hv Gv]].
    exists (us ++ vs).
    split ; [ (now apply Forall_app) | idtac ].
    split.
    + intros [? ?].
      apply Forall_app ; firstorder.
    + intro K; split.
      * apply Gu.
        apply (Forall_app1 _ _ _ K).
      * apply Gv.
        apply (Forall_app2 _ _ _ K).
Defined.

Lemma subbase_open {A : Type} (S : P (P A)) (u : P A) :
  S u -> (subbase S) u.
Proof.
  intros H x.
  split.
  - intro G.
    exists u ; split ; [ idtac | firstorder ].
    exists (u :: nil).
    split ; [now constructor | idtac].
    intro y; split.
    + intro ; now constructor.
    + intro K.
      inversion K; auto.
  - firstorder.
Qed.

Definition cofinite (A: Type) : topology A :=
  subbase { u : P A | exists x, forall y, (u y <-> y <> x) }.

Lemma cofinite_T1 (A : Type) : T1 (cofinite A).
Proof.
  intros x y N.
  exists {z : A | z<>y}.
  split ; auto.
  apply subbase_open.
  exists y; firstorder.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (z : natural) (lf3 : natural) (lf2 : natural) : natural :=
  plus (plus z lf3) lf2.


Require Import Init Nat.

Module sets.
 Fixpoint ninl (n : nat) (a : list nat) : bool :=
  match a with
  | nil => true
  | cons x a' =>
   match eqb n x with
   | false => ninl n a'
   | true => false
   end
  end
 .

 Fixpoint uniques (a : list nat) : bool :=
  match a with
  | nil => true
  | cons x a' =>
   match ninl x a' with
   | false => false
   | true => uniques a'
   end
  end
 .

 Definition set := { x : list nat | eq_true (uniques x) }.

 Definition add_uniques (n : nat) (s : list nat) (p : eq_true (uniques s)) (q : eq_true (ninl n s))
     : eq_true (uniques (cons n s)).
 Proof.
  unfold uniques.
  fold (uniques s).
  destruct (ninl n s).
  -
   apply p.
  -
   apply q.
 Defined.

 Definition if_eq_true {r : Type} (b : bool) (t : eq_true b -> r) (f : r) : r.
 Proof.
  destruct b.
  -
   apply t.
   apply is_eq_true.
  -
   apply f.
 Defined.

 Definition add (n : nat) (s : set) : set :=
  match s with
  | exist _ s' p =>
   if_eq_true (ninl n s')
    (fun q => exist _ (cons n s') (add_uniques n s' p q))
    (exist _ s' p)
  end
 .
End sets.

Extraction Language Haskell.

Extraction sets.


Require Export MetricSpaces.
Require Import Psatz.
From Coq Require Import ProofIrrelevance.

Section Completeness.

Variable X:Type.
Variable d:X->X->R.
Hypothesis d_metric: metric d.

Definition cauchy (x:nat->X) : Prop :=
  forall eps:R, eps > 0 -> exists N:nat, forall m n:nat,
    (m >= N)%nat -> (n >= N)%nat -> d (x m) (x n) < eps.

Lemma convergent_sequence_is_cauchy:
  forall (x:Net nat_DS (MetricTopology d d_metric))
    (x0:point_set (MetricTopology d d_metric)),
  net_limit x x0 -> cauchy x.
Proof.
intros.
destruct (MetricTopology_metrized X d d_metric x0).
red; intros.
destruct (H (open_ball d x0 (eps/2))) as [N].
- Opaque In. apply open_neighborhood_basis_elements. Transparent In.
  constructor.
  lra.
- constructor.
  rewrite metric_zero; trivial.
  lra.
- simpl in N.
  exists N.
  intros.
  destruct (H1 m H2).
  destruct (H1 n H3).
  apply Rle_lt_trans with (d x0 (x m) + d x0 (x n)).
  + rewrite (metric_sym _ _ d_metric x0 (x m)); trivial.
    now apply triangle_inequality.
  + lra.
Qed.

Lemma cauchy_sequence_with_cluster_point_converges:
  forall (x:Net nat_DS (MetricTopology d d_metric))
    (x0:point_set (MetricTopology d d_metric)),
  cauchy x -> net_cluster_point x x0 -> net_limit x x0.
Proof.
intros.
apply metric_space_net_limit with d.
- apply MetricTopology_metrized.
- intros.
  red; intros.
  destruct (H (eps/2)) as [N].
  + lra.
  + pose (U := open_ball d x0 (eps/2)).
    assert (open_neighborhood U x0 (X:=MetricTopology d d_metric)).
  { apply MetricTopology_metrized.
    constructor.
    lra. }
    destruct H3.
    destruct (H0 U H3 H4 N) as [m [? []]].
    simpl in H5.
    exists N; intros n ?.
    simpl in H7.
    apply Rle_lt_trans with (d x0 (x m) + d (x m) (x n)).
    * now apply triangle_inequality.
    * cut (d (x m) (x n) < eps/2).
      ** lra.
      ** now apply H2.
Qed.

Definition complete : Prop :=
  forall x:nat->X, cauchy x ->
    exists x0:X, net_limit x x0 (I:=nat_DS)
      (X:=MetricTopology d d_metric).

End Completeness.

Arguments cauchy {X}.
Arguments complete {X}.

Section closed_subset_of_complete.

Variable X:Type.
Variable d:X->X->R.
Hypothesis d_metric:metric d.
Variable F:Ensemble X.

Let FT := { x:X | In F x }.
Let d_restriction := fun x y:FT => d (proj1_sig x) (proj1_sig y).

Lemma d_restriction_metric: metric d_restriction.
Proof.
constructor; intros; try destruct x; try destruct y; try destruct z;
  try apply subset_eq_compat; apply d_metric; trivial.
Qed.

Lemma closed_subset_of_complete_is_complete:
  complete d d_metric ->
  closed F (X:=MetricTopology d d_metric) ->
  complete d_restriction d_restriction_metric.
Proof.
intros.
red; intros.
pose (y := fun n:nat => proj1_sig (x n)).
destruct (H y) as [y0].
- red; intros.
  destruct (H1 eps H2) as [N].
  now exists N.
- intros.
  assert (In F y0).
{ rewrite <- (closure_fixes_closed _ H0); trivial.
  apply @net_limit_in_closure with (I:=nat_DS) (x:=y); trivial.
  red; intros.
  exists i; split.
  - apply le_refl.
  - unfold y.
    destruct (x i); trivial. }
  exists (exist _ y0 H3).
  apply metric_space_net_limit with d_restriction.
  + apply MetricTopology_metrized.
  + intros.
    unfold d_restriction; simpl.
    apply metric_space_net_limit_converse with
      (MetricTopology d d_metric); trivial.
    apply MetricTopology_metrized.
Qed.

Lemma complete_subset_is_closed:
  complete d_restriction d_restriction_metric ->
  closed F (X:=MetricTopology d d_metric).
Proof.
intros.
cut (Included (closure F (X:=MetricTopology d d_metric)) F).
- intros.
  assert (closure F (X:=MetricTopology d d_metric) = F).
{ apply Extensionality_Ensembles.
  split; trivial; apply closure_inflationary. }
  rewrite <- H1; apply closure_closed.
- red; intros.
  assert (exists y:Net nat_DS (MetricTopology d d_metric),
    (forall n:nat, In F (y n)) /\ net_limit y x).
{ apply first_countable_sequence_closure; trivial.
  apply metrizable_impl_first_countable.
  exists d; trivial; apply MetricTopology_metrized. }
  destruct H1 as [y []].
  pose (y' := ((fun n:nat => exist _ (y n) (H1 n)) :
               Net nat_DS (MetricTopology d_restriction d_restriction_metric))).
  assert (cauchy d y).
{ apply convergent_sequence_is_cauchy with d_metric x; trivial. }
  assert (cauchy d_restriction y').
{ red; intros.
  destruct (H3 eps H4) as [N].
  exists N; intros.
  unfold d_restriction; unfold y'; simpl.
  now apply H5. }
  destruct (H _ H4) as [[x0]].
  cut (net_limit y x0 (I:=nat_DS) (X:=MetricTopology d d_metric)).
  + intros.
    assert (x = x0).
  { assert (uniqueness (net_limit y (I:=nat_DS)
                            (X:=MetricTopology d d_metric))).
  { apply Hausdorff_impl_net_limit_unique.
    apply T3_sep_impl_Hausdorff.
    apply normal_sep_impl_T3_sep.
    apply metrizable_impl_normal_sep.
    exists d; trivial.
    apply MetricTopology_metrized. }
    now apply H7. }
    now rewrite H7.
  + apply metric_space_net_limit with d.
    * apply MetricTopology_metrized.
    * exact (metric_space_net_limit_converse
        (MetricTopology d_restriction d_restriction_metric)
        d_restriction (MetricTopology_metrized _ d_restriction
                             d_restriction_metric)
        nat_DS y' (exist _ x0 i) H5).
Qed.

End closed_subset_of_complete.


Require Import mathcomp.ssreflect.all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

Inductive Fibonacci : nat -> nat -> Prop :=
  | Fib1 : Fibonacci 1 1
  | Fib2 : Fibonacci 1 2
  | FibPlus : forall val_1 val_2 seq, Fibonacci val_1 seq -> Fibonacci val_2 (seq + 1) -> Fibonacci (val_1 + val_2) (seq + 2).
Hint Constructors Fibonacci.

Definition f3 : Fibonacci 2 3 := FibPlus Fib1 Fib2.

Definition f4 : Fibonacci 3 4.
  exact (FibPlus Fib2 f3).
Qed.

Print f4.

Definition f6 : Fibonacci 8 6.
  cut (Fibonacci 5 5).
  move=> f5.
  exact (FibPlus f4 f5).
  exact (FibPlus f3 f4).
Qed.

Print f6.

Lemma weird :
  Fibonacci 7 18 ->
  Fibonacci 8 19 ->
  Fibonacci 15 20.
  intros.
  exact (FibPlus H H0).
Qed.

Require Import Coq.Arith.Even.

Print even.

Definition even0: even 0 := even_O.
Definition odd1 : odd 1 := odd_S 0 even0.
Definition odd3: odd 3 := odd_S 2 (even_S 1 odd1).
(* https://coq.inria.fr/library/Coq.Arith.Even.html *)
(* https://math-comp.github.io/htmldoc/mathcomp.ssreflect.ssrnat.html *)

Lemma even_repeat_3 :
  forall n0 n1 seq,
    Fibonacci n0 seq ->
    Fibonacci n1 (seq + 1) ->
    even n0 ->
    odd n1 ->
    (exists n3,
     Fibonacci n3 (seq + 3) /\ even n3).
  move=> n0 n1 seq fib0 fib1 even0 odd1.
  have fib2: Fibonacci (n0 + n1) (seq + 2).
  (exact (FibPlus fib0 fib1)).
  have plus1 : 2 = (1 + 1). eauto.
  rewrite plus1 in fib2.
  rewrite addnA in fib2.
  exists (n1 + (n0 + n1)).
  split.
  - have->: (3) = (1 + 2). eauto.
    rewrite [(seq + (1 + 2))] addnA.
    exact: (FibPlus fib1 fib2).
  - have odd2: odd (n0 + n1). by apply odd_plus_r.
    by apply odd_even_plus.
Qed.

Print even_repeat_3.


Fixpoint product_of_range from count :=
  match count with
  | O => 1
  | S count' => (S from) * product_of_range (S from) count'
  end.

Definition task :=
  forall from count, exists k,
      product_of_range from count = k * product_of_range O count.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (lf2 : natural) (y : natural) (x : natural)
  : natural := plus Zero (Succ y).