Set Printing Universes.
Set Universe Polymorphism.

Module LC.

Definition boolean := forall A, A -> A -> A.
Definition true : boolean := fun A t f => t.
Definition false : boolean := fun A t f => f.

Definition not : boolean -> boolean :=
  fun b => fun A t f => b A f t.

Definition and : boolean -> boolean -> boolean :=
  fun l r => fun A t f => l A (r A t f) f.

Definition or : boolean -> boolean -> boolean :=
  fun l r => fun A t f => l A t (r A t f).

Section boolean_examples.
  Variables (A: Type) (t f:A).
  Example true_ex : true A t f = t.
  Proof. trivial. Qed.

  Example false_ex : false A t f = f.
  Proof. trivial. Qed.

  Example not_t : not false = true.
  Proof. trivial. Qed.

  Example not_f : not true = false.
  Proof. trivial. Qed.

  Example and_t_t : and true true = true.
  Proof. trivial. Qed.

  Example and_t_f : and true false = false.
  Proof. trivial. Qed.

  Example and_f_t : and false true = false.
  Proof. trivial. Qed.

  Example and_f_f : and false false = false.
  Proof. trivial. Qed.

  Example or_t_t : or true true = true.
  Proof. trivial. Qed.

  Example or_t_f : or true false = true.
  Proof. trivial. Qed.

  Example or_f_t : or false true = true.
  Proof. trivial. Qed.

  Example or_f_f : or false false = false.
  Proof. trivial. Qed.
End boolean_examples.

Definition church := forall A, (A -> A) -> A -> A.

Definition zero : church := fun A (f:A->A) (x:A) => x.
Definition one : church := fun A (f:A->A) (x:A) => f x.
Definition two : church := fun A (f:A->A) (x:A) => f (f x).
Definition three : church := fun A (f:A->A) (x:A) => f (f (f x)).
Definition four : church := fun A (f:A->A) (x:A) => f (f (f (f x))).
Definition five : church := fun A (f:A->A) (x:A) => f (f (f (f (f x)))).

Definition succ : church -> church :=
  fun (n: church) => fun A (f: A->A) (x: A) => f (n A f x).

Definition plus : church -> church -> church :=
  fun m n => fun A (f: A->A) (x: A) => m A f (n A f x).

Definition plus' : church -> church -> church :=
  fun m n => m church succ n.

Definition mult : church -> church -> church :=
  fun m n => fun A (f: A->A) (x: A) => m A (n A f) x.

Definition iszero : church -> boolean :=
  fun n: church => n boolean (fun _ => false) true.

Fixpoint nat_to_church (n: nat): church :=
  match n with
    | 0 => zero
    | S x => succ (nat_to_church x)
  end.

Notation "<| n |>" := (nat_to_church n).

Section church_examples.
  Example succ_0 : succ zero = one.
  Proof. trivial. Qed.

  Example succ_1 : succ one = two.
  Proof. trivial. Qed.

  Example succ_2 : succ two = three.
  Proof. trivial. Qed.

  Example succ_3 : succ three = four.
  Proof. trivial. Qed.

  Example plus_0_N : forall (n: church), plus zero n = n.
  Proof. trivial. Qed.

  Example plus_N_0 : forall (n: church), plus n zero = n.
  Proof. trivial. Qed.

  Example plus_1_1 : plus one one = two.
  Proof. trivial. Qed.

  Example plus_2_2 : plus two two = four.
  Proof. trivial. Qed.

  Example mult_0_N : forall (n: church), mult zero n = zero.
  Proof. trivial. Qed.

  Example mult_N_0 : forall (n: church), mult n zero = zero.
  Proof.
  (* type of n is too weak *)
  Admitted.

  Example mult_1_N : forall (n: church), mult one n = n.
  Proof. trivial. Qed.

  Example mult_N_1 : forall (n: church), mult n one = n.
  Proof. trivial. Qed.

  Example mult2_plus : forall (n: church), mult two n = plus n n.
  Proof. trivial. Qed.

  Example mult_n2_plus : forall (n: church), mult n two = plus n n.
  Proof.
  (* type of n is too weak *)
  Admitted.

  Example zero_iszero : iszero zero = true.
  Proof. trivial. Qed.

  Example one_iszero : iszero one = false.
  Proof. trivial. Qed.

  Example two_iszero : iszero two = false.
  Proof. trivial. Qed.

  Lemma nat_succ : forall n:nat, <|S n|> = succ <|n|>.
  Proof. trivial. Qed.

  Lemma nat_plus : forall n m: nat, plus <|n|> <|m|> = <|n+m|>.
  Proof.
    intros n.
    induction n.
    + trivial.
    + intros.
      simpl.
      rewrite <- IHn.
      trivial.
  Qed.

  Lemma nat_mult : forall n m: nat, mult <|n|> <|m|> = <|n*m|>.
  Proof.
    intros n.
    induction n.
    + trivial.
    + intros.
      simpl.
      rewrite <- nat_plus.
      rewrite <- IHn.
      trivial.
  Qed.
End church_examples.

Definition pair A B := forall C, (A -> B -> C) -> C.

Definition make_pair {A B} : A -> B -> pair A B :=
  fun (a:A) (b:B) => fun C p => p a b.

Definition fst {A B} : pair A B -> A :=
  fun p => p A (fun a b => a).

Definition snd {A B} : pair A B -> B :=
  fun p => p B (fun a b => b).

Section pair_examples.
  Example good_fst : forall A B, forall (a:A) (b:B),
    fst (make_pair a b) = a.
  Proof. trivial. Qed.

  Example good_snd : forall A B, forall (a:A) (b:B),
    snd (make_pair a b) = b.
  Proof. trivial. Qed.
End pair_examples.

Definition pred_step : pair church church -> pair church church :=
  fun p => make_pair (snd p) (succ (snd p)).

Section pred_step_examples.
  Example pred_step_0 : pred_step (make_pair zero zero) = make_pair zero one.
  Proof. trivial. Qed.
  Example pred_step_1 : pred_step (make_pair zero one) = make_pair one two.
  Proof. trivial. Qed.

  Example pred_step_2 : pred_step (make_pair one two) = make_pair two three.
  Proof. trivial. Qed.

  Example pred_step_3 : pred_step (make_pair two three) = make_pair three four.
  Proof. trivial. Qed.
End pred_step_examples.

Definition pred : church -> church :=
  fun (n: church) => fst (n (pair church church) pred_step (make_pair zero zero)).

Section pred_examples.
  Example pred_0 : pred zero = zero.
  Proof. trivial. Qed.

  Example pred_1 : pred one = zero.
  Proof. trivial. Qed.

  Example pred_2 : pred two = one.
  Proof. trivial. Qed.

  Example pred_3 : pred three = two.
  Proof. trivial. Qed.

  Example pred_4 : pred four = three.
  Proof. trivial. Qed.
End pred_examples.

Fail Definition sub_ch : church -> church -> church :=
  fun n m => m church pred n.

Fail Definition leq_ch : church -> church -> boolean :=
  fun n m => iszero (sub_ch n m).

Fail Definition le_ch : church -> church -> boolean :=
  fun n m => leq_ch (succ n) m.

Fail Definition iseq_ch : church -> church -> boolean :=
  fun n m => and (leq_ch n m) (leq_ch m n).

Definition fib_step : pair church church -> pair church church :=
  fun p => make_pair (snd p) (plus (fst p) (snd p)).

Section fib_step_examples.
  Example fib_step_0 : fib_step (make_pair zero one) = make_pair one one.
  Proof. trivial. Qed.

  Example fib_step_1 : fib_step (make_pair one one) = make_pair one two.
  Proof. trivial. Qed.

  Example fib_step_2 : fib_step (make_pair one two) = make_pair two three.
  Proof. trivial. Qed.

  Example fib_step_3 : fib_step (make_pair two three) = make_pair three five.
  Proof. trivial. Qed.
End fib_step_examples.

Definition fib : church -> church :=
  fun n => fst (n (pair church church) fib_step (make_pair zero one)).

Section fib_examples.
  Example fib_0 : fib zero = zero.
  Proof. trivial. Qed.

  Example fib_1 : fib one = one.
  Proof. trivial. Qed.

  Example fib_2 : fib two = one.
  Proof. trivial. Qed.

  Example fib_3 : fib three = two.
  Proof. trivial. Qed.

  Example fib_4 : fib four = three.
  Proof. trivial. Qed.

  Example fib_5 : fib five = five.
  Proof. trivial. Qed.
End fib_examples.

End LC.

Recursive Extraction LC.


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Vector theory of real numbers based on ListList
  author    : ZhengPu Shi
  date      : 2021.12

  remark    :
  1. Use real numbers to represent components.
  2. it is based on VectorThySig
*)

Require Export DepRec.VectorThy.
Require Export FieldStruct.
Require Export ListListExt RExt.

Export FieldR.
Module Export VectorThyR := VectorThy FieldR.FieldDefR.

Open Scope R.
Open Scope mat_scope.
Open Scope vec_scope.

(* ######################################################################### *)
(** * Vector theory on Real numbers *)

(* ==================================== *)
(** ** Vector operations on any dimensions *)
Section DimAny.

  (** Length of a vector, also known as magnitude, and norm (Euclidean norm). *)

  (** Vector length squared. Note: it is suitable for compute *)
  Definition vlen_sqr {n} (v : V n) : R := vdot v v.

  (** Vector length. Note: it is a existential construct, suitable for proofs. *)
  Definition vlen {n} (v : V n) : R := sqrt (vlen_sqr v).

  (** Normalization of non-zero vector *)
  Definition vnormalize {n} (v : V n) (H : vnonzero v) : V n :=
    let k := 1 / (vlen v) in
      vcmul k v.

  (** The k times of a non-zero vector v is equal to 0, then k must be 0 *)
  Lemma vcmul_nonzero_eq_zero_imply_k0 : forall {n} (v : V n) k,
    vnonzero v -> k c* v = vec0 -> k = 0.
  Proof.
    intros. destruct v. unfold vnonzero in *. unfold vec0 in *.
    unfold mcmul in *.
    apply meq_iff in H0. apply meq_iff_not in H. simpl in *.
    unfold dmap in *.
    destruct (Xeqdec k 0); auto.
    rename mat_data into dl.
    generalize dependent n.
    generalize dependent dl. induction dl; intros.
    - simpl in *; subst; simpl in *. easy.
    - simpl in *. destruct n; simpl in *. easy.
      destruct mat_width. inversion mat_height.
      unfold dlzero in H. simpl in H.
      rewrite cons_neq_iff in H; try apply list_eq_dec.
      + destruct H.
        * (* a != [0] *)
          destruct a; try easy.
          assert (x <> 0 /\ a = []).
          { apply list_length1_neq. split; auto. }
          destruct H3.
          rewrite H5 in H0. simpl in H0. inversion H0.
  (*         assert ({k = 0} + {k != 0}). apply Aeqdec. *)
          destruct (Xeqdec k 0); auto.
          assert (k * x <> 0)%X; try easy.
          apply Rmult_integral_contrapositive_currified; auto.
        * (* dl != repeat [A0] n *)
          apply IHdl with (n:=n); auto.
          inversion H0. rewrite H6. rewrite H5. auto.
      + apply Xeqdec.
  Qed.

  (** Vector parallel (collinear): zero vector is parallel to any vector,
      or two non-zero vectors has k times relation.

      Discussion:
      The mainstream approach is that, the zero vector is parallel and perpendicular
      to any vector. If we could discuss parallel only for non-zero vector?
      A explicit reason is that, transitivity of parallel relation is not preserved
      if contain zero vector.

      Ref: https://www.zhihu.com/question/489006373

      关于零向量的平行？ 两个方面:
      a. “平行”或“不平行”是对两个可以被识别的方向的比较，对于零向量，“方向”是不可
         识别的，或说，是不确定的。从这个角度讲，“平行”这个概念不该被用到评价两个
         零向量的关系上的。
      b. 不过，两个零向量是“相等”的，对于向量而言，“相等”这件事包含了大小和方向
         的相等，这么说来，说两个零向量“方向”相等，也就是“平行”或也是说得通的。
  *)

  (* 定义1：v0是v1的k倍，或者 v1是v0的k倍。*)
  Definition vparallel_ver1 {n} (v0 v1 : V n) : Prop :=
    exists k, (v0 = k c* v1 \/ v1 = k c* v0).

  (* 定义2：v0 是 0，或者 v1 是 0，或者 v0 是 v1 的 k 倍 *)
  Definition vparallel_ver2 {n} (v0 v1 : V n) : Prop :=
    (vzero v0) \/ (vzero v1) \/ (exists k, v0 = k c* v1).

  (* 证明这两个定义等价 *)
  Lemma vparallel_ver1_eq_ver2 : forall {n} (v0 v1 : V n),
    vparallel_ver1 v0 v1 <-> vparallel_ver2 v0 v1.
  Proof.
    intros. unfold vparallel_ver1, vparallel_ver2.
    unfold vzero, vnonzero. split; intros.
    - assert ({v0 = vec0} + {v0 <> vec0}). apply meq_dec.
      assert ({v1 = vec0} + {v1 <> vec0}). apply meq_dec.
      destruct H0.
      + left. auto.
      + destruct H1.
        * right. left. auto.
        * right. right. destruct H. destruct H.
          { exists x. auto. }
          { exists (1/x). rewrite H.
            rewrite mcmul_assoc.
            replace ((1/x)%R * x)%X with 1.
            rewrite mcmul_1_l. easy.
            compute. field.
            apply (vec_eq_vcmul_imply_coef_neq0 v1 v0); auto. }
    - destruct H.
      + exists 0. left. rewrite mcmul_0_l. rewrite H. rewrite vec0_eq_mat0.
        easy.
      + destruct H.
        * exists 0. right. rewrite mcmul_0_l,H,vec0_eq_mat0. easy.
        * destruct H. exists x. left. auto.
  Qed.

  (** 向量平行谓词的定义 *)
  Definition vparallel {n} (v0 v1 : V n) : Prop :=
    vparallel_ver2 v0 v1.

  Notation "v0 // v1" := (vparallel (v0) (v1)) (at level 70) : vec_scope.

  (** * 向量平行的性质 *)

  (** 向量平行是等价关系 *)

  (** 自反性 *)
  Lemma vparallel_refl : forall {n} (v : V n), v // v.
  Proof.
    intros. unfold vparallel,vparallel_ver2. right. right. exists 1.
    rewrite mcmul_1_l. easy.
  Qed.

  (** 对称性 *)
  Lemma vparallel_sym : forall {n} (v0 v1 : V n), v0 // v1 -> v1 // v0.
  Proof.
    intros. unfold vparallel,vparallel_ver2 in *.
    assert ({vzero v0} + {vnonzero v0}). apply meq_dec.
    assert ({vzero v1} + {vnonzero v1}). apply meq_dec.
    destruct H0.
    - right; left; auto.
    - destruct H1.
      + left; auto.
      + destruct H; auto. destruct H; auto. destruct H.
        right; right. rewrite H.
        exists (1/x). rewrite mcmul_assoc.
        replace ((1/x)%R * x)%X with 1. rewrite mcmul_1_l; easy.
        compute. field. apply (vec_eq_vcmul_imply_coef_neq0 v0 v1); auto.
  Qed.

  (** 传递性 *)
  (* 要求v1是非零向量。因为若v1为0，v0//v1, v1//v2, 但 v0,v2 不平行 *)
  Lemma vparallel_trans : forall {n} (v0 v1 v2 : V n),
    vnonzero v1 -> v0 // v1 -> v1 // v2 -> v0 // v2.
  Proof.
    intros. unfold vparallel, vparallel_ver2 in *.
    assert ({vzero v0} + {vnonzero v0}). apply meq_dec.
    assert ({vzero v1} + {vnonzero v1}). apply meq_dec.
    assert ({vzero v2} + {vnonzero v2}). apply meq_dec.
    destruct H2.
    - left; auto.
    - destruct H4.
      + right; left; auto.
      + right; right.
        destruct H3.
        * destruct H0; try contradiction.
        * destruct H0,H1; try contradiction.
          destruct H0,H1; try contradiction.
          destruct H0,H1. rewrite H0,H1.
          exists (x*x0)%X. apply mcmul_assoc.
  Qed.

  (** 非零向量k倍相等，k唯一 *)
  Lemma vcmul_vnonzero_eq_iff_unique_k : forall {n} (v : V n) (H : vnonzero v),
    forall k1 k2, k1 c* v = k2 c* v -> k1 = k2.
  Proof.
    intros. destruct v. apply meq_iff in H0. simpl in *.
    rename mat_data into dl. unfold vnonzero in H. apply meq_iff_not in H.
    simpl in *.
    unfold dmap in *.
    (* hard part *)
    generalize dependent n.
    generalize dependent dl.
    induction dl; intros.
    - simpl in *; subst; simpl in *. easy.
    - simpl in *. inversion H0. clear H0. destruct mat_width.
      destruct n. easy. simpl in *.
      apply cons_neq_iff in H. destruct H.
      + (* a != [0] *)
        destruct a. easy.
        assert (a = []).
        { simpl in *. inversion H0. rewrite length_zero_iff_nil in H5; auto. }
        assert (x <> 0).
        { rewrite H4 in *. apply cons_neq_iff in H. destruct H; auto.
          apply Xeqdec. }
        subst. simpl in H2. inversion H2.
        apply Rmult_eq_reg_r with (r:=x); auto.
      + (* dl != ListAux.cvt_row2col (repeat 0 n) *)
        apply IHdl with (n:=n); auto.
      + apply list_eq_dec. apply Xeqdec.
  Qed.

  (** 非零向量平行，则存在唯一比例系数k *)
  Lemma vparallel_vnonezero_imply_unique_k : forall {n} (v0 v1 : V n)
    (H1 : vnonzero v0) (H2 : vnonzero v1),
    v0 // v1 -> (exists ! k, v0 = k c* v1).
  Proof.
    intros.
    destruct H; try contradiction.
    destruct H; try contradiction.
    destruct H. exists x. unfold unique. split; auto.
    intros. apply vcmul_vnonzero_eq_iff_unique_k with (v:=v1); auto.
    rewrite <- H,H0. easy.
  Qed.

  (** 非零向量v0，v1 与 v0 平行，iff，存在唯一实数 a 使得 v1 = a * v0 *)
  Lemma vparallel_iff1 : forall {n} (v0 v1 : V n) (H : vnonzero v0),
    (v1 // v0) <-> (exists ! a, v1 = a c* v0).
  Proof.
    intros. split; intros.
    - unfold vparallel, vparallel_ver2, vnonzero in *.
      assert ({vzero v0} + {vnonzero v0}). apply meq_dec.
      assert ({vzero v1} + {vnonzero v1}). apply meq_dec.
      destruct H1; try contradiction.
      destruct H2.
      + (* {vzero v1} *)
        exists 0. unfold unique. split.
        * rewrite v2. rewrite mcmul_0_l. apply vec0_eq_mat0.
        * rewrite v2. intros.
          symmetry. symmetry in H1.
          apply vcmul_nonzero_eq_zero_imply_k0 with (v:=v0); auto.
      + (* {vnonzero v1} *)
        destruct H0; try easy.
        destruct H0; try easy.
        destruct H0.
        (* vnonzero v0 -> vnonzero v1 -> v1 = x * v0 -> exists ! x *)
        exists x. unfold unique. split; auto.
        intros. rewrite H0 in H1.
        apply vcmul_vnonzero_eq_iff_unique_k in H1; auto.
    - destruct H0. destruct H0.
      unfold vparallel. unfold vparallel_ver2.
      right. right. exists x. auto.
  Qed.

End DimAny.

(* ==================================== *)
(** ** 3-dim vector operations *)
Section Dim3.

  (** 3阶方阵的行列式 *)
  Definition det3 (m : M 3 3) : X :=
    let '((a11,a12,a13),(a21,a22,a23),(a31,a32,a33)) :=
      m2t_3x3 m in
    let b1 := (a11 * a22 * a33)%X in
    let b2 := (a12 * a23 * a31)%X in
    let b3 := (a13 * a21 * a32)%X in
    let c1 := (a11 * a23 * a32)%X in
    let c2 := (a12 * a21 * a33)%X in
    let c3 := (a13 * a22 * a31)%X in
    let b := (b1 + b2 + b3)%X in
    let c := (c1 + c2 + c3)%X in
      (b - c)%X.

  (** V3斜对称矩阵 *)
  Definition skew_sym_mat_of_v3 (v : V 3) : M 3 3 :=
    let '(x,y,z) := v2t_3 v in
      (mk_mat_3_3
        X0    (-z)  y
        z     X0    (-x)
        (-y)  x     X0)%X.

  (** V3叉乘，向量积 *)
  Definition vcross3 (v1 v2 : V 3) : V 3 := (skew_sym_mat_of_v3 v1) * v2.

  (** 矩阵是否为SO3（李群，旋转群） *)
  Definition so3 (m : M 3 3) : Prop :=
    let so3_mul_unit : Prop := (m ᵀ) * m = mat1 3 in
    let so3_det : Prop := (det3 m) = X1 in
      so3_mul_unit /\ so3_det.

   (** 计算两个向量的夹角 *)
  Definition vangle3 (v0 v1 : V 3) : R :=
    acos (scalar_of_mat (v0 ᵀ * v1)).

  (** (1,0,0) 和 (1,1,0) 的夹角是 45度，即 π/4 *)
  Example vangle3_ex1 : vangle3 (l2v [1;0;0]) (l2v [1;1;0]) = PI/4.
  Proof.
    compute.
(*     Search acos. *)
    Abort. (* 暂不知哪里错了，要去查叉乘的意义 *)

  (** 根据两个向量来计算旋转轴 *)
  Definition rot_axis_by_twovec (v0 v1 : V 3) : V 3 :=
    let s : R := (vlen v0 * vlen v1)%R in
      (s c* (vcross3 v0 v1))%M.

  (* 谓词：两向量不共线（不平行的） *)
  (* Definition v3_non_colinear (v0 v1 : V3) : Prop :=
    v0 <> v1 /\ v0 <> (-v1)%M.
   *)

End Dim3.


(** 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) (y : natural) (x : natural) : natural :=
  plus x (Succ Zero).


(** 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) (y : natural) (x : natural) : natural :=
  plus Zero (Succ y).


Require Import String.

Definition prenom : string := "Eve".
Definition nom : string := "Poitevin".

(* *)

Inductive arbint : Set :=
  | F : arbint
  | N : arbint -> nat -> arbint  -> arbint
.

Fixpoint taille (a : arbint) : nat :=
  match a with
  | F => 0
  | N g n d => taille g + S (taille d)
  end.

Fixpoint arb_S (a : arbint) : arbint :=
  match a with
  | F => F
  | N g n d => N (arb_S g) (S n) (arb_S d)
  end.

(* ComplÃ©ter la preuve. *)
Lemma meme_taille_arb_S : forall a, taille (arb_S a) = taille a.
Proof.
  intro a.
  induction a as [ | ].
  - cbn [arb_S]. reflexivity.
  - cbn [arb_S]. cbn [taille]. rewrite IHa1. rewrite IHa2. reflexivity.
Qed.

(* QCM (Ã  questions binaires) *)
(* Dans ce qui suit remplacer ". Admitted." par ":= votre reponse."
   si vous connaissez la bonne rÃ©ponse, ou laisser ". Admitted." sinon.*)

(* Question 1 :
  la preuve prÃ©cÃ©dente est par rÃ©currence sur a *)
Definition reponse_1 : bool:= true.

(* Question 2 :
   la preuve prÃ©cÃ©dente est par rÃ©currence sur la taille de a *)
Definition reponse_2 : bool:= false.

(* Question 3 :
   dans la preuve prÃ©cÃ©dente, combien y a-t-il d'hypothÃ¨ses de rÃ©currence ? *)
Definition reponse_3 : nat:= 2.


Require Import Cpdt.CpdtTactics.
Require Import Cpdt.Predicates.
(* exercise 0.2-1
   以下に示したタクティクのみを用いて、(a) ~ (c) を証明せよ。
   apply, assumption, constructor, destruct, intro, intros, left, right, split, unfold *)

Theorem tautology_a : and (or True False) (or True False).
  constructor; constructor; apply I.
Qed.

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

Theorem tautology_c : forall P Q R : Prop, (and P (or Q R)) -> (or (and P Q) (and P R)).
  intros.
  destruct H.
  destruct H0.
  left.
  constructor.
  apply H.
  apply H0.
  right.
  constructor.
  apply H.
  apply H0.
Qed.

(* exercise 0.2-2 *)
Theorem first_order_logic : forall (A : Type) (x y z : A) (P : A -> Prop)
                                   (Q : A -> A -> Prop) (F : A -> A),
    (P x) -> (forall x, P x -> exists y, Q x y) ->
    (forall x y, Q x y -> Q y (F y)) ->
    (exists z, Q z (F z)).
  intros.
  apply H0 in H.                (* 前提が forall なら apply *)
  destruct H as [ y0 H2 ].      (* 前提が exists なら destruct/case *)
  apply H1 in H2.
  exists y0.                    (* exists を示したければ具体的に成り立つものを与える *)
  assumption.
Qed.

Section Two.                    (* こう書くと綺麗 *)
  Variable T : Set.
  Variable x : T.
  Variable p : T -> Prop.
  Variable q : T -> T -> Prop.
  Variable f : T -> T.

  Theorem ex : p x -> (forall x, p x -> exists y, q x y) ->
               (forall x y, q x y -> q y (f y)) -> exists z, q z (f z).
    intros.
    assert (exists y, q x y).
    apply H0; assumption.
    destruct H2.
    exists x0.
    eapply H1.                  (* 普通のapplyだと死ぬ メタ変数を入れるようにする *)
    eassumption.
  Qed.
End Two.

(* exercise 0.2-3 *)
Inductive mult6 : nat -> Prop :=
| Mult6   : mult6 O
| MultS6  : forall n, mult6 n -> mult6 (S (S (S (S (S (S n)))))).

Inductive mult10 : nat -> Prop :=
| Mult10  : mult10 O
| MultS10 : forall n, mult10 n -> mult10 (S (S (S (S (S (S (S (S (S (S n)))))))))).

Inductive multiple : nat -> Prop :=
| Multi6  : forall n, mult6 n -> multiple n
| Multi10 : forall n, mult10 n -> multiple n.

Theorem mult6_contra : mult6 13 -> False.
  inversion 1.
  inversion H1.
  inversion H3.
Qed.

Theorem not13 : ~ (mult6 13).   (* False を導いても、not を示してもOK *)
  intro.
  repeat (
      match goal with
      | [ H : mult6  ?N |- _] => inversion H
      | [ H : mult10 ?N |- _] => inversion H
      end
    ).
Qed.

Theorem multiple_contra : multiple 13 -> False.
  inversion 1.
  inversion H0.
  inversion H3.
  inversion H5.

  inversion H0.
  inversion H3.
Qed.

Inductive oddness : nat -> Prop :=
| Odd : forall n, oddness (S (n * 2)).

Eval simpl in oddness (S O).
Eval simpl in (S (S (S O)) * 2).

Theorem not_6_or_10 : forall n, multiple n -> ~ exists m, n = 1 + 2 * m.
  Admitted.


Require Export Arith.
Require Export ArithRing.
Require Export Omega.

Ltac CaseEq f := generalize (refl_equal f);
    pattern f at -1 in |- *; case f.

Fixpoint div4 (n:nat) : nat * nat :=
  match n with
  | S (S (S (S p))) => let (q, r) := div4 p in (S q, r)
  | a => (0, a)
  end.

Fixpoint bsqrt (n b:nat) {struct b} : nat * nat :=
  match b with
  | O => (0, 0)
  | S b' =>
      match div4 n with
      | (O, O) => (0, 0)
      | (O, S p) => (1, p)
      | (q, r0) =>
          let (s', r') := bsqrt q b' in
          match le_gt_dec (4 * s' + 1) (4 * r' + r0) with
          | left _ => (2 * s' + 1, 4 * r' + r0 - (4 * s' + 1))
          | right _ => (2 * s', 4 * r' + r0)
          end
      end
  end.

(* We start by proving a few basic properties of division by 4.
  As suggested in section 8.3.1, we can use a specific induction
  principle to work on div4.  This is also the solution to exercise
  \ref{quadruple_induction}. *)

Theorem div4_ind :
 forall P:nat -> Prop,
   P 0 ->
   P 1 ->
   P 2 ->
   P 3 -> (forall n:nat, P n -> P (S (S (S (S n))))) -> forall n:nat, P n.
Proof.
 intros P P0 P1 P2 P3 Prec n.
 cut (P n /\ P (S n) /\ P (S (S n)) /\ P (S (S (S n)))).
 -  intuition.
 -  elim n; intuition.
Qed.

(* Proving the main characteristics of div4 is easy using
  div4_ind.  We avoid using Simpl so that multiplications
  do not get unfolded into additions. *)

Lemma div4_exact : forall n:nat, let (q, r) := div4 n in n = 4 * q + r.
Proof.
 intros n; elim n using div4_ind; try (simpl in |- *; auto; fail).
 intros p; cbv beta iota zeta delta [div4] in |- *; fold div4 in |- *.
 case (div4 p).
 intros q r Hrec; rewrite Hrec; ring.
Qed.
(* Since 4 is a constant, we can use div4_exact to
   obtain a linear equality in the sense of Presburger arithmetic
  and the Omega decision procedure can cope with the formula.*)

Theorem div4_lt : forall n:nat, let (q, r) := div4 n in 0 < q -> q < n.
Proof.
 intros n; generalize (div4_exact n); case (div4 n).
 intros q r Heq; omega.
Qed.

Theorem div4_lt_rem : forall n:nat, let (q, r) := div4 n in r < 4.
Proof.
 intros n; elim n using div4_ind; try (simpl in |- *; auto with arith).
 intros p; case (div4 p); auto.
Qed.

Ltac remove_minus :=
  match goal with
  |  |- context [(?X1 - ?X2 + ?X3)] =>
      rewrite <- (plus_comm X3); remove_minus
  |  |- context [(?X1 + (?X2 - ?X3) + ?X4)] =>
      rewrite (plus_assoc_reverse X1 (X2 - X3)); remove_minus
  |  |- context [(?X1 + (?X2 + (?X3 - ?X4)))] =>
      rewrite (plus_assoc X1 X2 (X3 - X4))
  |  |- (_ = ?X1 + (?X2 - ?X3)) =>
      apply (fun n m p:nat => plus_reg_l m p n) with X3;
       try rewrite (plus_permute X3 X1 (X2 - X3));
       rewrite le_plus_minus_r
  end.

(* The proof of this goal is a simple matter of computation, but
   NatRing can't cope with it because of the irregular behavior of
   minus.  The tactic remove_minus defined above takes care of that by
   adding the subtracted term on both side of the equality, and then
   simplifying with le_plus_minus.  This simplification only works
   because the theorem has the right hypothesis.  *)

Theorem bsqrt_exact_lemma_le :
 forall n q r s' r':nat,
   n = 4 * q + r ->
   q = s' * s' + r' ->
   4 * s' + 1 <= 4 * r' + r ->
   n = (2 * s' + 1) * (2 * s' + 1) + (4 * r' + r - (4 * s' + 1)).
Proof.
 intros; remove_minus.
 subst; ring.
 assumption.
Qed.

Lemma bsqrt_exact_lemma_gt :
 forall n q r s' r':nat,
   n = 4 * q + r ->
   q = s' * s' + r' ->
   4 * s' + 1 > 4 * r' + r -> n = 2 * s' * (2 * s') + (4 * r' + r).
Proof.
 intros; subst; ring.
Qed.

Theorem bsqrt_exact :
 forall b n:nat, n <= b -> let (s, r) := bsqrt n b in n = s * s + r.
Proof.
 (* Induction on the bound, as should always be the case
   for bounded recursive functions. *)
 intros b; elim b.

(* When the bound is zero, if n is lower than the bound, it
  is also 0, it is only a matter of computation to check the
  equality. *)
 intros n Hle; rewrite <- (le_n_O_eq _ Hle); simpl in |- *; auto.

 (*We limit simplification to the bsqrt function. *)
 intros b' Hrec n Hle; cbv beta iota zeta delta [bsqrt] in |- *;
  fold bsqrt in |- *.

 (* We use the lemmas on div4.  To avoid CaseEq, we rely on
   Generalize before doing a Case analysis. *)
 generalize (div4_lt n) (div4_exact n).
 case (div4 n).
 intros q r; case q.
 -  case r; intros; subst; ring.
 -  intros q' Hlt Heq; generalize (Hrec (S q')); case (bsqrt (S q') b').
    intros s' r' Hrec'.

 (* Because le_gt_dec is a well-specified function,
   there is no need to generalize hypotheses to perform
  the case analysis on this function call. *)
    case (le_gt_dec (4 * s' + 1) (4 * r' + r)).
    apply bsqrt_exact_lemma_le with (S q'); auto; omega.
    apply bsqrt_exact_lemma_gt with (S q'); auto; omega.
Qed.

Theorem bsqrt_rem :
 forall b n:nat, n <= b ->
   let (s, r) := bsqrt n b in n < (s + 1) * (s + 1).
Proof.
 intros b; elim b.
 -  intros n Hle; rewrite <- (le_n_O_eq _ Hle);
  simpl in |- *; auto with arith.

 (*We limit simplification to the bsqrt function. *)
 -  intros b' Hrec n Hle; generalize (bsqrt_exact (S b') n Hle);
    cbv beta iota zeta delta [bsqrt] in |- *; fold bsqrt in |- *.

(* We use the lemmas on div4.  To avoid CaseEq, we rely on
  Generalize before doing a Case analysis. *)
 generalize (div4_lt n) (div4_exact n) (div4_lt_rem n).
 case (div4 n);  intros q r;  case q.
 + case r; intros; subst; simpl in |- *; auto with arith.
 +  intros q' Hlt Heq Hlt_rem; generalize (Hrec (S q')).
    case (bsqrt (S q') b').
    intros s' r' Hrec'.

 (* Because le_gt_dec is a well-specified function,
   there is no need to generalize hypothesese to perform
   the case analysis on this function call. *)
 case (le_gt_dec (4 * s' + 1) (4 * r' + r)).
 *  intros Hle' Heq'; rewrite Heq.
    apply lt_le_trans with (4 * S q' + 4).
    auto with arith.
     replace ((2 * s' + 1 + 1) * (2 * s' + 1 + 1)) with
     (4 * ((s' + 1) * (s' + 1))).
     abstract omega.
     ring.
 *  intros Hgt Heq'; rewrite Heq'.
    match goal with
      |  |- (?X1 < ?X2) => ring_simplify X1; ring_simplify X2
    end.
    abstract omega.
Qed.

Definition sqrt_nat :
  forall n:nat,
    {s : nat &  {r : nat | n = s * s + r /\ n < (s + 1) * (s + 1)}}.
 intros n;
  generalize (bsqrt_exact n n (le_n n)) (bsqrt_rem n n (le_n n));
  case (bsqrt n n).
 intros s r H1 H2; exists s; exists r; auto.
Defined.

Example test : bsqrt 37 37 = (6,1).
Proof. reflexivity.  Qed.

Example test2 : bsqrt 49 49 = (7,0).
Proof. reflexivity.  Qed.


Definition eventually_periodic (f : nat -> nat) (n : nat) : Prop :=
  exists t m0,
    t > 0 /\ forall m, m0 < m -> Nat.iter (t + m) f n = Nat.iter m f n.

(* Floyd's tortoise and hare algorithm *)
Inductive hare_catches_tortoise (f : nat -> nat) : nat -> nat -> Prop :=
| CatchNext : forall x y, x = f y -> hare_catches_tortoise f x y
| CatchLater : forall x y, hare_catches_tortoise f (f x) (f (f y)) ->
                           hare_catches_tortoise f x y.

Definition task :=
  forall f n, eventually_periodic f n <-> hare_catches_tortoise f n (f n).


(*******************************************************************)
(*  This is part of RelationAlgebra, it is distributed under the   *)
(*    terms of the GNU Lesser General Public License version 3     *)
(*              (see file LICENSE for more details)                *)
(*                                                                 *)
(*  Copyright 2012: Damien Pous. (CNRS, LIP - ENS Lyon, UMR 5668)  *)
(*******************************************************************)

(** * pair: encoding pairs of ordinals as ordinals *)
(** more precisely, [ord n * ord m] into [ord (n*m)] *)

Require Import Lt Peano_dec Compare_dec Mult Euclid NPeano. (* TODO: se passer de NPeano? *)
Require Import ordinal.

Set Asymmetric Patterns.
Set Implicit Arguments.

(** equivalence between our Boolean strict order on [nat],
   and the standard one from the standard library  *)
Lemma ltb_lt x y: ltb x y = true <-> lt x y.
Proof.
  revert y. induction x; destruct y; simpl.
   split. discriminate. inversion 1.
   split. intro. apply lt_0_Sn. reflexivity.
   split. discriminate. inversion 1.
   rewrite IHx. split. apply lt_n_S. apply lt_S_n.
Qed.

(** auxiliary lemma *)
Lemma mk_lt n m x y: x<n -> y<m -> y*n+x < n*m.
Proof.
  setoid_rewrite ltb_lt.
  intros. apply lt_le_trans with (y*n+n). apply plus_le_lt_compat. apply le_n. assumption.
  rewrite <-mult_succ_l, (mult_comm n). apply mult_le_compat. assumption. apply le_n.
Qed.

(** since [x] is bounded by [n], we encode the pair [(x,y)] as [y*n+x] *)
Definition mk n m (x: ord n) (y: ord m): ord (n*m).
destruct x as [x Hx]; destruct y as [y Hy].
apply Ord with (y*n+x).
now apply mk_lt.
Defined.

Lemma ord_nm_lt_O_n {n m} (x: ord (n*m)): lt 0 n.
Proof. destruct n. elim (ord_0_empty x). apply lt_0_Sn. Qed.

(** first projection, by modulo *)
Definition pi1 {n m} (p: ord (n*m)): ord n :=
  let '(divex _ x Hx _) := eucl_dev n (ord_nm_lt_O_n p) p in (Ord x (proj2 (ltb_lt _ _) Hx)).

(** second projection, by division *)
Definition pi2 {n m} (p: ord (n*m)): ord m.
destruct (eucl_dev n (ord_nm_lt_O_n p) p) as [y x Hx Hy].
apply Ord with y.
unfold gt in *.
destruct p as [p Hp]. simpl in Hy. rewrite Hy in Hp. clear p Hy.
destruct (le_lt_dec m y) as [Hy|Hy]. 2: now apply ltb_lt. exfalso.
apply ltb_lt in Hp. apply (mult_le_compat_l _ _ n) in  Hy.
apply (lt_le_trans _ _ _ Hp) in Hy. rewrite mult_comm in Hy.
apply ltb_lt in Hy. rewrite leb_plus_r in Hy. discriminate.
Defined.

Lemma euclid_unique n: lt 0 n ->
  forall x y x' y', lt x n -> lt x' n -> y*n+x = y'*n+x' -> y=y' /\ x=x'.
Proof.
  intros Hn x y x' y' Hx Hx' H. rewrite mult_comm, (mult_comm y') in H. split.
   erewrite Nat.div_unique. 3: eassumption. 2: assumption.
   rewrite H. eapply Nat.div_unique. 2: symmetry; eassumption. assumption.
   erewrite Nat.mod_unique. 3: eassumption. 2: assumption.
   rewrite H. eapply Nat.mod_unique. 2: symmetry; eassumption. assumption.
Qed.

(** projections bhave as expected *)
Lemma pi1mk n m: forall x y, pi1 (@mk n m x y) = x.
Proof.
  intros [x Hx] [y Hy]. unfold pi1, mk. case eucl_dev.
  intros y' x' Hx' H. apply eq_ord. apply euclid_unique in H as [_ ?]; auto.
  eapply le_lt_trans. apply le_0_n. eassumption.
  now apply ltb_lt.
Qed.

Lemma pi2mk n m: forall x y, pi2 (@mk n m x y) = y.
Proof.
  intros [x Hx] [y Hy]. unfold pi2, mk. case eucl_dev.
  intros y' x' Hx' H. apply eq_ord. simpl. apply euclid_unique in H as [? _]; auto.
  eapply le_lt_trans. apply le_0_n. eassumption.
  now apply ltb_lt.
Qed.

(** surjective pairing *)
Lemma mkpi12 n m: forall p, @mk n m (pi1 p) (pi2 p) = p.
Proof.
  intros [p Hp]. unfold pi1, pi2, mk. case eucl_dev. simpl. intros y x Hx Hy.
  apply eq_ord. simpl. now rewrite Hy.
Qed.


Require Import SQIR.UnitaryOps.
Require Import Utilities.
Require Import QuantumLib.Measurement.

Open Scope ucom.
Local Close Scope C_scope.
Local Close Scope R_scope.

Local Coercion Nat.b2n : bool >-> nat.

(* This file contains a definition of the Deutsch-Jozsa program, which determines
   whether a function is constant or balanced using one query to a boolean oracle.

   See, e.g., https://en.wikipedia.org/wiki/Deutsch%E2%80%93Jozsa_algorithm

   This file also contains proofs of correctness of the Deutsch-Jozsa program
   using two different methods. The first uses a standard definition of boolean
   oracles and follows the standard textbook proof of correctness. The second
   uses an inductive definition of boolean oracles, which allows for an inductive
   proof. *)

(** Definition of Deutsch-Jozsa program. **)

Definition deutsch_jozsa {n} (U : base_ucom (S n)) : base_ucom (S n) :=
  X n ; npar (S n) U_H ; U; npar (S n) U_H.

(** Proof of correctness #1 **)

(* Definition of boolean oracle U : ∣ x ⟩∣ y ⟩ ↦ ∣ x ⟩∣ y ⊕ f(x) ⟩ *)
Definition boolean_oracle {n} (U : base_ucom (S n)) (f : nat -> bool) :=
  forall x (y : bool), (x < 2 ^ n)%nat ->
    @Mmult _ _ 1 (uc_eval U) (basis_vector (2 ^ n) x ⊗ ∣ y ⟩) =
      basis_vector (2 ^ n) x ⊗ ∣ xorb y (f x) ⟩.

Definition balanced f n := n > 0 /\ count0 f (2 ^ n) = 2 ^ (n - 1).

Definition constant f n := count0 f (2 ^ n) = 0 \/ count0 f (2 ^ n) = 2 ^ n.

Local Open Scope C_scope.
Local Open Scope R_scope.

(* After running deutsch_jozsa, the probability of measuring the state
   (n ⨂ ∣0⟩) ⊗ ∣1⟩ will be a sum of terms of the form (-1)^(f x). The
   value of this sum can be rewritten as follows:
       ∑ (-1)^(f x) / n = 1 - 2 * count f / n.
   Note that if f is balanced, then this expression will be zero. If f is
   constant then the expression will either be 1 or -1. *)
Lemma sum_of_minus_1 : forall (f : nat -> bool) n,
  (n > 0)%nat ->
  ((Σ (fun x => (-1) ^ f(x)) n) * / INR n)%C = 1 - 2 * INR (count0 f n) * / INR n.
Proof.
  unfold count0.
  intros.
  destruct n; try lia.
  clear H.
  induction n.
  simpl.
  destruct (f O); simpl; lca.
  repeat rewrite <- big_sum_extend_r in *.
  simpl count in *.
  remember (Σ (fun x : nat => (-1) ^ f x) n)%C as sum.
  clear Heqsum.
  rewrite Cmult_plus_distr_r.
  rewrite <- (Cmult_1_r (_ * / _)).
  rewrite <- (Cinv_r (INR (S n))).
  assert (forall a b c d, ((a * b) * (c * d))%C = ((a * d) * (c * b))%C).
  { intros. field. }
  rewrite H, IHn; clear.
  repeat rewrite plus_INR.
  rewrite <- RtoC_inv.
  rewrite RtoC_pow.
  repeat rewrite <- RtoC_mult.
  rewrite <- RtoC_plus.
  apply injective_projections; simpl; try reflexivity.
  field_simplify_eq.
  destruct (f (S n)); subst; simpl; lra.
  destruct n; try lra.
  repeat rewrite <- S_INR.
  split.
  4: apply C0_fst_neq; remember (S n) as Sn; simpl; subst.
  all: apply not_0_INR; lia.
Qed.

Lemma basis_vector_1_0 : basis_vector 1 0 = I 1.
Proof.
  unfold basis_vector, I.
  solve_matrix.
  bdestruct_all; reflexivity.
Qed.

(* In the Deutsch Jozsa problem we care about the probability of measuring ∣0...0⟩
   in the first n qubits (the last qubit always ends up in the ∣1⟩ state). *)
Local Opaque pow.
Lemma deutsch_jozsa_success_probability :
  forall {n : nat} (U : base_ucom (S n)) f,
  (n > 0)%nat ->
  boolean_oracle U f ->
  @prob_partial_meas n 1 (n ⨂ ∣0⟩) (uc_eval (deutsch_jozsa U) × (S n ⨂ ∣0⟩)) =
    (1 - 2 * INR (count0 f (2 ^ n)) * /2 ^ n) ^ 2.
Proof.
  unfold count0.
  intros n U f Hn H.
  unfold deutsch_jozsa.
  Opaque npar.
  simpl uc_eval.
  restore_dims.
  rewrite npar_H by lia.
  autorewrite with eval_db.
  bdestruct_all.
  replace (S n - (n + 1))%nat with O by lia.
  simpl I.
  Transparent npar.
  simpl.
  restore_dims.
  repeat (rewrite Mmult_assoc; restore_dims).
  Qsimpl. Qsimpl.
  rewrite H0_kron_n_spec_alt by auto.
  replace (hadamard × ∣1⟩) with ∣ - ⟩ by solve_matrix.
  restore_dims.
  distribute_scale.
  rewrite kron_Msum_distr_r.
  replace (2 ^ S n)%nat with (2 ^ n * 2)%nat by unify_pows_two.
  rewrite 2 Mmult_Msum_distr_l.
  erewrite big_sum_eq_bounded.
  2: { intros i Hi.
       restore_dims.
       distribute_plus.
       distribute_scale.
       unfold boolean_oracle in H.
       repeat rewrite Nat.mul_1_r.
       replace (2 ^ S n)%nat with (2 ^ n * 2)%nat in * by unify_pows_two.
       replace ∣ 0 ⟩ with ∣ Nat.b2n false ⟩ by reflexivity.
       rewrite (H i false) by assumption.
       replace ∣ 1 ⟩ with ∣ Nat.b2n true ⟩ by reflexivity.
       rewrite (H i true) by assumption.
       restore_dims.
       Qsimpl.
       rewrite <- 2 Mscale_kron_dist_r.
       rewrite <- kron_plus_distr_l.
       rewrite <- 2 Mscale_mult_dist_r.
       rewrite <- Mmult_plus_distr_l.
       replace (/ √ 2 .* ∣ false ⊕ f i ⟩ .+ - / √ 2 .* ∣ true ⊕ f i ⟩) with ((-1)^(f i) .* ∣ - ⟩).
       distribute_scale.
       rewrite Hminus_spec.
       rewrite <- Mscale_kron_dist_l.
       reflexivity.
       destruct (f i); simpl; lma. }
  rewrite <- kron_Msum_distr_r.
  rewrite <- Mscale_kron_dist_l.
  specialize (@partial_meas_tensor n 1) as H1.
  repeat rewrite Nat.pow_1_r in H1.
  rewrite H1; clear H1.
  2:{ split. auto with wf_db. apply bra1ket1. }
  unfold probability_of_outcome, inner_product.
  distribute_scale.
  rewrite Mmult_Msum_distr_l.
  erewrite big_sum_eq_bounded.
  2: { intros i Hi.
       rewrite basis_f_to_vec_alt by assumption.
       rewrite H_kron_n_spec by assumption.
       distribute_scale.
       rewrite Mmult_Msum_distr_l.
       erewrite big_sum_unique.
       2: { exists O.
            rewrite kron_n_0_is_0_vector.
            split; [lia | split].
            distribute_scale.
            restore_dims.
            rewrite basis_vector_product_eq by lia.
            reflexivity.
            intros j ? ?.
            distribute_scale.
            restore_dims.
            rewrite basis_vector_product_neq by lia.
            lma. }
       rewrite product_comm, nat_to_funbool_0, product_0.
       simpl.
       rewrite Mscale_1_l.
       rewrite Cmult_comm.
       rewrite <- Mscale_assoc.
       reflexivity. }
  rewrite Mscale_Msum_distr_r, Mscale_Msum_distr_l.
  restore_dims.
  distribute_scale.
  unfold scale, I; simpl.
  rewrite Cmult_1_r.
  rewrite <- Cinv_mult_distr by nonzero.
  rewrite <- RtoC_mult.
  rewrite sqrt_def.
  rewrite Cmult_comm.
  replace (2 ^ n)%R with (INR (2 ^ n)).
  rewrite sum_of_minus_1.
  rewrite Cmod_R.
  rewrite <- 2 Rsqr_pow2.
  rewrite <- Rsqr_abs.
  reflexivity.
  apply pow_positive. lia.
  rewrite pow_INR.
  reflexivity.
  apply pow_le; lra.
Qed.

(* accept := probability of measuring ∣0...0⟩ in the first n qubits is 1 *)
Definition accept {n : nat} (U : base_ucom (S n)) : Prop :=
   @prob_partial_meas n 1
      (n ⨂ ∣0⟩)
      (uc_eval (deutsch_jozsa U) × (S n ⨂ ∣0⟩)) = 1.

(* reject := probability of measuring ∣0...0⟩ in the first n qubits is 0 *)
Definition reject {n : nat} (U : base_ucom (S n)) : Prop :=
   @prob_partial_meas n 1
      (n ⨂ ∣0⟩)
      (uc_eval (deutsch_jozsa U) × (S n ⨂ ∣0⟩)) = 0.

Theorem deutsch_jozsa_correct :
  forall {n} (f : nat -> bool) (U : base_ucom (S n)),
  (n > 0)%nat -> boolean_oracle U f ->
  (constant f n -> accept U) /\ (balanced f n -> reject U).
Proof.
  intros n f0 U Hn Hb.
  unfold accept, reject.
  split; intro H.
  - rewrite deutsch_jozsa_success_probability with (f:=f0); auto.
    unfold constant in H.
    destruct H; rewrite H; simpl; try lra.
    replace (INR (2 ^ n)) with (2 ^ n).
    field. nonzero.
    rewrite pow_INR. reflexivity.
  - rewrite deutsch_jozsa_success_probability with (f:=f0); auto.
    destruct H as [_ H].
    rewrite H; simpl; try lra.
    replace (INR (2 ^ (n - 1))) with (2 ^ n / 2).
    field. nonzero.
    rewrite pow_INR.
    replace (INR 2) with 2 by reflexivity.
    field_simplify_eq.
    rewrite tech_pow_Rmult.
    replace (S (n - 1)) with n by lia.
    reflexivity.
Qed.

(** Proof of correctness #2 **)

(* Inductive definition of a boolean oracle. Note that in this definition
   the result bit is stored at the beginning rather than the end, so
   we have something like U : ∣ y ⟩∣ x ⟩ ↦ ∣ y ⊕ f(x) ⟩∣ x ⟩  *)
Inductive boolean : forall {n}, base_ucom (S n) -> Set :=
  | boolean_I : forall u, u ≡ SKIP -> @boolean 0 u
  | boolean_X : forall u, u ≡ X 0  -> @boolean 0 u
  | boolean_U : forall dim (u : base_ucom (S (S dim))) (u1 u2 : base_ucom (S dim)),
                boolean u1 -> boolean u2 ->
                uc_eval u = (uc_eval u1 ⊗ ∣0⟩⟨0∣) .+ (uc_eval u2 ⊗ ∣1⟩⟨1∣) ->
                boolean u.

(* TODO: Can we prove equivalence between these definitions? i.e.
     forall {n} (U : base_ucom (S n)),
       boolean U <-> exists f, boolean_oracle U f. *)

(* Slightly different version of DJ with the result bit at index 0. *)
Definition deutsch_jozsa' {n} (U : base_ucom n) : base_ucom n :=
  X 0 ; npar n U_H ; U; npar n U_H.

(* Counting for inductively defined oracles *)
Fixpoint count' {dim : nat} {u : base_ucom (S dim)} (P : boolean u) : nat :=
  match P with
  | boolean_I _ _ => 0
  | boolean_X _ _ => 1
  | boolean_U _ _ _ _ P1 P2 _ => (count' P1 + count' P2)
  end.

Definition balanced' {dim : nat} {u : base_ucom (S dim)} (P : boolean u) : Prop :=
  (dim > 0 /\ count' P = 2 ^ (dim - 1))%nat.

Definition constant' {dim : nat} {u : base_ucom (S dim)} (P : boolean u) : Prop :=
  (count' P = 0 \/ count' P = 2 ^ dim)%nat.

Local Transparent pow.
Lemma deutsch_jozsa_success_probability' :
  forall {n : nat} {U : base_ucom (S n)} (P : boolean U),
  ((∣1⟩ ⊗ n ⨂ ∣0⟩)† × (uc_eval (deutsch_jozsa' U)) × ((S n) ⨂ ∣0⟩)) O O =
      1 - 2 * INR (count' P) * /2 ^ n.
Proof.
  intros.
  unfold deutsch_jozsa'.
  rewrite kron_n_assoc by auto with wf_db.
  Opaque npar.
  (* initial rewriting to get rid of X, H gates *)
  simpl uc_eval. restore_dims.
  rewrite npar_H by lia.
  replace (S n - S n)%nat with O by lia.
  autorewrite with eval_db.
  bdestruct_all.
  simpl I.
  Msimpl_light.
  replace (n - 0)%nat with n by lia.
  rewrite kron_n_assoc by auto with wf_db.
  restore_dims.
  repeat rewrite Mmult_assoc.
  restore_dims.
  Qsimpl.
  replace (hadamard × ∣1⟩) with ∣ - ⟩ by solve_matrix.
  rewrite H0_kron_n_spec.
  rewrite <- Mmult_assoc.
  Qsimpl.
  replace (hadamard) with (hadamard†) by (Qsimpl; easy).
  rewrite <- kron_n_adjoint by auto with wf_db.
  repeat rewrite <- Mmult_adjoint.
  rewrite H0_kron_n_spec.
  replace (hadamard × ∣1⟩) with ∣ - ⟩ by solve_matrix.
  rewrite <- kron_adjoint.
  (* interesting part of the proof that looks at the structure of P *)
  induction n; dependent destruction P.
  - simpl. rewrite u0. clear.
    rewrite denote_SKIP; try lia.
    Msimpl_light. restore_dims.
    replace (∣ - ⟩† × ∣ - ⟩) with (I 1) by solve_matrix.
    lca.
  - simpl. rewrite u0. clear.
    autorewrite with eval_db; simpl.
    Msimpl_light. restore_dims.
    replace (∣ - ⟩† × (σx × ∣ - ⟩)) with (-1 .* I 1) by solve_matrix.
    lca.
  - simpl. rewrite e.
    restore_dims.
    repeat rewrite <- kron_assoc by auto with wf_db.
    restore_dims.
    setoid_rewrite kron_adjoint.
    rewrite Mmult_plus_distr_r.
    restore_dims.
    rewrite Mmult_plus_distr_l.
    repeat rewrite kron_mixed_product.
    replace ((∣+⟩) † × (∣0⟩⟨0∣ × ∣+⟩)) with ((1/2)%R .* I 1).
    replace ((∣+⟩) † × (∣1⟩⟨1∣ × ∣+⟩)) with ((1/2)%R .* I 1).
    repeat rewrite Mscale_kron_dist_r.
    rewrite <- Mscale_plus_distr_r.
    Msimpl_light. restore_dims.
    unfold scale, Mplus in *.
    setoid_rewrite (IHn u1 P1); try lia.
    setoid_rewrite (IHn u2 P2); try lia.
    clear.
    rewrite <- RtoC_plus, <- RtoC_mult.
    apply f_equal2; trivial.
    rewrite plus_INR.
    field_simplify_eq; trivial.
    nonzero.
    unfold xbasis_plus. solve_matrix.
    unfold xbasis_plus. solve_matrix.
Qed.

(* accept := probability of measuring ∣0...0⟩ in the last n qubits is 1 *)
Definition accept' {n : nat} {U : base_ucom (S n)} (P : boolean U) : Prop :=
  @probability_of_outcome (2 ^ (S n))
    (∣1⟩ ⊗ n ⨂ ∣0⟩)
    (uc_eval (deutsch_jozsa' U) × (S n ⨂ ∣0⟩)) = 1.

(* reject := probability of measuring ∣0...0⟩ in the last n qubits is 0 *)
Definition reject' {n : nat} {U : base_ucom (S n)} (P : boolean U) : Prop :=
  @probability_of_outcome (2 ^ (S n))
    (∣1⟩ ⊗ n ⨂ ∣0⟩)
    (uc_eval (deutsch_jozsa' U) × (S n ⨂ ∣0⟩)) = 0.

Local Opaque pow.
Theorem deutsch_jozsa_constant_correct' :
  forall (n : nat) (U : base_ucom (S n)) (P : boolean U), constant' P -> accept' P.
Proof.
  intros n U P H.
  unfold accept', probability_of_outcome.
  apply RtoC_inj.
  rewrite <- RtoC_pow, Cmod_sqr.
  unfold inner_product.
  restore_dims.
  rewrite <- Mmult_assoc.
  rewrite (deutsch_jozsa_success_probability' P).
  destruct H; rewrite H; simpl; try lca.
  autorewrite with RtoC_db R_db.
  rewrite Cconj_R.
  autorewrite with RtoC_db.
  apply f_equal2; try reflexivity.
  replace (INR (2 ^ n)) with (2 ^ n).
  field. nonzero.
  rewrite pow_INR.
  reflexivity.
Qed.

Theorem deutsch_jozsa_balanced_correct' :
  forall (n : nat) (U : base_ucom (S n)) (P : boolean U), balanced' P -> reject' P.
Proof.
  intros n U P [H1 H2].
  unfold reject', probability_of_outcome.
  apply RtoC_inj.
  rewrite <- RtoC_pow, Cmod_sqr.
  unfold inner_product.
  restore_dims.
  rewrite <- Mmult_assoc.
  rewrite (deutsch_jozsa_success_probability' P).
  rewrite H2; simpl.
  autorewrite with RtoC_db R_db.
  rewrite Cconj_R.
  autorewrite with RtoC_db.
  apply f_equal2; try reflexivity.
  replace (INR (2 ^ (n - 1))) with (2 ^ n / 2).
  field. nonzero.
  rewrite pow_INR.
  field_simplify_eq.
  rewrite tech_pow_Rmult.
  replace (S (n - 1)) with n by lia.
  reflexivity.
Qed.


Require Export P03.

(** For those who like a challenge, here is an exercise taken from the
    Coq'Art book by Bertot and Casteran (p. 123).  Each of the
    following four statements, together with [excluded_middle], can be
    considered as characterizing classical logic.  We can't prove any
    of them in Coq, but we can consistently add any one of them as an
    axiom if we wish to work in classical logic.

    Prove that all five propositions (these four plus
    [excluded_middle]) are equivalent. *)

Theorem excluded_middle_to_double_negation_elimination:
  excluded_middle -> double_negation_elimination.
Proof.
  unfold excluded_middle, double_negation_elimination.
  intros ex P neg. unfold not in neg. destruct (ex P).
  - apply H.
  - unfold not in H. apply neg in H. contradiction.
Qed.

Theorem double_negation_elimination_to_excluded_middle:
  double_negation_elimination -> excluded_middle.
Proof.
  unfold excluded_middle, double_negation_elimination.
  intros dn P. apply dn. intros H. apply H. right. intros H'. apply H. left. assumption.
Qed.


Require Import HoTT.
From GCTT Require Import finite_types permutations.

Section Sign.
  Lemma swap_fix_last {n : nat} (e : fintype n.+1 <~> fintype n.+1) :
    (swap_last e oE e) (inr tt) = inr tt.
  Proof.
    apply fin_transpose_last_with_with.
  Qed.

  (* First sign of transpositions with the last element *)
  Definition sgn_transpose {n : nat} (i : fintype n.+1) : (fintype 2 <~> fintype 2).
  Proof.
    destruct i as [i | []].
    (* i is a nontrivial transposition, and has sign τ *)
    - exact twist2.
    (* i is the trivial transposition and has sign ι *)
    - exact equiv_idmap.
  Defined.

  (** The sign of a permutations counts (modulo 2) how many nontrivial transpositions a permutation
   can be factorized into. *)
  Fixpoint sign (n : nat) :
    (fintype n <~> fintype n) -> (fintype 2 <~> fintype 2).
  Proof.
    intro e.
    (* For n = 0, the sign is trivial *)
    destruct n. { exact equiv_idmap. }
    exact (sgn_transpose (e (inr tt)) oE sign n (transpose_and_restrict e)).
  Defined.

  Lemma sgn_transpose_notlast {n : nat} (i : fintype n.+1) :
        (i <> inr tt) -> sgn_transpose i = twist2.
  Proof.
    intro nlast.
    destruct i as [i | []].
    - reflexivity.
    - destruct (nlast idpath).
  Qed.

  Definition sgn_id (m : nat) :
    sign m (equiv_idmap) = equiv_idmap.
  Proof.
    induction m.
    - reflexivity.
    - simpl. refine (_ @ IHm).
      refine (ecompose_1e _ @ _).
      apply (ap (sign m)).
      apply path_equiv. apply path_arrow.
      apply transpose_and_restrict_id.
  Qed.

  Lemma sgn2_is_id : sign 2 == idmap.
  Proof.
    intro e.
    unfold sign.
    assert (h : (transpose_and_restrict e) (inr tt) = inr tt).
    { recall ((transpose_and_restrict e) (inr tt)) as x eqn:p. rewrite p.
      destruct x as [[] | []]; reflexivity. }
    rewrite h. clear h.
    rewrite (ecompose_e1).
    recall (e (inr tt)) as x eqn:p. rewrite p. simpl.
    destruct x as [ [[] | []] | []]; apply inverse; apply path_equiv; apply path_arrow.
    - apply (sym2_notfixlast e p).
    - apply (sym2_fixlast e p).
  Qed.

  Definition sgn_beta_transpose (m : nat) (x y : fintype m) :
    (x <> y) -> sign m (fin_transpose x y) = twist2.
  Proof.
    intro neq.
    induction m.
    - destruct x.
    - change (sign m.+1 (fin_transpose x y))
             with
             (sgn_transpose (fin_transpose x y (inr tt)) oE
              sign m (transpose_and_restrict (fin_transpose x y))).
      destruct y as [y | []].
      + destruct x as [x | []].
        * rewrite
            (path_equiv (path_arrow _ _ (transpose_and_restrict_transpose_fixlast x y))).
          simpl.
          refine (ecompose_1e _ @ _).
          apply IHm. revert neq. apply functor_not.
          apply (ap inl).
        * rewrite (fin_transpose_beta_l).
          change (sgn_transpose (inl y)) with twist2.
          rewrite (path_equiv (path_arrow _ _
                      (fin_transpose_sym (n := m.+1) (inr tt) (inl y)))).
          rewrite (path_equiv (path_arrow _ _
                      (transpose_and_restrict_transpose_nfx (inl y)))).
          rewrite sgn_id. apply ecompose_e1.
      + rewrite (fin_transpose_beta_r).
        rewrite (path_equiv (path_arrow _ _
                      (transpose_and_restrict_transpose_nfx x))).
        rewrite (sgn_id). refine (ecompose_e1 _ @ _).
        destruct x as [x | []].
        * reflexivity.
        * destruct (neq idpath).
  Qed.

  (** The sign sends block sum to composition  *)
  Definition sgn_block_sum {m n : nat} (e1 : fintype m <~> fintype m) (e2 : fintype n <~> fintype n) :
    sign (n+m) (block_sum e1 e2) = sign n e2 oE sign m e1.
  Proof.
    induction n.
    - simpl.
      refine (_ @ (ecompose_1e _)^).
      apply (ap (sign m)).
      apply path_equiv. apply path_arrow. intro.
      apply (block_sum_beta_finl e1 e2 x).
    - simpl.
      rewrite (path_equiv (path_forall _ _ (transpose_and_restrict_block_sum e1 e2))).
      rewrite (IHn (transpose_and_restrict e2)).
      refine (ecompose_e_ee _ _ _ @ _).
      apply (ap (fun g =>
                   g oE sign n (transpose_and_restrict e2) oE
                     sign m e1)).
      cut (forall x : fintype n.+1,
              sgn_transpose (functor_sum (finr m n) idmap x) = sgn_transpose x).
      { intro H. apply H. }
      intros [x | x]; reflexivity.
  Qed.

  Lemma functor_sum_compose {A1 A2 A3 B1 B2 B3 : Type}
        (f1 : A1 -> A2) (f2 : A2 -> A3)
        (g1 : B1 -> B2) (g2 : B2 -> B3) :
    functor_sum (f2 o f1) (g2 o g1) == (functor_sum f2 g2) o (functor_sum f1 g1).
  Proof.
    intros [a | a]; reflexivity.
  Defined.

  Definition transpose_and_restrict_fixlast {n : nat}
             (e : fintype n.+1 <~> fintype n.+1)
             (fixlast : e (inr tt) = inr tt) :
    transpose_and_restrict e == equiv_restrict e fixlast.
  Proof.
    apply inj_equiv_plus1.
    intro x.
    refine (transpose_and_restrict_eta _ x @ _ @ (equiv_restrict_eta _ _ x)^).
    ev_equiv. unfold swap_last. rewrite fixlast.
    apply (fin_transpose_same_is_id (n := n.+1) (inr tt) (e x)).
  Defined.

  Lemma transpose_and_restrict_fixlast1 {n : nat}
             (e1 e2 : fintype n.+1 <~> fintype n.+1)
             (fixlast_1: e1 (inr tt) = inr tt) :
    transpose_and_restrict (e2 oE e1) ==
    (transpose_and_restrict e2) oE (transpose_and_restrict e1).
  Proof.
    apply inj_equiv_plus1.
    intro x.
    refine (transpose_and_restrict_eta _ x @ _).
    unfold swap_last. ev_equiv. rewrite fixlast_1.
    transitivity (((transpose_and_restrict e2 +E 1) oE (transpose_and_restrict e1 +E 1)) x).
    - ev_equiv.
      apply inverse.
      refine (transpose_and_restrict_eta e2 _ @ _). ev_equiv.
      apply (ap (swap_last e2)). apply (ap e2).
      refine (transpose_and_restrict_eta e1 _ @ _). ev_equiv.
      unfold swap_last. rewrite fixlast_1.
      apply (fin_transpose_same_is_id (n := n.+1)).
    - destruct x as [x | []]; reflexivity.
  Qed.

  Lemma transpose_and_restrict_fixlast2 {n : nat}
             (e1 e2 : fintype n.+1 <~> fintype n.+1)
             (fixlast_2 : e2 (inr tt) = inr tt) :
    transpose_and_restrict (e2 oE e1) ==
    (transpose_and_restrict e2) oE (transpose_and_restrict e1).
  Proof.
    apply inj_equiv_plus1.
    intro x.
    refine (transpose_and_restrict_eta _ _ @ _).
    refine (_ @ (functor_sum_compose _ _ idmap idmap x)^).
    refine (_ @ (transpose_and_restrict_eta e2 _)^).
    refine (_ @ (ap ((swap_last e2) o e2) (transpose_and_restrict_eta e1 x)^)).
    unfold swap_last. ev_equiv. rewrite fixlast_2.
    refine (_ @ (fin_transpose_same_is_id (n := n.+1) _ _ )^).
    apply inverse.
    refine (natural_fin_transpose (e1 (inr tt)) (inr tt) e2  _ @ _).
    rewrite fixlast_2. reflexivity.
  Qed.

  Lemma transpose_and_restrict_fixlast12 {n : nat}
             (e1 e2 : fintype n.+1 <~> fintype n.+1)
             (fixlast_12 : e2 (e1 (inr tt)) = inr tt) :
    transpose_and_restrict (e2 oE e1) ==
    (transpose_and_restrict e2) oE (transpose_and_restrict e1).
  Proof.
    apply inj_equiv_plus1.
    intro x.
    refine (transpose_and_restrict_eta _ _ @ _).
    refine (_ @ (functor_sum_compose _ _ idmap idmap x)^).
    refine (_ @ (transpose_and_restrict_eta e2 _)^).
    refine (_ @ (ap (swap_last e2 oE e2) (transpose_and_restrict_eta e1 x)^)).
    ev_equiv.
    refine (_ @ (ap (swap_last e2) (natural_fin_transpose (e1 (inr tt)) (inr tt) e2 (e1 x))^)).
    unfold swap_last. ev_equiv. rewrite fixlast_12.
    refine (fin_transpose_same_is_id (n := n.+1) (inr tt) _ @ _).
    rewrite (fin_transpose_sym (e2 (inr tt)) (inr tt)).
    refine ((fin_transpose_invol (n := n.+1) (inr tt) (e2 (inr tt)) _)^).
  Qed.

  Lemma transpose_and_restrict_nfx {n : nat}
        (e1 e2 : fintype n.+1 <~> fintype n.+1)
        (x2 x12: fintype n)
        (* (p1 : e1 (inr tt) = inl x1) *)
        (p2 : e2 (inr tt) = inl x2)
        (p12 : e2 (e1 (inr tt)) = inl x12) :
    transpose_and_restrict (e2 oE e1) ==
    (fin_transpose x2 x12)
      oE (transpose_and_restrict e2) oE (transpose_and_restrict e1).
  Proof.
    apply inj_equiv_plus1.
    intro x.
    refine (transpose_and_restrict_eta _ _ @ _).
    refine (_ @ (functor_sum_compose _ _ idmap idmap x)^).
    rewrite (functor_sum_compose (transpose_and_restrict e2) (fin_transpose x2 x12) idmap idmap).
    refine (_ @ ap ((functor_sum (fin_transpose x2 x12) idmap)
                      o (functor_sum (transpose_and_restrict e2) idmap))
              (transpose_and_restrict_eta e1 x)^).
    refine (_ @ ap (functor_sum (fin_transpose x2 x12) idmap)
              (transpose_and_restrict_eta e2 _)^).
    ev_equiv.
    assert (h : fin_transpose (e2 (inr tt)) (e2 (e1 (inr tt))) ==
            functor_sum (B := Unit) (fin_transpose x2 x12) idmap ).
    { rewrite p2.  rewrite p12. intro i. reflexivity. }
    refine (_ @ h _). clear h.
    unfold swap_last.  ev_equiv.

    rewrite (natural_fin_transpose (e1 (inr tt)) (inr tt) e2 (e1 x)).
    generalize (e2 (e1 x)). clear x. intro x.
    (* four cases: x = n+1, e2 (e1 (n+1)) = x, e2 (n+1) = x, and everything else *)
    destruct x as [x | []].
    - rewrite p12. rewrite p2.
      destruct (decidablepaths_fin n x12 x).
      + rewrite p.
        repeat rewrite fin_transpose_beta_l.
        apply inverse.
        apply fin_transpose_other; apply inr_ne_inl.
      + transitivity (inl Unit x).
        { apply fin_transpose_other.
          - revert n0. apply functor_not.
            intro p. exact (path_sum_inl Unit p^).
          - apply inl_ne_inr. }
        destruct (decidablepaths_fin n x2 x).
        * rewrite p.
          rewrite fin_transpose_beta_r.
          assert (h : fin_transpose (n := n.+1) (inl x) (inr tt) (inl x12) = inl x12).
          { apply fin_transpose_other; try (apply inl_ne_inr).
            revert n0. apply functor_not. apply path_sum_inl. }
          rewrite h. clear h.
          apply inverse.
          apply fin_transpose_beta_r.
        * assert (h : fin_transpose (n := n.+1) (inl x12) (inl x2) (inl x) = inl x).
          { apply fin_transpose_other;
              apply (functor_not (path_sum_inl Unit));
              apply (functor_not inverse).
            - exact n0. - exact n1. }
          rewrite h. clear h.
          assert (h : fin_transpose (n := n.+1) (inl x2) (inr tt) (inl x) = inl x).
          { apply fin_transpose_other; try (apply inl_ne_inr).
            apply (functor_not (path_sum_inl Unit)).
            apply (functor_not (inverse) n1). }
          rewrite h. clear h.
          apply inverse.
          apply fin_transpose_other;
            apply (functor_not (path_sum_inl Unit));
            apply (functor_not inverse).
          { exact n1. } { exact n0. }
    - rewrite fin_transpose_beta_r.
      rewrite p12.  rewrite p2.
      rewrite (fin_transpose_other (n := n.+1) (inl x12) (inl x2) (inr tt)
                                   (inr_ne_inl _ _) (inr_ne_inl _ _)).
      rewrite fin_transpose_beta_r. rewrite fin_transpose_beta_l.
      reflexivity.
  Qed.

  (** The sign preserves composition  *)
  Definition sgn_compose (n : nat) (e1 e2 : fintype n <~> fintype n) :
    sign n (e2 oE e1) = (sign n e2) oE (sign n e1).
  Proof.
    induction n. { reflexivity. }
    simpl. rewrite ecompose_e_ee.
    rewrite (ecompose_ee_e _ (sign n (transpose_and_restrict e2)) _).
    rewrite (symm_sym2 (sign n (transpose_and_restrict e2)) _).
    rewrite (ecompose_ee_e _ _ (sgn_transpose (e2 (inr tt)))).
    rewrite (ecompose_ee_e _ _ (sgn_transpose (e1 (inr tt)))).
    rewrite (ecompose_e_ee _ _ (sgn_transpose (e2 (inr tt)))).
    rewrite <- (IHn (transpose_and_restrict e1) (transpose_and_restrict e2)).
    recall (e1 (inr tt)) as x1 eqn:p1.
    destruct x1 as [x1 | []].
    - recall (e2 (e1 (inr tt))) as x12 eqn:p12.
         destruct x12 as [x12 | []].
      +  recall (e2 (inr tt)) as x2 eqn:p2.
         destruct x2 as [x2 | []].
         * rewrite (path_equiv (path_forall _ _
                                            (transpose_and_restrict_nfx e1 e2 x2 x12 p2 p12))).
           (* rewrite p12. rewrite p2. *)
           rewrite ecompose_ee_e.
           rewrite (IHn
                      (transpose_and_restrict e2 oE transpose_and_restrict e1) (fin_transpose x2 x12)).
           rewrite (ecompose_ee_e).
           rewrite p12. rewrite p2. simpl.
           apply (ap (fun g => twist2 oE g)).
           apply (ap
                    (fun g => g oE
                              sign n (transpose_and_restrict e2 oE transpose_and_restrict e1))).
           rewrite p1.
           apply (sgn_beta_transpose).
           apply (functor_not (ap (fun x => (inl Unit x)))).
           rewrite <- p12. rewrite <- p2.
           apply (functor_not (equiv_inj e2)). rewrite p1.
           apply inr_ne_inl.
        * (* rewrite p1. refine (_ @ sgn_id n). *)
          (* apply (ap (sign n)). *)
          (* assert (h : x2 = x12). *)
          (* { apply (path_sum_inl Unit). *)
          (*   rewrite <- p2. rewrite <- p12.  rewrite p1.  reflexivity. } *)
          (* rewrite h. clear h. *)
          (* apply path_equiv. apply path_arrow. apply fin_transpose_same_is_id. *)
          rewrite
            (path_equiv (path_arrow _ _ (transpose_and_restrict_fixlast2 e1 e2 p2))).
          apply (ap (fun g =>
                       g oE sign n (transpose_and_restrict e2 oE transpose_and_restrict e1))).
          rewrite p2. rewrite p1.
          simpl. rewrite ecompose_1e.
          apply sgn_transpose_notlast.
          rewrite <- p2.
          apply (functor_not (equiv_inj e2)).
          apply inl_ne_inr.
      + rewrite (path_equiv (path_arrow _ _
                     (transpose_and_restrict_fixlast12 e1 e2 p12))).
        apply (ap (fun g =>
                       g oE sign n (transpose_and_restrict e2 oE transpose_and_restrict e1))).
        rewrite p12. rewrite p1. simpl.
        apply emoveL_eM. rewrite ecompose_1e.
        simpl.
        apply inverse. rewrite twist2_inv.
        apply sgn_transpose_notlast.
        intro false.
        rewrite p1 in p12. apply (inl_ne_inr  x1 tt).
        apply (equiv_inj e2).
        exact (p12 @ false^).
    - rewrite (path_equiv (path_arrow _ _ (transpose_and_restrict_fixlast1 e1 e2 p1))).
      apply (ap (fun g =>
                       g oE sign n (transpose_and_restrict e2 oE transpose_and_restrict e1))).
      rewrite p1. simpl.
      refine (ecompose_e1 _)^.
  Qed.

End Sign.


(** 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 (y : natural) (x : natural) (lf2 : natural) : natural :=
  mult (Succ x) y.


Require Import Lia.

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


Require Import Arith.
Require Import Omega.
Require Import Psatz.

Require Import kernel_graph.
Require Import graph_examples.
Require Import kernel_numeric.

(* A walk in G from x to y. *)
Record walk (G : Graph) (x y : nat) := {
  walk_intermediate : nat ; (* stevilo vmesnih vozlisc *)
  walk_length := S (S walk_intermediate) ; (* stevilo vozlisc *)
  walk_func :> nat -> nat ;
  walk_in_graph : forall i, i < walk_length -> walk_func i < V G ;
  walk_connected : forall i, i < S walk_intermediate -> G (walk_func i) (walk_func (S i)) ;
  walk_start : walk_func 0 = x ;
  walk_end : walk_func (S walk_intermediate) = y
}.

Arguments walk_intermediate {_ _ _} _.
Arguments walk_length {_ _ _} _.

Theorem mini_walk (G : Graph) (n : nat) (p : n > 0) (x y : nat) (Wxy : walk G x y):
  walk_intermediate Wxy = n -> walk G x (walk_func G x y Wxy n).
Proof.
  intro Wxyinl.
  simple refine {| walk_intermediate := (n - 1) ;
                   walk_func := (walk_func G x y Wxy) |}.
  - intros i Ai.
    apply walk_in_graph.
    unfold walk_length.
    rewrite Wxyinl.
    omega.
  - intros i Ai.
    apply walk_connected.
    rewrite Wxyinl.
    omega.
  - apply walk_start.
  - replace (S (n - 1)) with n; auto.
    omega.
Qed.

Definition connected (G : Graph) :=
  forall x y, x < G -> y < G -> x < y -> walk G x y.

Lemma prove_for_one (P : nat -> Prop) (i : nat) :
  i < 1 -> P 0 -> P i.
Proof.
  intros H G.
  induction i.
  - assumption.
  - omega.
Qed.

Lemma prove_for_two (P : nat -> Prop) (i : nat) :
  i < 2 -> P 0 -> P 1 -> P i.
Proof.
  intros ilt2 H0 H1.
  induction i.
  - auto.
  - induction i.
    + auto.
    + omega.
Qed.

Lemma complete_connected (n : nat) : connected (K n).
Proof.
  intros x y xG yG x_lt_y.
  simple refine {| walk_intermediate := 0 ;
                   walk_func := (fun i => match i with
                                       | 0 => x
                                       | _ => y
                                       end) |}.
  - intros i H.
    pattern i.
    now apply prove_for_two.
  - intros i H.
    simpl ; pattern i.
    apply prove_for_one.
    + assumption.
    + omega.
  - reflexivity.
  - reflexivity.
Qed.

Lemma walk_transitive (G : Graph) (x y z : nat) :
  x < G -> y < G -> z < G ->
  walk G x y -> walk G y z -> walk G x z.
Proof.
  intros ? ? ? s t.
  assert (E : s (S (walk_intermediate s)) = t 0).
  { rewrite walk_start. apply walk_end. }
  simple refine {|
           walk_intermediate := S (walk_intermediate s + walk_intermediate t) ;
           walk_func := (fun i => if lt_dec i (walk_length s) then s i else t (S (i - walk_length s)))
         |}.
  - intros i ?.
    simpl.
    destruct (lt_dec i (walk_length s)).
    + now apply walk_in_graph.
    + apply walk_in_graph.
      unfold walk_length.
      omega.
  - intros i ? ; simpl.
    destruct (lt_dec i (walk_length s)) ; destruct (lt_dec (S i) (walk_length s)).
    + apply walk_connected.
      unfold walk_length in * ; omega.
    + replace i with (walk_length s - 1) in *.
      * { simpl.
          rewrite Nat.sub_diag.
          rewrite E.
          apply walk_connected.
          omega.
        }
      * omega.
    + omega.
    + unfold walk_length; simpl.
      replace (S (i - S (walk_intermediate s))) with (S (S (i - S (S (walk_intermediate s))))).
      * apply walk_connected.
        unfold walk_length in *.
        omega.
      * unfold walk_length in *.
        omega.
  - now apply walk_start.
  - simpl.
    unfold walk_length in *.
    destruct (lt_dec (S (S (walk_intermediate s + walk_intermediate t))) (S (S (walk_intermediate s)))).
    + omega.
    + rewrite minus_plus.
      apply walk_end.
Defined.

Lemma walk_symmetric (G : Graph) (x y : nat) :
  x < G -> y < G ->
  walk G x y -> walk G y x.
Proof.
  intros p q Wxy.
  simple refine {|
    walk_intermediate := walk_intermediate Wxy ;
    walk_func := (fun i => Wxy (walk_length Wxy - i - 1))
  |}; unfold walk_length.
  - intros i A.
    apply (walk_in_graph _ _ _ Wxy).
    unfold walk_length.
    omega.
  - intros i A.
    apply E_symmetric.
    + apply (walk_in_graph _ _ _ Wxy); unfold walk_length; omega.
    + apply (walk_in_graph _ _ _ Wxy); unfold walk_length; omega.
    + replace (S (S (walk_intermediate Wxy)) - i - 1) with
              (S (S (S (walk_intermediate Wxy)) - S i - 1)).
      * apply walk_connected.
        omega.
      * omega.
  - apply walk_end.
  - replace (S (S (walk_intermediate Wxy)) - S (walk_intermediate Wxy) - 1) with 0.
    + apply walk_start.
    + omega.
Qed.

Lemma path_is_connected (n : nat) : connected (Path n).
Proof.
  intros x y xG yG x_lt_y.
  simple refine {|
    walk_intermediate := y - x - 1;
    walk_func := (fun i => x + i)
  |}.
  - intros i A.
    omega.
  - intros i A.
    simpl.
    omega.
  - auto.
  - omega.
Qed.

Definition connectedA (G : Graph) :=
  forall x, 0 < x < G -> walk G 0 x.

Lemma same_conected_zero_or_smallerP2 (G : Graph) :
  connected G -> connectedA G.
Proof.
  unfold connected.
  intro Conn.
  unfold connectedA.
  intros x p.
  apply Conn; omega.
Qed.

Lemma same_conected_zero_or_smallerP1 (G : Graph) :
  connectedA G -> connected G.
Proof.
  unfold connectedA.
  intro ConnA.
  unfold connected.
  intros x y p q w.
  destruct (Nat.eq_dec x 0) as [A|B].
  - rewrite A.
    apply ConnA.
    omega.
  - assert (x > 0).
    + omega.
    + assert (walk G 0 x).
      * apply ConnA; omega.
      * assert (walk G 0 y).
        {
        apply ConnA; omega.
        }
        {
          assert (walk G x 0).
          - apply walk_symmetric; auto; omega.
          - apply (walk_transitive G x 0 y); auto; omega.
        }
Qed.

Definition connectedB (G : Graph) :=
  forall x y, x < G -> y < G -> not(x = y) -> walk G x y.

Lemma same_conected_smaller_or_allP2 (G : Graph) :
  connectedB G -> connected G.
Proof.
  unfold connectedB.
  intro ConnB.
  unfold connected.
  intros x y xP yP P.
  apply ConnB; omega.
Qed.

(*
Search (_ < _).
*)

Lemma same_conected_smaller_or_allP1 (G : Graph) :
  connected G -> connectedB G.
Proof.
  unfold connected.
  intro Conn.
  unfold connectedB.
  intros x y xP yP P.
  destruct (lt_eq_lt_dec x y) as [[A|B]|C].
  - apply Conn; auto.
  - absurd(x = y); auto.
  - apply walk_symmetric; auto.
Qed.

(* Search (_ = _). *)

Theorem color_dec (col : nat -> bool) (x : nat):
  {col x = false} + {col x = true}.
Proof.
  destruct (col x); auto.
Qed.

Definition idecomposable (G : Graph) :=
  forall col : nat -> bool, all x : G, all y : G,
  (col x = true -> col y = false ->
   some a : G, some b : G, (col a = true /\ col b = false /\ G a b)).

Theorem change_location_simple1 (n : nat) :
  forall col : nat -> bool,
  (col 0 = true -> col n = false ->
  some a : n, (col a = true /\ col (S a) = false)).
Proof.
  intros col xCol yCol.
  induction n.
  {
    rewrite yCol in xCol.
    absurd (false = true); auto.
  }
  {
    destruct (color_dec col n).
    - destruct IHn as [a [Aa H]]; auto.
      exists a.
      split.
      + omega.
      + apply H.
    - exists n.
      auto.
  }
Qed.

Theorem change_location_simple2 (n : nat) :
  forall col : nat -> bool,
  (col 0 = false -> col n = true ->
  some a : n, (col a = false /\ col (S a) = true)).
Proof.
  intros col xCol yCol.
  induction n.
  {
    rewrite yCol in xCol.
    absurd (false = true); auto.
  }
  {
    destruct (color_dec col n).
    - exists n.
      auto.
    - destruct IHn as [a [Aa H]]; auto.
      exists a.
      split.
      * omega.
      * apply H.
  }
Qed.

Theorem change_location_simple1x (x n : nat) (Ax : x < n):
  forall col : nat -> bool,
  (col x = true -> col n = false ->
  some a : n, (x <= a /\ col a = true /\ col (S a) = false)).
Proof.
  intros col xCol yCol.
  induction n.
  {
    omega.
  }
  {
    destruct (lt_eq_lt_dec x n) as [[H1|H2]|H3].
    {
      destruct (color_dec col n).
      - destruct IHn as [a [Aa H]]; auto.
        exists a.
        split.
        * omega.
        * apply H.
      - exists n.
        split; auto.
        split; auto.
        omega.
    }
    {
      exists x.
      replace x with n in *.
      auto.
    }
    {
      omega.
    }
  }
Qed.

Theorem change_location_simple2x (x n : nat) (Ax : x < n):
  forall col : nat -> bool,
  (col x = false -> col n = true ->
  some a : n, (x <= a /\ col a = false /\ col (S a) = true)).
Proof.
  intros col xCol yCol.
  induction n.
  {
    omega.
  }
  {
    destruct (lt_eq_lt_dec x n) as [[H1|H2]|H3].
    {
      destruct (color_dec col n).
      - exists n.
        split; auto.
        split; auto.
        omega.
      - destruct IHn as [a [Aa H]]; auto.
        exists a.
        split.
        * omega.
        * apply H.
    }
    {
      exists x.
      replace x with n in *.
      auto.
    }
    {
      omega.
    }
  }
Qed.

Theorem change_location (n : nat):
  forall col : nat -> bool, all x : n, all y : n,
  (col x = true -> col y = false ->
   some a : (n - 1), (
  (col a = true /\ col (S a) = false) \/
  (col a = false /\ col (S a) = true))).
Proof.
  induction n.
  {
    intros col x Ax y Ay xCol yCol.
    omega.
  }
  {
    intros col x Ax y Ay xCol yCol.
    destruct (lt_eq_lt_dec x y) as [[H1|H2]|H3].
    - pose (change_location_simple1x x y H1 col xCol yCol) as CLS1x.
      destruct CLS1x as [a H].
      destruct H as [Aay [Axa [aCol saCol]]].
      exists a.
      split.
      + omega.
      + auto.
    - replace x with y in *.
      rewrite yCol in xCol.
      absurd (false = true); auto.
    - pose (change_location_simple2x y x H3 col yCol xCol) as CLS2x.
      destruct CLS2x as [a [Aay [Axa [aCol saCol]]]].
      exists a.
      split.
      + omega.
      + auto.
  }
Qed.

Theorem change_location_function (n : nat) (An : n > 1):
  forall col : nat -> bool, (forall f : nat -> nat,
  col (f 0) = true -> col (f (n-1)) = false ->
   some a : (n - 1), (
  (col (f a) = true /\ col (f (S a)) = false) \/
  (col (f a) = false /\ col (f (S a)) = true))).
Proof.
  intros col f.
  apply (change_location n (fun x => col (f x))); omega.
Qed.

Arguments walk_func {_ _ _} _ _.

Theorem walk_idecomposable
  (G : Graph) (col : nat -> bool) (x y n : nat)
  (An : n > 1) (Wxy : walk G x y) :
  walk_length Wxy = n ->
  (col x = true -> col y = false ->
   some a : (n - 1), (
  (col ((walk_func Wxy) a) = true /\ col ((walk_func Wxy) (S a)) = false) \/
  (col ((walk_func Wxy) a) = false /\ col ((walk_func Wxy) (S a)) = true))).
Proof.
  intros Wxylen xCol yCol.
  apply change_location_function.
  - assumption.
  - replace x with (walk_func Wxy 0) in xCol.
    + assumption.
    + apply walk_start.
  - replace y with (walk_func Wxy (n - 1)) in yCol.
    + assumption.
    + replace (n - 1) with (S (walk_intermediate Wxy)).
      * apply walk_end.
      * rewrite <- Wxylen.
        unfold walk_length.
        omega.
Qed.

Theorem connected_then_idecomposable (G : Graph) :
  connected G -> idecomposable G.
Proof.
  unfold connected.
  intro Conn.
  unfold idecomposable.
  intros col x xA y yA xCol yCol.
  assert (walk G x y) as Wxy.
  {
    destruct (lt_eq_lt_dec x y) as [[H1|H2]|H3].
    - apply Conn; auto.
    - replace y with x in yCol.
      absurd (col x = true); auto.
      rewrite yCol.
      auto.
    - apply walk_symmetric; auto.
  }
  {
    assert (some a : (walk_length Wxy -1), (
      (col ((walk_func Wxy) a) = true /\ col ((walk_func Wxy) (S a)) = false) \/
      (col ((walk_func Wxy) a) = false /\ col ((walk_func Wxy) (S a)) = true)))
      as H.
    {
      apply walk_idecomposable.
      - unfold walk_length.
        omega.
      - auto.
      - assumption.
      - assumption.
    }
    {
      destruct H as [q [Aq [[H0 H1]|[H2 H3]]]].
      {
        exists (Wxy q).
        split.
        - apply walk_in_graph.
          omega.
        - exists (Wxy (S q)).
          split.
          + apply walk_in_graph.
            omega.
          + split; auto; split; auto.
            apply walk_connected.
            unfold walk_length in Aq.
            omega.
      }
      {
        exists (Wxy (S q)).
        split.
        - apply walk_in_graph.
          omega.
        - exists (Wxy q).
          split.
          + apply walk_in_graph.
            omega.
          + split; auto; split; auto.
            apply (E_symmetric G).
            * apply walk_in_graph.
              omega.
            * apply walk_in_graph.
              omega.
            * apply walk_connected.
              unfold walk_length in Aq.
              omega.
      }
    }
  }
Qed.

Definition increasing_connected_graph (G : Graph) :=
  (forall x : nat, (0 < x < (V G) -> some y : x, (E G x y))).

(*
Theorem increasing_connected_then_connected (G : Graph) :
  increasing_connected_graph G -> connectedA G.
Proof.
  unfold increasing_connected_graph.
  intro ICG.
  unfold connectedA.
  intros x Ax.
  pose (ICG x Ax) as H.
  destruct H.
*)

Definition idecomposableA (G : Graph) :=
  all x : G, all y : G, forall col : nat -> bool,
  (col x = true -> col y = false ->
   some a : G, some b : G, (col a = true /\ col b = false /\ G a b)).

Theorem idecomposable_then_idecomposableA (G : Graph) :
  idecomposable G -> idecomposableA G.
Proof.
  unfold idecomposable.
  intro Idec.
  unfold idecomposableA.
  intros x Ax y Ay col.
  apply Idec; omega.
Qed.

Theorem idecomposableA_then_someone_to_zero (G : Graph) (y : nat):
  idecomposableA G ->
  0 < y < G ->
  some x : V G, G 0 x.
Proof.
  unfold idecomposableA.
  intros Idec H.
  assert (0 < G) as A0. omega.
  assert (y < G) as Ay. omega.
  set (col := (fun i => match i with
                 | 0 => true
                 | _ => false
               end)).
  assert (col 0 = true) as Col0. auto.
  assert (y <> 0). omega.
  assert (exists y0 : nat, y = S y0). exists (y - 1). omega.
  destruct H1.
  assert (col y = false) as yCol. rewrite H1. auto.
  pose (Idec 0 A0 y Ay col Col0 yCol) as Idec0y.
  destruct Idec0y as [a [Aa [b [Bb K]]]].
  destruct (Nat.eq_dec 0 a).
  - exists b.
    rewrite <- e in K.
    split; auto.
    apply K.
  - absurd (col a = true).
    + assert (a > 0).
      * omega.
      * assert (exists a0 : nat, a = S a0). exists (a - 1). omega.
        destruct H3.
        assert (col a = false). rewrite H3. auto.
        rewrite H4. auto.
    + apply K.
Qed.

Record connected_subgraph (G : Graph) (n : nat) := {
  cs_size := n ;
  cs_col : nat -> bool ;
  cs_size_proof : sum' (V G) (fun x => if cs_col x then 1 else 0) = cs_size ;
  cs_connected_proof : all x : (V G), all y : (V G), (
    cs_col x = true-> cs_col y = true -> walk G x y)
}.

Theorem sum_max_simple (n : nat) (f : nat -> bool) :
  sum' n (fun x => if f x then 1 else 0) <= n.
Proof.
  induction n.
  - auto.
  - rewrite sum'_S.
    assert ((if f n then 1 else 0) <= 1).
    + destruct (f n); omega.
    + omega.
Qed.

Theorem sum_end (n : nat) (f : nat -> bool)
  (P : sum' n (fun x => if f x then 1 else 0) = n) :
  all y : n, ((fun x => if f x then 1 else 0) y = 1).
Proof.
  induction n.
  {
    intros y Ay.
    omega.
  }
  {
    rewrite sum'_S in P.
    destruct (color_dec f n).
    - destruct (f n).
      + absurd (false = true); auto.
      + pose (sum_max_simple n f).
        absurd (true = true); omega. (* ni v cilju ampak predpostavke *)
    - destruct (f n) in P.
      + assert (sum' n (fun x : nat => if f x then 1 else 0) = n).
        * omega.
        * assert (all y : n, ((if f y then 1 else 0) = 1)) as HH; auto.
          intros y Ay.
          destruct (Nat.eq_dec y n).
          {
            destruct (color_dec f y).
            - rewrite e0 in e1. rewrite e in e1. absurd (false = true); auto.
            - destruct (f y); auto; absurd (false = true); auto.
          }
          {
            apply HH.
            omega.
          }
      + absurd (0 + sum' n (fun x : nat => if f x then 1 else 0) = S n); auto.
        pose (sum_max_simple n f).
        omega.
  }
Qed.

Theorem sum_end_f (n : nat) (f : nat -> bool)
  (P : sum' n (fun x => if f x then 1 else 0) = n) :
  all y : n, (f y = true).
Proof.
  intros y Ay.
  pose (sum_end n f P y Ay).
  assert ((if f y then 1 else 0) = 1).
  - apply e.
  - destruct (f y); auto.
    omega.
Qed.

Theorem conected_subgraph_connected (G : Graph):
  connected_subgraph G (V G) -> connected G.
Proof.
  intro ConnSub.
  unfold connected.
  intros x y Ax Ay Axy.
  pose (cs_connected_proof G (V G) ConnSub x Ax y Ay) as H.
  pose (cs_size_proof G (V G) ConnSub).
  apply H.
  - apply (sum_end_f (V G)).
    + unfold cs_size in e; auto.
    + apply Ax.
  - apply (sum_end_f (V G)).
    + unfold cs_size in e; auto.
    + apply Ay.
Qed.

Theorem conected_subgraph_extend (G : Graph) (n : nat) (P : 1 + n < (V G)):
  idecomposable G -> connected_subgraph G n -> connected_subgraph G (1 + n).
Proof.
  unfold idecomposable.
  intros Idec ConnSub.
  set (col := (cs_col G n ConnSub)).
  (* sedaj potrebujemo nek x barve true in nek y barve false
     potem poiscemo vozlisce b in dodamo novo barvo col'
     ki je enaka povsod razen v vozliscu b je true
     tako smo dobili vecji povezan podgarf
  *)
  pose (Idec col).

Theorem idecomposable_extend (G : Graph) :
  idecomposable G -> connectedA G.

Theorem idecomposable_then_connectedA (G : Graph) :
  idecomposable G -> connectedA G.
Proof.
  unfold idecomposable.
  intro Idec.
  unfold connectedA.
  intros x Ax.
  assert (0 < V G) as B0.
  {
    omega.
  }
  {
    assert (x < V G) as Bx.
    - omega.
    - pose (Idec 0 B0 x Bx).
  }

Theorem idecomposable_then_connected (G : Graph) :
  idecomposable G -> connected G.
Proof.
  unfold idecomposable.
  intro Idec.
  unfold connected.
  intros x y Ax Ay Axy.

(**

Theorem connected_then_idecomposable (G : Graph) :
  connected G -> idecomposable G.
Proof.
  unfold connected.
  intro Conn.
  unfold idecomposable.
  intros col x xA y yA xCol yCol.
  assert (walk G x y) as Wxy.
  {
    destruct (lt_eq_lt_dec x y) as [[H1|H2]|H3].
    - apply Conn; auto.
    - replace y with x in yCol.
      absurd (col x = true); auto.
      rewrite yCol.
      auto.
    - apply walk_symmetric; auto.
  }
  {
    set (qqq := walk_intermediate Wxy).
    induction (walk_intermediate Wxy).
    {
    exists x.
    split; auto.
    exists y.
    split; auto.
    split; auto.
    split; auto.
    assert (walk_func Wxy 0 = x).
    - apply walk_start.
    - assert (walk_func Wxy (S (walk_intermediate Wxy)) = y).
      + apply walk_end.
      + assert (walk_intermediate Wxy = 0) as IH0.
        * replace (walk_intermediate Wxy) with qqq; auto.
          admit.
        * rewrite IH0 in H0.
          rewrite <- H. (* to pomeni da naredis revrite H iz druge strani*)
          rewrite <- H0.
          apply walk_connected.
          rewrite IH0.
          auto.
    }
    {

    }
  }
Admitted.

  (col : nat -> bool) (x y : nat)
  (Ax : x < (V G)) (Ay : y < (V G))
  (xCol : col x = true) (yCol : col y = false) (Wxy : walk G x y):
  (walk_intermediate Wxy = n) ->
  (some i : (walk_length Wxy),
  ((col (walk_func Wxy i) = true /\ col (walk_func Wxy (S i)) = false) \/
  (col (walk_func Wxy i) = false /\ col (walk_func Wxy (S i)) = true))).
Proof.
  revert Wxy.
  revert yCol xCol Ay Ax.
  revert y.
  unfold walk_length.
  induction n.

Theorem walk_idecomposable (G : Graph) (n : nat)
  (col : nat -> bool) (x y : nat)
  (Ax : x < (V G)) (Ay : y < (V G))
  (xCol : col x = true) (yCol : col y = false) (Wxy : walk G x y):
  (walk_intermediate Wxy = n) ->
  (some i : (walk_length Wxy),
  ((col (walk_func Wxy i) = true /\ col (walk_func Wxy (S i)) = false) \/
  (col (walk_func Wxy i) = false /\ col (walk_func Wxy (S i)) = true))).
Proof.
  revert Wxy.
  revert yCol xCol Ay Ax.
  revert y.
  unfold walk_length.
  induction n.

Theorem walk_idecomposable (G : Graph) (n : nat)
  (col : nat -> bool) (x y : nat)
  (Ax : x < (V G)) (Ay : y < (V G))
  (AWxy : walk_func Wxy x < walk_func Wxy y)
  (xCol : col x = true) (yCol : col y = false) (Wxy : walk G x y):
  (walk_intermediate Wxy = n) ->
  (some i : (walk_length Wxy),
  (col (walk_func Wxy i) = true /\ col (walk_func Wxy (S i)) = false)).
Proof.
  revert Wxy.
  revert yCol xCol Ay Ax.
  revert y.
  unfold walk_length.
  induction n.
  {
    intros y yCol xCol Ay Ax.
    intro Wxy.
    intro Wxyinl.
    rewrite Wxyinl.
    exists 0.
    rewrite walk_start.
    split; auto.
    replace 1 with (S (walk_intermediate Wxy)).
    - split; auto.
      rewrite walk_end; auto.
    - rewrite Wxyinl; auto.
  }
  {
    intros y yCol xCol Ay Ax.
    intro Wxy.
    intro Wxyinl.
    rewrite Wxyinl.
    destruct (color_dec col (walk_func Wxy (S n))) as [yPredF|yPredT].
    - (* set (yPred := walk_func Wxy (S (S n))). *)
      assert (walk G x (walk_func Wxy (S n))) as mWxy.
      + {
          simple refine {| walk_intermediate := n;
                           walk_func := (walk_func Wxy) |}.
          - intros i Ai.
            apply walk_in_graph.
            unfold walk_length.
            rewrite Wxyinl.
            omega.
          - intros i Ai.
            apply walk_connected.
            rewrite Wxyinl.
            omega.
          - apply walk_start.
          - omega.
        }
        (*
        apply mini_walk; auto.
        omega.
        *)
      + assert (walk_intermediate mWxy = n) as mWxinl.
        {
          admit.
        }
        {
          assert (some i : S (S (walk_intermediate mWxy)),
                 (col (mWxy i) = true /\ col (mWxy (S i)) = false)).
          * apply IHn; auto.
            {
              apply walk_in_graph.
              unfold walk_length.
              rewrite Wxyinl.
              omega.
            }
            {
              destruct (Nat.eq_dec x (walk_func Wxy (S n))).
              - replace (Wxy (S n)) with x in *.
                rewrite yPredF in xCol.
                absurd (false = true); auto.
              - assert (walk_func Wxy (S (S n)) = y).
                + rewrite <- Wxyinl.
                  apply walk_end.
                + rewrite <- H in Ax.
                  destruct (lt_eq_lt_dec x (Wxy (S n))) as [[H1|H2]|H3]; auto.
                  * absurd (x = Wxy (S n)); auto.
                  * (admited****)
(**
            }
          * rewrite mWxinl in H.
            destruct H as [i [Ai [j [Aj H0]]]].
            exists i.
            split; auto.
            exists j.
            split; auto.
            assert (walk_func mWxy = walk_func Wxy) as same_func.
            {
              admit.
            }
            {
              rewrite same_func in H0.
              auto.
            }
        }
    -
  }

*)
(*
Theorem walk_idecomposable (G : Graph) (*(n : nat)*) (col : nat -> bool) (x y : nat)
  (Ax : x < (V G)) (Ay : y < (V G))
  (Wxy : walk G x y)
  (xCol : col x = true) (yCol : col y = false):
  (*n = walk_intermediate Wxy ->*)
  (some i : (walk_length Wxy),
  (some j : (walk_length Wxy),
  (col (walk_func Wxy i) = true /\ col (walk_func Wxy j) = false))).
Proof.
  unfold walk_length.
  (* pose (walk_end G x y Wxy). *)
  (**intro An.**)
  induction (walk_intermediate Wxy).
  {
    exists 0.
    split; auto.
    rewrite walk_start.
    exists 1.
    split; auto.
    assert (walk_func Wxy 1 = y) as Wf1y.
    - replace 1 with (S (walk_intermediate Wxy)).
      + apply (walk_end G x y Wxy).
      + unfold walk_intermediate.
        admit.
    - rewrite Wf1y.
      auto.
  }
  {

  }

Theorem change_location_functionB (n : nat) (f : nat -> nat):
  forall col : nat -> bool, all x : n, all y : n,
  (col (f x) = true -> col (f y) = false ->
   some a : n, (
  (col (f a) = true /\ col (f (S a)) = false) \/
  (col (f a) = false /\ col (f (S a)) = true))).
Proof.
  intro col.
  apply (change_location n (fun x => col (f x))).
Qed.

Theorem change_location_functionA (n : nat) :
  forall col : nat -> bool, all x : n, all y : n,
  (forall f : nat -> nat,
  (col (f x) = true -> col (f y) = false ->
   some a : n, (
  (col (f a) = true /\ col (f (S a)) = false) \/
  (col (f a) = false /\ col (f (S a)) = true)))).
Proof.
  intros col x Ax y Ay f.
  apply change_location_function; auto.
Qed.

(* Search (_ < _).*)

(* Search ((_ < _) -> (_ < _) -> (_ < _)). *)

Arguments walk_func {_ _ _} _ _.

Theorem walk_idecomposable
  (G : Graph) (col : nat -> bool) (x y n : nat)
  (Ax : x < n) (Ay : y < n) (Wxy : walk G x y) :
  walk_length Wxy = n ->
  (col ((walk_func Wxy) x) = true -> col ((walk_func Wxy) y) = false ->
   some a : n, (
  (col ((walk_func Wxy) a) = true /\ col ((walk_func Wxy) (S a)) = false) \/
  (col ((walk_func Wxy) a) = false /\ col ((walk_func Wxy) (S a)) = true))).
Proof.
  intro Wxylen.
  apply change_location_functionA; auto.
Qed.

Theorem walk_idecomposableA
  (G : Graph) (col : nat -> bool) (x y n : nat) (Wxy : walk G x y) :
  walk_length Wxy = n ->
  (col x = true -> col y = false ->
   some a : n, (
  (col ((walk_func Wxy) a) = true /\ col ((walk_func Wxy) (S a)) = false) \/
  (col ((walk_func Wxy) a) = false /\ col ((walk_func Wxy) (S a)) = true))).
Proof.
  intros Wxylen xCol yCol.
  replace x with (walk_func Wxy 0) in xCol.
  replace y with (walk_func Wxy (S (walk_intermediate Wxy))) in yCol.
  - pose (change_location_functionA (walk_length Wxy) col (Wxy 0)).
Qed.
**)

(*
Theorem idecomposableA_then_someone_to_zero (G : Graph) :
  idecomposableA G -> 0 < V G -> some x : V G, G 0 x.
Proof.
  unfold idecomposableA.
  intros Idec Ag.
  destruct (lt_eq_lt_dec 0 (V G - 1)) as [[H1|H2]|H3].
  - pose (Idec 0 Ag).

  - admit.
  - omega.
  *)


(*Benjamin Bracquier et Lilian Soler*)
(**
Objectif de ce suppport de TD :
familiarisation avec les AST winstr pour le langage WHILE.
*)

(* ------------------------------------------------------------ *)
(** * Familiarisation avec les AST winstr pour le langage WHILE *)

(** ** Syntaxe abstraite *)
Inductive aexp :=
| Aco : nat -> aexp (* constantes *)
| Ava : nat -> aexp (* variables *)
| Apl : aexp -> aexp -> aexp
| Amu : aexp -> aexp -> aexp
| Amo : aexp -> aexp -> aexp
.

Inductive bexp :=
| Btrue : bexp
| Bfalse : bexp
| Bnot : bexp -> bexp
| Band : bexp -> bexp -> bexp
| Bor : bexp -> bexp -> bexp
| Beq : bexp -> bexp -> bexp (* test égalité de bexp *)
| Beqnat : aexp -> aexp -> bexp (* test égalité d'aexp *)
.

Inductive winstr :=
| Skip   : winstr
| Assign : nat -> aexp -> winstr
| Seq    : winstr -> winstr -> winstr
| If     : bexp -> winstr -> winstr -> winstr
| While  : bexp -> winstr -> winstr
.

(** Le langage IMP : comme WHILE mais sans While *)
Inductive instr :=
| ISkip   : instr
| IAssign : nat -> aexp -> instr
| ISeq    : instr -> instr -> instr
| IIf     : bexp -> instr -> instr -> instr
.

(** Définir les AST des programmes suivants *)
(** x3 := 5 * x2 *)
Example P1 : instr := IAssign 3 (Amu (Aco 5) (Ava 2)).

(** x2 := x2 + 1 *)
Example P2 : instr := IAssign 2 (Apl (Ava 2) (Aco 1)).

(** if x1 = x3 then (x2 := x2 + 1; x2 := x2 + 1) else x3 := 5 * x2 *)
Example P3 : instr := IIf (Beqnat (Ava 1) (Ava 3)) (ISeq (IAssign 2 (Apl (Ava 2) (Aco 1))) (IAssign 2 (Apl (Ava 2) (Aco 1)))) (IAssign 3 (Amu (Aco 5)  (Ava 2))).

(** ** Sémantique fonctionnelle *)

Inductive state :=
  | Nil : state
  | Cons : nat -> state -> state
.

(** On se donne des notations préalables pour faciliter la présentation *)
Notation "[]" := Nil.
Notation "x :: y" := (Cons x y).

(** L'appel [get i s] rend la valeur associée à xi dans l'état s *)
Fixpoint get (i: nat) (s: state) : nat :=
  match s with
  | []     => 0
  | v :: s' =>
    match i with
    | O => v
    | S i' => get i' s'
    end
  end.

(** *** Sémantique fonctionnelle de aexp*)
Fixpoint evalA (a: aexp) (s: state) : nat :=
  match a with
  | Aco n => n
  | Ava x => get x s
  | Apl a1 a2 =>  evalA a1 s + evalA a2 s
  | Amu a1 a2 =>  evalA a1 s * evalA a2 s
  | Amo a1 a2 =>  evalA a1 s - evalA a2 s
  end.

(** *** Sémantique fonctionnelle de bexp*)
Definition eqboolb b1 b2 : bool :=
  match b1, b2  with
  | true, true   => true
  | false, false => true
  | _ , _        => false
  end.

Fixpoint eqnatb n1 n2 : bool :=
   match n1, n2 with
  | O, O         => true
  | S n1', S n2' => eqnatb n1' n2'
  | _, _         => false
  end.

 Fixpoint evalB (b : bexp) (s : state) : bool :=
  match b with
  | Btrue => true
  | Bfalse => false
  | Bnot b => negb (evalB b s)
  | Band e1 e2 => (evalB e1 s) && (evalB e2 s)
  | Bor e1 e2 => (evalB e1 s) || (evalB e2 s)
  | Beq e1 e2 => eqboolb (evalB e1 s) (evalB e2 s)
  | Beqnat n1 n2 => eqnatb (evalA n1 s) (evalA n2 s)
  end.

(** *** Sémantique fonctionnelle de IMP *)

(** La mise à jour d'une variable [v] par un nouvel entier [n]
    dans un état [s] s'écrit [update s v n'].
    Cette fonction n'échoue jamais et écrit la valeur à sa place même
    si elle n'est pas encore définie dans l'état [s]. *)

(** À définir en TD *)
(** [update i v s] rend l'état dans lequel xi vaut [v],
    les valeurs des autres variables étant celles de [s].
    Attention à bien traiter tous les cas, notament ceux
    où l'état est représenté par une liste vide : tout se passe
    comme si, à la place, on avait une liste comprenant
    suffisamment de 0 (valeur par défaut).
 *)
Fixpoint update (i:nat) (v:nat) (s:state) : state :=
  match i with
  |O => match s with
        |[] => v::[]
        |v'::s' =>v::s'
        end
  |S i' => match s with
           |[] => 0::update i' v []
           |v'::s' =>v':: update i' v s'
           end
  end.

(** Quelques états pour faire des tests *)
(** S1 est un état dans lequel la variable "x0" vaut 1 et la variable "x1"
    vaut 2 et toutes les autres valent 0 (valeur par défaut) *)

Example S1 := 1 :: 2 :: Nil.
Example S2 := 0 :: 3 :: Nil.
Example S3 := 0 :: 7 :: 5 :: 41 :: Nil.

Example S4 :=
  let s1 := update 4 1 S1 in
  let s2 := update 3 2 s1 in
  let s3 := update 2 3 s2 in
  let s4 := update 2 3 s3 in
  update 0 5 s4.
Example test_S4 : S4 = 5 :: 2 :: 3 :: 2 :: 1 :: [].
Proof. reflexivity. Qed. (*reflexivity. Qed.*)

(** Peut s'écrire dans une premier temps avec update laissé "Admitted". *)
Fixpoint evalI (i : instr) (s : state) : state :=
  match i with
  | ISkip       => s
  | IAssign x a => update x (evalA a s) s
  | ISeq i1 i2  => evalI i2 (evalI i1 s)
  | IIf b i1 i2 => if evalB b s then evalI i1 s else evalI i2 s
  end.

(** La pré-commande "Fail" indique que l'on s'attend à un échec *)
(** La présence de [{struct i}] indique que l'argument devant
    décroître structurellement est [i] ;
    Pour [evalI] on aurait pu le préciser aussi mais Coq a su
    reconstruire cette information à partir du corps de la fonction.
*)
Fail Fixpoint evalW (i : winstr) (s : state) {struct i} : state :=
  (** à compléter, en expliquant le diagnostic rendu par Coq *)
  match i with
  | Skip       => s
  |Assign x a => update x (evalA a s) s
  |Seq i1 i2 => evalW i2 (evalW i1 s)
  |If b i1 i2 => if evalB b s then evalW i1 s else evalW i2 s
  |While b i => if evalB b s then evalW (While b i) (evalW i s) else s
  end.

(** ** Tests *)

Example test1 : evalI P1 S1 = 1 :: 2 :: 0 :: 0 :: [].
Proof. reflexivity. Qed.

Example test2 : evalI P1 S4 = 5 :: 2 :: 3 :: 15 :: 1 :: [].
Proof. reflexivity. Qed.

Example test3 : evalI P3 S1 = 1 :: 2 :: 0 :: 0 :: [].
Proof. reflexivity. Qed.

Example test4 : evalI P3 S4 = 5 :: 2 :: 5 :: 2 :: 1 :: [].
Proof. reflexivity. Qed.