(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(***********************************************************************
    Summation.v from Z to Z
 *********************************************************************)
Require Import Arith.
Require Import ArithRing.
Require Import ListAux.
Require Import ZArith.
Require Import Lia.
Require Import Iterator.
Require Import ZProgression.

Open Scope Z_scope.
(* Iterated Sum *)

Definition Zsum :=
   fun n m f =>
   if Zle_bool n m
     then iter 0 f Zplus (progression Z.succ n (Z.abs_nat  ((1 + m) - n)))
     else iter 0 f Zplus (progression Z.pred n (Z.abs_nat  ((1 + n) - m))).
Global Hint Unfold Zsum : core.

Lemma Zsum_nn: forall n f,  Zsum n n f = f n.
intros n f; unfold Zsum; rewrite Zle_bool_refl.
replace ((1 + n) - n) with 1; auto with zarith.
simpl; ring.
Qed.

Theorem permutation_rev: forall (A:Set) (l : list A),  permutation (rev l) l.
intros a l; elim l; simpl; auto.
intros a1 l1 Hl1.
apply permutation_trans with (cons a1 (rev l1)); auto.
change (permutation (rev l1 ++ (a1 :: nil)) (app (cons a1 nil) (rev l1))); auto.
Qed.

Lemma Zsum_swap: forall (n m : Z) (f : Z ->  Z),  Zsum n m f = Zsum m n f.
Proof.
  intros n m f; revert n m.
  cut (forall n m, n < m -> Zsum n m f = Zsum m n f).
  { intros L n m.
    destruct (Ztrichotomy n m) as [ LT | [ -> | GT ] ].
    - apply L, LT.
    - reflexivity.
    - symmetry; apply L, Z.gt_lt, GT. }
intros n m n_lt_m; unfold Zsum.
replace (m <=? n) with false by (symmetry; apply Z.leb_gt, n_lt_m).
replace (n <=? m) with true by (symmetry; apply Z.leb_le, Z.lt_le_incl, n_lt_m).
apply iter_permutation; auto with zarith.
apply permutation_trans
     with (rev (progression Z.succ n (Z.abs_nat  ((1 + m) - n)))).
apply permutation_sym; apply permutation_rev.
rewrite Zprogression_opp; auto with zarith.
replace (n + Z_of_nat (pred (Z.abs_nat  ((1 + m) - n)))) with m; auto.
replace (Z.abs_nat  ((1 + m) - n)) with (S (Z.abs_nat  (m - n))).
simpl.
rewrite inj_Zabs_nat.
rewrite Z.abs_eq; auto with zarith.
lia.
Qed.

Lemma Zsum_split_up:
 forall (n m p : Z) (f : Z ->  Z),
 ( n <= m < p ) ->  Zsum n p f = Zsum n m f + Zsum (m + 1) p f.
intros n m p f [H H0].
case (Zle_lt_or_eq _ _ H); clear H; intros H.
unfold Zsum; (repeat rewrite Zle_imp_le_bool); auto with zarith.
assert (H1: n < p).
apply Z.lt_trans with ( 1 := H ); auto with zarith.
assert (H2: m < 1 + p).
apply Z.lt_trans with ( 1 := H0 ); auto with zarith.
assert (H3: n < 1 + m).
apply Z.lt_trans with ( 1 := H ); auto with zarith.
assert (H4: n < 1 + p).
apply Z.lt_trans with ( 1 := H1 ); auto with zarith.
replace (Z.abs_nat  ((1 + p) - (m + 1)))
     with (minus (Z.abs_nat  ((1 + p) - n)) (Z.abs_nat  ((1 + m) - n))).
apply iter_progression_app. 1-3: auto with zarith.
apply inj_le_rev.
(repeat rewrite inj_Zabs_nat); auto with zarith.
(repeat rewrite Z.abs_eq); auto with zarith.
rewrite next_n_Z.
rewrite inj_Zabs_nat.
rewrite Z.abs_eq; auto with zarith.
apply inj_eq_rev.
rewrite inj_minus1.
(repeat rewrite inj_Zabs_nat).
(repeat rewrite Z.abs_eq); auto with zarith.
apply inj_le_rev.
(repeat rewrite inj_Zabs_nat).
(repeat rewrite Z.abs_eq); auto with zarith.
subst m.
rewrite Zsum_nn; auto with zarith.
unfold Zsum; generalize (Zle_cases n p); generalize (Zle_cases (n + 1) p);
 case (Zle_bool n p); case (Zle_bool (n + 1) p); auto with zarith.
intros H1 H2.
replace (Z.abs_nat  ((1 + p) - n)) with (S (Z.abs_nat  (p - n))).
replace (n + 1) with (Z.succ n) by auto with zarith.
replace ((1 + p) - Z.succ n) with (p - n); auto with zarith.
apply inj_eq_rev.
rewrite inj_S; (repeat rewrite inj_Zabs_nat).
(repeat rewrite Z.abs_eq); auto with zarith.
Qed.

Lemma Zsum_S_left:
 forall (n m : Z) (f : Z ->  Z), n < m ->  Zsum n m f = f n + Zsum (n + 1) m f.
intros n m f H; rewrite (Zsum_split_up n n m f); auto with zarith.
rewrite Zsum_nn; auto with zarith.
Qed.

Lemma Zsum_S_right:
 forall (n m : Z) (f : Z ->  Z),
 n <= m ->  Zsum n (m + 1) f = Zsum n m f  + f (m + 1).
intros n m f H; rewrite (Zsum_split_up n m (m + 1) f); auto with zarith.
rewrite Zsum_nn; auto with zarith.
Qed.

Lemma Zsum_split_down:
 forall (n m p : Z) (f : Z ->  Z),
 ( p < m <= n ) ->  Zsum n p f = Zsum n m f  + Zsum (m - 1) p f.
intros n m p f [H H0].
case (Zle_lt_or_eq p (m - 1)); auto with zarith; intros H1.
pattern m at 1; replace m with ((m - 1) + 1) by auto with zarith.
repeat rewrite (Zsum_swap n).
rewrite (Zsum_swap (m - 1)).
rewrite Zplus_comm.
apply Zsum_split_up; auto with zarith.
subst p.
repeat rewrite (Zsum_swap n).
rewrite Zsum_nn.
unfold Zsum; (repeat rewrite Zle_imp_le_bool); auto with zarith.
replace (Z.abs_nat   ((1 + n) - (m - 1))) with (S (Z.abs_nat   (n - (m - 1)))).
rewrite Zplus_comm.
replace (Z.abs_nat   ((1 + n) - m)) with (Z.abs_nat  (n - (m - 1))).
pattern m at 4; replace m with (Z.succ (m - 1)); auto with zarith.
apply f_equal with ( f := Z.abs_nat  ); auto with zarith.
apply inj_eq_rev.
rewrite inj_S.
(repeat rewrite inj_Zabs_nat).
(repeat rewrite Z.abs_eq); auto with zarith.
Qed.

Lemma Zsum_ext:
 forall (n m : Z) (f g : Z ->  Z),
 n <= m ->
 (forall (x : Z), ( n <= x <= m ) ->  f x = g x) ->  Zsum n m f = Zsum n m g.
intros n m f g HH H.
unfold Zsum; auto.
unfold Zsum; (repeat rewrite Zle_imp_le_bool); auto with zarith.
apply iter_ext; auto with zarith.
intros a H1; apply H; auto; split.
apply Zprogression_le_init with ( 1 := H1 ).
cut (a < Z.succ m); auto with zarith.
replace (Z.succ m) with (n + Z_of_nat (Z.abs_nat  ((1 + m) - n))).
apply Zprogression_le_end; auto with zarith.
rewrite inj_Zabs_nat.
(repeat rewrite Z.abs_eq); auto with zarith.
Qed.

Lemma Zsum_add:
 forall (n m : Z) (f g : Z ->  Z),
  Zsum n m f  + Zsum n m g = Zsum n m (fun (i : Z) => f i + g i).
intros n m f g; unfold Zsum; case (Zle_bool n m); apply iter_comp;
 auto with zarith.
Qed.

Lemma Zsum_times:
 forall n m x f,  x * Zsum n m f = Zsum n m (fun i=> x * f i).
intros n m x f.
unfold Zsum. case (Zle_bool n m); intros; apply iter_comp_const with (k := (fun y : Z => x * y)); auto with zarith.
Qed.

Lemma inv_Zsum:
 forall (P : Z ->  Prop) (n m : Z) (f : Z ->  Z),
 n <= m ->
 P 0 ->
 (forall (a b : Z), P a -> P b ->  P (a + b)) ->
 (forall (x : Z), ( n <= x <= m ) ->  P (f x)) ->  P (Zsum n m f).
intros P n m f HH H H0 H1.
unfold Zsum; rewrite Zle_imp_le_bool; auto with zarith; apply iter_inv; auto.
intros x H3; apply H1; auto; split.
apply Zprogression_le_init with ( 1 := H3 ).
cut (x < Z.succ m); auto with zarith.
replace (Z.succ m) with (n + Z_of_nat (Z.abs_nat  ((1 + m) - n))).
apply Zprogression_le_end; auto with zarith.
rewrite inj_Zabs_nat.
(repeat rewrite Z.abs_eq); auto with zarith.
Qed.

Lemma Zsum_pred:
 forall (n m : Z) (f : Z ->  Z),
  Zsum n m f = Zsum (n + 1) (m + 1) (fun (i : Z) => f (Z.pred i)).
intros n m f.
unfold Zsum.
generalize (Zle_cases n m); generalize (Zle_cases (n + 1) (m + 1));
 case (Zle_bool n m); case (Zle_bool (n + 1) (m + 1)); auto with zarith.
replace ((1 + (m + 1)) - (n + 1)) with ((1 + m) - n); auto with zarith.
intros H1 H2; cut (exists c , c = Z.abs_nat  ((1 + m) - n) ).
intros [c H3]; rewrite <- H3.
generalize n; elim c; auto with zarith; clear H1 H2 H3 c n.
intros c H n; simpl; eq_tac; auto with zarith.
eq_tac; unfold Z.pred; auto with zarith.
replace (Z.succ (n + 1)) with (Z.succ n + 1); auto with zarith.
exists (Z.abs_nat  ((1 + m) - n)); auto.
replace ((1 + (n + 1)) - (m + 1)) with ((1 + n) - m); auto with zarith.
intros H1 H2; cut (exists c , c = Z.abs_nat  ((1 + n) - m) ).
intros [c H3]; rewrite <- H3.
generalize n; elim c; auto with zarith; clear H1 H2 H3 c n.
intros c H n; simpl; (eq_tac; auto with zarith).
eq_tac; unfold Z.pred; auto with zarith.
replace (Z.pred (n + 1)) with (Z.pred n + 1); auto with zarith.
unfold Z.pred; auto with zarith.
exists (Z.abs_nat  ((1 + n) - m)); auto.
Qed.

Theorem Zsum_c:
 forall (c p q : Z), p <= q ->  Zsum p q (fun x => c) = ((1 + q) - p) * c.
intros c p q Hq; unfold Zsum.
rewrite Zle_imp_le_bool; auto with zarith.
pattern ((1 + q) - p) at 2.
 rewrite <- Z.abs_eq; auto with zarith.
 rewrite <- inj_Zabs_nat; auto with zarith.
cut (exists r , r = Z.abs_nat  ((1 + q) - p) );
 [intros [r H1]; rewrite <- H1 | exists (Z.abs_nat  ((1 + q) - p))]; auto.
generalize p; elim r; auto with zarith.
intros n H p0; replace (Z_of_nat (S n)) with (Z_of_nat n + 1).
simpl; rewrite H; ring.
rewrite inj_S; auto with zarith.
Qed.

Theorem Zsum_Zsum_f:
 forall (i j k l : Z) (f : Z -> Z ->  Z),
 i <= j ->
 k < l ->
  Zsum i j (fun x => Zsum k (l + 1) (fun y => f x y)) =
  Zsum i j (fun x => Zsum k l (fun y => f x y) + f x (l + 1)).
intros; apply Zsum_ext; intros; auto with zarith.
rewrite Zsum_S_right; auto with zarith.
Qed.

Theorem Zsum_com:
 forall (i j k l : Z) (f : Z -> Z ->  Z),
  Zsum i j (fun x => Zsum k l (fun y => f x y)) =
  Zsum k l (fun y => Zsum i j (fun x => f x y)).
intros; unfold Zsum; case (Zle_bool i j); case (Zle_bool k l); apply iter_com;
 auto with zarith.
Qed.

Theorem Zsum_le:
 forall (n m : Z) (f g : Z ->  Z),
 n <= m ->
 (forall (x : Z), ( n <= x <= m ) ->  (f x <= g x )) ->
  (Zsum n m f <= Zsum n m g ).
intros n m f g Hl H.
unfold Zsum; rewrite Zle_imp_le_bool; auto with zarith.
unfold Zsum;
 cut
  (forall x,
   In x (progression Z.succ n (Z.abs_nat  ((1 + m) - n))) ->  ( f x <= g x )).
elim (progression Z.succ n (Z.abs_nat  ((1 + m) - n))); simpl; auto with zarith.
intros x H1; apply H; split.
apply Zprogression_le_init with ( 1 := H1 ); auto.
cut (x < m + 1); auto with zarith.
replace (m + 1) with (n + Z_of_nat (Z.abs_nat  ((1 + m) - n))).
apply Zprogression_le_end; auto with zarith.
rewrite inj_Zabs_nat.
rewrite Z.abs_eq; auto with zarith.
Qed.

Theorem iter_le:
forall (f g: Z -> Z)  l, (forall a, In a l -> f a <= g a) ->
  iter 0 f Zplus l <= iter 0 g Zplus l.
intros f g l; elim l; simpl; auto with zarith.
Qed.

Theorem Zsum_lt:
 forall n m f g,
 (forall x, n <= x -> x <= m ->  f x <= g x) ->
 (exists x, n <= x /\ x <= m /\  f x < g x) ->
  Zsum n m f < Zsum n m g.
intros n m f g H (d, (Hd1, (Hd2, Hd3))); unfold Zsum; rewrite Zle_imp_le_bool; auto with zarith.
cut (In d (progression  Z.succ n (Z.abs_nat  (1 + m - n)))).
cut (forall x, In x (progression Z.succ n (Z.abs_nat  (1 + m - n)))->  f x <= g x).
elim (progression  Z.succ n (Z.abs_nat  (1 + m - n))); simpl; auto with zarith.
intros a l Rec  H0 [H1 | H1]; subst; auto.
apply Z.le_lt_trans with (f d + iter 0 g Zplus l); auto with zarith.
apply Zplus_le_compat_l.
apply iter_le; auto.
apply Z.lt_le_trans with (f a + iter 0 g Zplus l); auto with zarith.
intros x H1; apply H.
apply Zprogression_le_init with ( 1 := H1 ); auto.
cut (x < m + 1); auto with zarith.
replace (m + 1) with (n + Z_of_nat (Z.abs_nat  ((1 + m) - n))).
apply Zprogression_le_end with ( 1 := H1 ); auto with arith.
rewrite inj_Zabs_nat.
rewrite Z.abs_eq; auto with zarith.
apply in_Zprogression.
rewrite inj_Zabs_nat.
rewrite Z.abs_eq; auto with zarith.
Qed.

Theorem Zsum_minus:
 forall n m f g,  Zsum n m f - Zsum n m g = Zsum n m (fun x => f x - g x).
intros n m f g; apply trans_equal with (Zsum n m f + (-1) * Zsum n m g); auto with zarith.
rewrite Zsum_times; rewrite Zsum_add; auto with zarith.
Qed.


(*
Borrowed from https://github.com/QuickChick/QuickChick/blob/master/src/StringOT.v

Ordering code by Antal :)

*)

Require Import Coq.Structures.OrderedType.
Require Import Coq.Strings.Ascii.
Require Import Coq.NArith.NArith.

Module AsciiOT <: OrderedType.

  Definition t := ascii.

  Definition eq       := @Logic.eq       ascii.
  Definition eq_refl  := @Logic.eq_refl  ascii.
  Definition eq_sym   := @Logic.eq_sym   ascii.
  Definition eq_trans := @Logic.eq_trans ascii.
  Definition eq_dec   := ascii_dec.

  Definition lt (c d : ascii) : Prop := (N_of_ascii c < N_of_ascii d)%N.

  Theorem lt_trans : forall c d e : ascii, lt c d -> lt d e -> lt c e.
  Proof. intros *; unfold lt; apply N.lt_trans. Qed.

  Theorem lt_not_eq : forall c d : ascii, lt c d -> ~ eq c d.
  Proof.
    unfold lt, eq; red; intros;
      assert (N_of_ascii c = N_of_ascii d) as eq' by (f_equal; assumption);
      generalize dependent eq'; apply N.lt_neq; assumption.
  Qed.

  Theorem compare : forall c d : ascii, Compare lt eq c d.
  Proof.
    unfold lt, eq; intros;
      remember (N_of_ascii c ?= N_of_ascii d)%N as C; symmetry in HeqC; destruct C;
        [ apply EQ; replace c with (ascii_of_N (N_of_ascii c))
            by apply ascii_N_embedding;
          replace d with (ascii_of_N (N_of_ascii d))
            by apply ascii_N_embedding;
          f_equal; apply N.compare_eq
        | apply LT
        | apply GT; apply N.gt_lt];
        assumption.
  Qed.

End AsciiOT.


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

Require Import List Arith Lia.
Import ListNotations.

Require Import Undecidability.Synthetic.Definitions.

From Undecidability.Shared.Libs.DLW
  Require Import utils list_bool pos vec subcode sss.

From Undecidability.StackMachines.BSM
  Require Import tiles_solvable bsm_defs bsm_utils bsm_pcp.

From Undecidability.PCP
  Require Import PCP PCP_facts.

Fact tile_concat_itau ln lt : tile_concat ln lt = (itau1 lt (rev ln), itau2 lt (rev ln)).
Proof.
  induction ln as [ | i ln IH ]; simpl; auto.
  rewrite itau1_app, itau2_app; simpl.
  generalize (nth i lt ([], [])); intros (a,b); rewrite IH.
  repeat rewrite <- app_nil_end; auto.
Qed.

(* tiles_solvable & iBPCP is the same predicate except that the existentially
   quantified list is reversed *)

Theorem tiles_solvable_iBPCP lt : tiles_solvable lt <-> iPCPb lt.
Proof.
  split.
  + intros (ln & H1 & H2 & H3).
    rewrite tile_concat_itau in H3.
    exists (rev ln).
    rewrite <- Forall_forall.
    repeat split; auto.
    * apply Forall_rev; auto.
    * contradict H1; rewrite <- (rev_involutive ln), H1; auto.
  + intros (ln & H1 & H2 & H3).
    exists (rev ln).
    rewrite tile_concat_itau, rev_involutive.
    repeat split; auto.
    * contradict H2; rewrite <- (rev_involutive ln), H2; auto.
    * apply Forall_rev, Forall_forall; auto.
Qed.

Local Notation "P // s ->> t" := (sss_compute (@bsm_sss _) P s t).
Local Notation "P // s ~~> t" := (sss_output (@bsm_sss _) P s t).
Local Notation "P // s ↓" := (sss_terminates (@bsm_sss _) P s).

Section iPCPb_to_BSM_HALTING.

  Let f (lt : list (card bool)) : BSM_PROBLEM.
  Proof.
    exists 4, 1, (pcp_bsm lt).
    exact (vec_set_pos (fun _ => nil)).
  Defined.

  Goal forall x, length(pcp_bsm x) >= 80.
  Proof.
    intros; rewrite pcp_bsm_size; lia.
  Qed.

  Theorem iPCPb_to_BSM_HALTING : iPCPb ⪯ Halt_BSM.
  Proof.
    exists f.
    intros lt.
    rewrite <- tiles_solvable_iBPCP.
    rewrite Halt_BSM_iff.
    unfold BSM_HALTING; split.
    * intros H.
      apply pcp_bsm_sound with (v := vec_set_pos (fun _ => nil)) in H.
      match type of H with  _ // _ ->> (?q,?w) => exists (q, w) end.
      split; auto.
      simpl; lia.
    * intros ((q & w) & H).
      apply pcp_bsm_complete in H; tauto.
  Qed.

End iPCPb_to_BSM_HALTING.


Set Warnings "-notation-overridden,-parsing".
Add LoadPath "~/Documents/lf" as LF.
From Coq Require Import omega.Omega.
From LF Require Import Maps.
From LF Require Import Imp.

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

Theorem ceval_deterministic: forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
    generalize dependent st2;
    induction E1; intros st2 E2; inv E2.
  - (* E_Skip *) reflexivity.
  - (* E_Ass *) reflexivity.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; apply H1. }
    subst st'0.
    apply IHE1_2. assumption.
    (* E_IfTrue *)
  - (* b evaluates to true *)
    apply IHE1. assumption.
  - (* b evaluates to false (contradiction) *)
    rewrite H in H5. inversion H5.
    (* E_IfFalse *)
    - (* b evaluates to true (contradiction) *)
    rewrite H in H5. inversion H5.
  - (* b evaluates to false *)
    apply IHE1. assumption.
  (* E_WhileFalse *)
  - (* b evaluates to false *)
    reflexivity.
  - (* b evaluates to true (contradiction) *)
    rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption. Qed.

Example auto_example_1 : forall (P Q R: Prop),
    (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P Q R H1 H2 H3.
  apply H2. apply H1. assumption.
Qed.

Example auto_exmple_1': forall (P Q R: Prop),
    (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  auto.
Qed.

Example auto_example_2 : forall P Q R S T U : Prop,
  (P -> Q) ->
  (P -> R) ->
  (T -> R) ->
  (S -> T -> U) ->
  ((P->Q) -> (P->S)) ->
  T ->
  P ->
  U.
Proof. auto. Qed.

Example auto_example_3 : forall P Q R S T U : Prop,
  (P -> Q) ->
  (Q -> R) ->
  (R -> S) ->
  (S -> T) ->
  (T -> U) ->
  P ->
  U.
Proof.
  auto.
  auto 6.
Qed.

Example auto_example_4 : forall P Q R : Prop,
    Q ->
    (Q -> R) ->
    P \/ (Q /\ R).
Proof. auto. Qed.

Lemma le_antisym : forall n m : nat, ( n <= m /\ m <= n) -> n = m.
Proof. intros. omega. Qed.

Example auto_example_6 : forall n m p : nat,
    (n <= p -> (n <= m /\ m <= n)) ->
     n <= p ->
     n = m.
Proof.
  intros.
  auto using le_antisym.
Qed.

Hint Resolve le_antisym.
Example auto_example_6' : forall n m p : nat,
    (n <= p -> (n <= m /\ m <= n)) ->
    n <= p ->
    n = m.
Proof.
  intros.
  auto.
Qed.

Definition is_fortytwo x := (x = 42).

Hint Unfold is_fortytwo.
Example auto_example_7: forall x,
    (x<= 42 /\ 42 <= x) -> is_fortytwo x.
Proof. auto. Qed.

Theorem ceval_deterministic': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
    induction E1; intros st2 E2; inv E2; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
Qed.

Theorem ceval_deterministic'_alt: forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
                st1 = st2.
Proof with auto.
  intros c st st1 st2 E1 E2;
    generalize dependent st2;
    induction E1;
    intros st2 E2; inv E2...
  - assert (st' = st'0) as EQ1...
    subst st'0...
  -
    + rewrite H in H5. inversion H5.
  -
    + rewrite H in H5. inversion H5.
  -
    + rewrite H in H2. inversion H2.
  - rewrite H in H4. inversion H4.
  - assert (st' = st'0) as EQ1...
    subst st'0...
Qed.

Ltac rwinv H1 H2 := rewrite H1 in H2; inv H2.

Theorem ceval_deterministic'': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
    induction E1; intros st2 E2; inv E2; auto.
  -
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  -
    + rwinv H H5.
  -
    + rwinv H H5.
  -
    +
      rwinv H H2.
  -
    rwinv H H4.
  -
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
Qed.

Ltac find_rwinv :=
  match goal with
    H1 : ?E = true,
         H2 : ?E = false
    |- _ => rwinv H1 H2
  end.

Theorem ceval_deterministic''': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
    induction E1; intros st2 E2; inv E2; try find_rwinv;
      auto.
  -  assert (st' = st'0) as EQ1 by auto.
     subst st'0.
     auto.
  -
    + assert (st' = st'0) as EQ1 by auto.
      subst st'0.
      auto. Qed.

Theorem ceval_deterministic'''': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
    induction E1; intros st2 E2;
      inv E2; try find_rwinv;
        auto.
  - rewrite (IHE1_1 st'0 H1) in *. auto.
  -
    + rewrite (IHE1_1 st'0 H3) in *. auto.
Qed.

Ltac find_eqn :=
  match goal with
    H1: forall x, ?P x -> ?L = ?R,
    H2: ?P ?X
    |- _ => rewrite (H1 X H2) in *
end.

Theorem ceval_deterministic''''': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
    induction E1; intros st2 E2; inv E2; try find_rwinv;
      repeat find_eqn; auto.
Qed.

Module Repeat.

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

  Notation "'SKIP'" :=
    CSkip.

  Notation "c1 ; c2" :=
    (CSeq c1 c2) (at level 80, right associativity).
  Notation "X '::=' a" :=
    (CAsgn X a) (at level 60).
  Notation "'WHILE' b 'DO' c 'END'" :=
    (CWhile b c) (at level 80, right associativity).
  Notation "'TEST' e1 'THEN' e2 'ELSE' e3 'FI'" :=
    (CIf e1 e2 e3) (at level 80, right associativity).
  Notation "'REPEAT' e1 'UNTIL' b2 'END'" :=
    (CRepeat e1 b2) (at level 80, right associativity).

  Inductive ceval : state -> com -> state -> Prop :=
  | E_Skip : forall st,
      ceval st SKIP st
  | E_Ass  : forall st a1 n X,
      aeval st a1 = n ->
      ceval st (X ::= a1) (t_update st X n)
  | E_Seq : forall c1 c2 st st' st'',
      ceval st c1 st' ->
      ceval st' c2 st'' ->
      ceval st (c1 ; c2) st''
  | E_IfTrue : forall st st' b1 c1 c2,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st (TEST b1 THEN c1 ELSE c2 FI) st'
  | E_IfFalse : forall st st' b1 c1 c2,
      beval st b1 = false ->
      ceval st c2 st' ->
      ceval st (TEST b1 THEN c1 ELSE c2 FI) st'
  | E_WhileFalse : forall b1 st c1,
      beval st b1 = false ->
      ceval st (WHILE b1 DO c1 END) st
  | E_WhileTrue : forall st st' st'' b1 c1,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st' (WHILE b1 DO c1 END) st'' ->
      ceval st (WHILE b1 DO c1 END) st''
  | E_RepeatEnd : forall st st' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = true ->
      ceval st (CRepeat c1 b1) st'
  | E_RepeatLoop : forall st st' st'' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = false ->
      ceval st' (CRepeat c1 b1) st'' ->
      ceval st (CRepeat c1 b1) st''.

  Notation "st '=[' c ']=>' st'" := (ceval st c st')
                                      (at level 40).

  Theorem ceval_deterministic: forall c st st1 st2,
      st =[ c ]=> st1 ->
      st =[ c ]=> st2 ->
      st1 = st2.
  Proof.
    intros c st st1 st2 E1 E2.
    generalize dependent st2;
      induction E1;
      intros st2 E2; inv E2; try find_rwinv; repeat find_eqn;
        auto.
    - (* E_RepeatEnd *)
      + find_rwinv.
    -
      + find_rwinv.
  Qed.

  Theorem ceval_deterministic': forall c st st1 st2,
      st =[ c ]=> st1 ->
      st =[ c ]=> st2 ->
      st1 = st2.
  Proof.
    intros c st st1 st2 E1 E2.
    generalize dependent st2;
      induction E1;
      intros st2 E2; inv E2; repeat find_eqn; try find_rwinv;
        auto.
  Qed.

End Repeat.


Require Import Coq.ZArith.BinIntDef Coq.ZArith.BinInt Coq.ZArith.Zdiv Psatz.

Definition minimize_eq_proof{A: Type}(eq_dec: forall (x y: A), {x = y} + {x <> y}){x y: A}    (pf: x = y): x = y :=
  match eq_dec x y with
  | left p => p
  | right n => match n pf: False with end
  end.

Section Word.
  Section fixedWidth.
    Variable width : nat.

    Declare Scope word_scope.

    Local Notation wrap_value n := (Z.modulo n (Z.pow 2 (Z.of_nat width))).

    (* Word is a record with two fields wordVal and wordBound *)
    Record word := mk {wordVal : Z ;
                       wordBound : wrap_value wordVal = wordVal}.

    Delimit Scope word_scope with word.
    Bind Scope word_scope with word.

    Open Scope word_scope.

    Definition ZToWord (n : Z) : word :=
      mk (wrap_value n) (minimize_eq_proof Z.eq_dec (Zdiv.Zmod_mod n _)).

    Definition boolToZ b : Z :=
      match b with
      | false => 0
      | true => 1
      end.

    Definition NToWord (n : N) := ZToWord (Z.of_N n).

    Definition boolToWord b := ZToWord (boolToZ b).

    Definition natToWord (n : nat) := ZToWord (Z.of_nat n).

    Definition wones := ZToWord ((2 ^ (Z.of_nat width))%Z - 1).

  End fixedWidth.

  Section implicitWidth.
    Context {width : nat}.

    Definition wordToNat (w : word width) := Z.to_nat (wordVal width w).

    Definition wadd x y := ZToWord width (Z.add (wordVal width x) (wordVal width y)).

    Definition wsub x y := ZToWord width (Z.sub (wordVal width x) (wordVal width y)).

    Definition wor x y := ZToWord width (Z.lor (wordVal width x) (wordVal width y)).

    Definition wand x y := ZToWord width (Z.land (wordVal width x) (wordVal width y)).

    Definition wxor x y := ZToWord width (Z.lxor (wordVal width x) (wordVal width y)).

    Definition wneg x := ZToWord width (Z.sub (Z.pow 2 (Z.of_nat width)) (wordVal width x)).

    Definition wnot x := ZToWord width (Z.sub (wordVal width (wneg x)) 1).

    Definition wuand x := Z.eqb (wordVal width (wones width)) (wordVal width x).

    Definition wuor x := negb (Z.eqb (wordVal width (ZToWord width 0)) (wordVal width x)).

    Fixpoint pos_uxor (p : positive) : bool :=
      match p with
      | xH => true
      | xI p' => negb (pos_uxor p')
      | xO p' => (pos_uxor p')
      end.

    Definition un_xor (z : Z) : bool :=
      match z with
      | Z0 => false
      | Zpos p => pos_uxor p
      | Zneg p => pos_uxor p
      end.

    Definition wuxor x := un_xor (wordVal width x).

    Definition wmul x y := ZToWord width (Z.mul (wordVal width x) (wordVal width y)).

    Definition wdiv x y := ZToWord width (Z.div (wordVal width x) (wordVal width y)).

    Definition wmod x y := ZToWord width (Z.modulo (wordVal width x) (wordVal width y)).

    Definition wslu x y := ZToWord width (Z.mul (wordVal width x) (Z.pow 2 (wordVal width y))).

    Definition wsru x y := ZToWord width (Z.div (wordVal width x) (Z.pow 2 (wordVal width y))).

    Definition weqb x y := Z.eqb (wordVal width x) (wordVal width y).

    Definition wltu x y := Z.ltb (wordVal width x) (wordVal width y).

  End implicitWidth.

  Definition truncLsb {lsb outSz} (w : @word outSz) : @word lsb :=
    ZToWord lsb (wordVal outSz w).

  Definition truncMsb {msb outSz} (w : @word outSz) : @word msb :=
    ZToWord msb (Z.div (wordVal outSz w) (Z.pow 2 (Z.of_nat (Nat.sub outSz msb)))).

  Definition wconcat {msb lsb outSz} (w1 : @word msb) (w2 : @word lsb) :  @word outSz :=
    ZToWord outSz (Z.add (Z.mul (wordVal msb w1) (Z.pow 2 (Z.of_nat lsb))) (wordVal lsb w2)).

  Definition wcombine {msb lsb} (w1 : @word msb) (w2 : @word lsb) : @word (msb + lsb) :=
    @wconcat msb lsb (msb + lsb) w1 w2.

  Definition get_msb {sz} (w : @word sz) : @word 1 :=
    (@truncMsb 1 sz w).

  Definition get_lsb {sz} (w : @word sz) : @word 1 :=
    (@truncLsb 1 sz w).

  Definition wnon_neg {sz} (w : @word sz) : bool :=
    (Z.ltb (wordVal _ w) (Z.pow 2 (Z.of_nat (sz - 1)))).

  Definition twosComplement {sz} (w: @word sz) : @word sz :=
    ZToWord _ (Z.sub (Z.pow 2 (Z.of_nat sz)) (wordVal _ w)).

  Definition wordToSignedZ {sz} (w: @word sz) : Z :=
    if Z.ltb (wordVal _ w) (Z.pow 2 (Z.of_nat (sz - 1)))
    then wordVal _ w
    else Z.opp (wordVal _ (twosComplement w)).

  Definition signZ (n: Z) :=
    match n with
    | Z0 => false
    | Z.pos _ => false
    | Z.neg _ => true
    end.

  Definition signedZToWord {sz} (n: Z) : @word sz :=
    if signZ n
    then twosComplement (ZToWord _ (Z.opp n))
    else ZToWord _ n.

  Definition wsra {sz1 sz2: nat} (w1: @word sz1) (w2 : @word sz2) : @word sz1 :=
    @signedZToWord sz1 (Z.div (if wnon_neg w1
                               then wordVal _ w1
                               else wordToSignedZ w1) (Z.pow 2 (wordVal _ w2))).

  Definition whd sz (w : word (S sz)) := @truncMsb 1 _ w.

  Definition wtail sz (w : word (S sz)) := @truncLsb sz _ w.

  Definition wsplitl (sz1 sz2 : nat) (w : @word (sz1 + sz2)) : @word sz1 :=
    ZToWord _ (wordVal _ w / (Z.pow 2 (Z.of_nat sz2)))%Z.

  Definition wsplitr (sz1 sz2 : nat) (w : @word (sz1 + sz2)) : @word sz2 :=
    ZToWord _ ((wordVal _ w) mod (Z.pow 2 (Z.of_nat sz2)))%Z.

  Fixpoint nat_cast (P : nat -> Type) {n m} : n = m -> P n -> P m.
    refine match n, m return n = m -> P n -> P m with
           | O, O => fun _ => id
           | S n, S m => fun pf => @nat_cast (fun n => P (S n)) n m (f_equal pred pf)
           | _, _ => fun pf => match _ pf : False with end
           end;
      clear; abstract congruence.
  Defined.

  Definition wmsb sz (w : word sz) (b : bool) :=
    if (sz =? 0)%nat then b else (0 <? wordToNat w / 2 ^ (sz - 1)).

  Definition wleu {sz} (x y : word sz) :=
    (wordVal _ x <=? wordVal _ y)%Z.

  Definition wlt_dec : forall {sz} (l r : word sz), {(wltu l r) = true} +  {(wltu l r) = false}.
  Proof.
    intros.
    destruct (wltu l r).
    left. reflexivity.
    right.
    reflexivity.
  Defined.

  Lemma eq_wordVal {sz} {x y : word sz} : wordVal _ x = wordVal _ y -> x = y.
  Proof.
    intros.
    destruct x as [x px].
    destruct y as [y py].
    intros.
    simpl in *; subst; auto.
    apply f_equal, Eqdep_dec.UIP_dec. eapply Z.eq_dec.
  Qed.

  Lemma weqb_true: forall {sz} (a b: word sz), weqb a b = true -> a = b.
  Proof.
    intros.
    unfold weqb in H.
    rewrite Z.eqb_eq in H.
    apply eq_wordVal.
    assumption.
  Qed.

  Lemma weqb_false: forall {sz} (a b: word sz), weqb a b = false -> a <> b.
  Proof.
    intros.
    unfold weqb in H.
    rewrite Z.eqb_neq in H. congruence.
  Qed.

  Definition weq {sz} (x y: word sz): {x = y} + {x <> y} :=
    match weqb x y as sth return weqb x y = sth -> {x = y} + {x <> y} with
    | true => fun s => left (weqb_true _ _ s)
    | false => fun s => right (weqb_false _ _ s)
    end eq_refl.

End Word.

Module Notations.

  Declare Scope word_scope.

  Notation "^~" := wneg : word_scope.
  Notation "l ^* r" := (@wmul _ l r) (at level 40, left associativity) : word_scope.
  Notation "l ^/ r" := (@wdiv _ l r) (at level 50, left associativity) : word_scope.
  Notation "l ^+ r" := (@wadd _ l r) (at level 50, left associativity) : word_scope.
  Notation "l ^- r" := (@wsub _ l r) (at level 50, left associativity) : word_scope.
  Notation "l ^% r" := (@wmod _ l r) (at level 50, left associativity) : word_scope.
  Notation "l ^| r" := (@wor _ l r) (at level 50, left associativity) : word_scope.
  Notation "l ^& r" := (@wand _ l r) (at level 40, left associativity) : word_scope.

  Notation "$ n" := (@natToWord _ n) (at level 0, no associativity): word_scope.
  (* Notation "$ m" := (@ZToWord _ m) (at level 0, no associativity): word_scope. *)

  Notation "WO~0" := (ZToWord 1 0) : word_scope.
  Notation "WO~1" := (ZToWord 1 1) : word_scope.
  Notation WO := (ZToWord 0 0).

  Delimit Scope word_scope with word.
End Notations.
Notation wzero sz := (ZToWord sz 0).

Export Notations.
Export ZArith.
(* Compute (@wnot 2 (ZToWord 2 2)). *)

(* Compute (@wneg 2 (ZToWord 2 3)). *)

(* Compute (wsra (ZToWord 4 15) (ZToWord 1 1)). *)

(* Compute (wsra (ZToWord 4 12) (ZToWord 3 3)). *)

(* Compute (wsra (ZToWord 2 1) (ZToWord 3 5)). *)

(* Compute (wsra (ZToWord 5 9) (ZToWord 4 3)). *)

(* Compute (@wconcat 2 2 4 (ZToWord 2 2) (ZToWord 2 3)). *)

(* Compute (@truncLsb 2 4 (@wconcat 2 2 4 (ZToWord 2 2) (ZToWord 2 3))).*)


Require Import ILL.Definitions.

(** ** BPCP reduces to iBPCP *)

Definition card_eq : forall x y : card bool, {x = y} + {x <> y}.
Proof.
  intros. repeat decide equality.
Defined.

Definition f (P : BSRS) (A : stack bool) := omap (fun x => pos card_eq x P) A.

Lemma itau_tau1 P A : A <<= P -> itau1 P (f P A) = tau1 A.
Proof.
  intros H. induction A as [ | (x,y) ].
  - reflexivity.
  - cbn. assert ((x/y) el P) as [n E] % (el_pos card_eq) by firstorder.
    rewrite E. cbn. unfold f in IHA. rewrite IHA; eauto. now erewrite pos_nth; eauto.
Qed.

Lemma itau_tau2 P A : A <<= P -> itau2 P (f P A) = tau2 A.
Proof.
  intros H. induction A as [ | (x,y) ].
  - reflexivity.
  - cbn. assert ((x/y) el P) as [n E] % (el_pos card_eq) by firstorder.
    rewrite E. cbn. unfold f in IHA. rewrite IHA; eauto. now erewrite pos_nth; eauto.
Qed.

Definition g (P : BSRS) (A : list nat) := map (fun n => nth n P ( [] / [] )) A.

Lemma tau_itau1 P A : (forall a : nat, a el A -> a < | P |) -> tau1 (g P A) = itau1 P A.
Proof.
  intros H. induction A.
  - reflexivity.
  - cbn. unfold g in *. rewrite IHA; firstorder. now destruct (nth a P ([] / [])) eqn:E.
Qed.

Lemma tau_itau2 P A : (forall a : nat, a el A -> a < | P |) -> tau2 (g P A) = itau2 P A.
Proof.
  intros H. induction A.
  - reflexivity.
  - cbn. unfold g in *. rewrite IHA; firstorder. now destruct (nth a P ([] / [])) eqn:E.
Qed.

Lemma BPCP_iBPCP : BPCP ⪯ iBPCP.
Proof.
  exists (fun P => P). intros P. split.
  - intros (A & ? & ? & ?).
    exists (f P A). repeat split.
    + now intros ? (? & ? & ? % pos_length) % in_omap_iff.
    + destruct A; try congruence. cbn.
      assert (c el P) as [n ->] % (el_pos card_eq) by firstorder.
      congruence.
    + rewrite itau_tau1, H1, itau_tau2; eauto.
  - intros (A & ? & ? & ?).
    exists (g P A). repeat split.
    + unfold g. intros ? (? & <- & ?) % in_map_iff. eapply nth_In; firstorder.
    + destruct A; cbn; congruence.
    + now rewrite tau_itau1, H1, tau_itau2.
Qed.


(**
Coq/SSReflect/MathComp の \in 演算子の不思議を納得する
===================

@suharahiromichi

2022/10/23
*)

(**
MathComp の``\in``は、``∈``の意味の二項演算子ですが、右側にはリストでも、集合でも、
型でも、命題でもよいという万能選手です。ここでは、その万能性を実現するしくみを調べて
みます。
また、MathCompの型クラスの機能をつかって、``\in``の右に書ける型を増やしてみます。

このファイルは以下にあります。

https://github.com/suharahiromichi/coq/blob/master/ssr/ssr_in_operator2.v

CoqとMathCompのバージョンは以下の通りです。
```
coq                     8.16.0
coq-mathcomp-ssreflect  1.15.0
```
*)

(**
# 準備

いつも通りにSSReflectをインポートし、
いつものお約束通り、Coqの引数の省略を許します。
*)
From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.                  (* Coqの引数の省略を許す。 *)

(**
省略された引数とコアーションを表示しないようにします。
いずれもディフォルト（省略時解釈）ですが、
今回はこれを切り替えることがあるかもしれないので、最初に明示しておきます。
*)
Unset Printing Implicit.            (* 省略された引数を表示しない。 *)
Unset Printing Coercions.           (* コアーションを表示しない。 *)
Set Printing Notations.             (* Notationを展開しません。 *)

(**
# ``\in``演算子の使用例
*)
Compute 1 \in [:: 1; 2].                    (* リスト *)
Compute 1 \in [tuple 1; 2].                 (* タプル *)
Compute true \in [set true].                (* 有限集合 *)
Compute 1 \in [pred n | n < 3].             (* 命題 *)
Compute 1 \in nat_eqType.                   (* 型 *)

(**
# ``\in``演算子の定義

Locate コマンドを使ってしらべると、``in_mem``と``mem``のふたつの関数で構成されています。
ここで注意すしないといけないのは、``\in``は、スコープで切り替えられる複数の演算子ではな
いことです。
*)
Locate "_ \in _".       (* Notation "x \in A" := (in_mem x (mem A)) *)

(**
これでは、x と A の型が判らないので、以下を試してみると、
*)

Check _ \in _.
(**
```
?x \in ?A : bool
where
?T : [ |- Type]
?x : [ |- ?T]
?pT : [ |- predType ?T]
?A : [ |- pred_sort ?pT]
```

となり、``T``と``pT``のふたつの型が与えられていることが判ります。
``pred_sort``の説明はあとでしますが、
とりあえず、``x``は任意の型``T``、``A``は``pT``型で、
その``pT``は``predType T``型と思ってください。

これをもとに``x``の型と``A``の型を与えてると、次のようになります。
*)
Check fun (T : Type) (pT : predType T) (x : T) (A : pred_sort pT) =>
        x \in A.

(**
さらに、``\in``を構成する``in_mem``と``mem``の先頭に``@``をつけてみると次のようになり、
``T``も``pT``も``in_mem``と``mem``に与えられていることが判ります。
*)
(*
Set Printing Coercions.
Set Printing Implicit.
Unset Printing Notations.
*)
Check fun (T : Type) (pT : predType T) (x : T) (A : pred_sort pT) =>
        @in_mem T x (@mem T pT A).

(**
# ``predType T``型の定義

``\in``を使うには、``predType T``型が必要だとわかったので、調べてみます。
``predType T``型は、``eqType``型などと同様のMathCompの型クラスです。
型クラスなので、``pT : predType T``なる``pT``は、型インスタンスとなります。

``predType``の実体はStructureで定義される構造体
で、``theories/ssr/ssrbool.v``で、以下のように定義されています。
（改行を変更。また、``pred T = T -> bool``を展開しています。）

(注1) Coqでは、RecordとStructureは同じコマンドです。

(注2) mathcomp/ssreflect/ssrbool.v から、Coq本体のコードツリーに移動されました。

```
Record predType (T : Type) : Type :=
  PredType {
      pred_sort :> Type;
      topred : pred_sort -> T -> bool
  }.
```

これは次のように読みます：

構造体 predType は、型引数``T : Type``をとり、``pred_sort``
と``topred``のふたつのメンバーを持つ。

- ``pred_sort``は、この型の元になる任意の型で、``T``とは無関係です。
ここでは勝手に「台」と呼ぶことにします。
また、``:>``は、``predType T``のインスタンスから「台」のへの型強制（コアーション）が
有効になることを意味します。コアーションは``pred_sort``で行われます。

- ``topred``は、to pred で、「台」と``T``から``bool``型を求めるbool述語ですが、
「台」を``T -> bool``型に変換する関数とも取れるので、以下「変換関数」と呼びます。

このふたつから、``predType T``型のインスタンスを作ることができます。
「台」から``predType T``を求める必要があるので、Coqのカノニカルとして、
（Definitionではなくて）Canonicalコマンドで定義します。
*)

(**
# ``predType T``型のインスタンスの例

理解の早道は実際に作ってみることなので、やってみましょう。
``predType T``型を実際に作って、``\in``で使えるかためしてみましょう。

直積型(Prod型、Pair)のどちらかならtrueを変返すものを考えます。
例えば次のような例ですが、まだ定義ができていないので、単純のエラーになります。
*)

Fail Compute 1 \in (1, 2).                  (* true *)
Fail Compute 3 \in (1, 2).                  (* false *)

(**
- 「台」は、直積型(Prod型、Pair)とします。
ただし、fstとsndが別の型だと意味がないので、``T * T``とします。

- 「変換関数」は、
``x``がのfstかsndかのどちらかの要素に含まれているかを判定するので、
次のようになります。``==``を使うために``T``は``eqType``にします。
*)
Definition pred_of_eq_pair (T : eqType) (A : T * T) : (T -> bool) :=
  fun (x : T) => (A.1 == x) || (A.2 == x).

(**
「変換関数」単独で動作を確認します。
*)
Compute pred_of_eq_pair nat_eqType (1, 2) 1. (* true *)
Compute pred_of_eq_pair nat_eqType (1, 2) 3. (* false *)

(**
Canonicalコマンドで定義します。
*)
Canonical pair_predType (T : eqType) :=
  {| pred_sort := T * T; topred := pred_of_eq_pair T |}.

(**
PredType を使って定義することもできます。
```
Canonical pair_predType (T : eqType) := @PredType T (T * T) (pred_of_eq_pair T).
```
*)

(**
「台」へのコアーションも機能しています。
*)
Compute pred_sort (pair_predType nat_eqType). (* (nat * nat) *)
Check (1, 2) : (nat * nat).
Check (1, 2) : pair_predType nat_eqType.

(**
所望の動作をしているようです。
*)
Compute 1 \in (1, 2).                       (* true *)
Compute 3 \in (1, 2).                       (* false *)

(**
補足説明：

``pred_of_eq_pair T``を``T : eqType``で定義したため、
``pair_predType T``も``T : eqType``になりますが、
``predType T``の``T``については、eqTypeのコアーションが効いて、``Equality.sort T``
になり、問題ありません。
 *)
(*
(* Set Printing Coercions. *)
Canonical pair_predType (T : eqType) :=
  {| pred_sort := (Equality.sort T) * (Equality.sort T); topred := pred_of_eq_pair T |}.
Check pair_predType : forall (T : eqType), predType (Equality.sort T).
 *)

(**
補足説明：

(1) ``\in``の定義に引数をもれなく与えてみます。
*)
Check (fun (T : Type) (pT : predType T) (x : T) (A : pred_sort pT) =>
         @in_mem T x (@mem T pT A))
      nat_eqType
      (pair_predType nat_eqType)
      1
      (1, 2).
(**
(2) ``T``に``nat_eqType``を展開してみます。コアーションが起きます。
*)
Check (fun (pT : predType (Equality.sort nat_eqType))
           (x : Equality.sort nat_eqType) (A : pred_sort pT) =>
         @in_mem nat_eqType x (@mem nat_eqType pT A))
      (pair_predType nat_eqType)
      1
      (1, 2).
(**
(2') ``predType``の引数や``x``の型のコアーションを計算すると、``nat``になります。
*)
Check (fun (pT : predType nat) (x : nat) (A : pred_sort pT) =>
         @in_mem nat_eqType x (@mem nat_eqType pT A))
      (pair_predType nat_eqType)
      1
      (1, 2).
(**
(3) ``pT``を展開します。
*)
Check (fun (x : nat) (A : pred_sort (pair_predType nat_eqType)) =>
         @in_mem nat x (@mem nat (pair_predType nat_eqType) A))
      1
      (1, 2).
(**
(3') ``A``の型のコアーションを計算すると、
``pred_sort (pair_predType nat_eqType))``が``(nat * nat)``になります。
*)
Check (fun (x : nat) (A : (nat * nat)) =>
         @in_mem nat x (@mem nat (pair_predType nat_eqType) A))
      1
      (1, 2).
(**
(4) のこりの値も展開します。それでも、``@mem``の第2引数は``predType T``型が必要です。
*)
Check @in_mem nat 1 (@mem nat (pair_predType nat_eqType) (1, 2)).

(**
# MathCompで定義済みの``predType T``のインスタンス型

既成の``predType T``のインスタンス型を見てみます。
前述のとおり、``predType T``のインスタンス型が、
``pred_sort``のついての正準解になっていることから、
``Canonical Projections`` から``pred_sort``を拾うことで
見つけられます。ここで説明しやすい、いくつかを以下にしめします。
*)

Print Canonical Projections.
(**
```
seq        <- pred_sort ( seq_predType )
tuple_of   <- pred_sort ( tuple_predType )
pred       <- pred_sort ( predPredType )
simpl_pred <- pred_sort ( simplPredType )
```
 *)

(* Set Printing Coercions. *)

(**
## seq_predType

- 「台」seq T
- 「変換関数」pred_of_seq
 *)
Print seq_predType.                         (* 定義 *)
Check [:: 1; 2] : seq nat.                  (* 「台」 *)
Check 1 \in [:: 1; 2].                      (* \in の例 *)
Compute 1 \in [:: 1; 2].                    (* \in の例 *)
Check [:: 1; 2] : seq_predType nat_eqType.
Check seq_predType nat_eqType : predType nat_eqType. (* predType のインスタンス型 *)

(**
## tuple_predType

- 「台」n-tuple T
- 「変換関数」pred_of_seq (tval s))

tval でseqに変換して、pred_of_seq を適用する。
*)
Print tuple_predType.                       (* 定義 *)
Check [tuple 1; 2] : 2.-tuple nat.          (* 「台」 *)
Check 1 \in [tuple 1; 2].                   (* \in の例 *)
Compute 1 \in [tuple 1; 2].                 (* \in の例 *)
Check [tuple 1; 2] : tuple_predType 2 nat_eqType.
Check tuple_predType 2 nat_eqType : predType nat_eqType. (* predType のインスタンス型 *)

(**
## set_predType

``set <- pred_sort ( set_predType )`` がないことから、
これについては、別なメカニズムが働いてると思われる。
ここの記述は不正確かもしれない。

- 「台」set_type T（有限集合）
- 「変換関数」pred_of_set
*)
Print set_predType.                         (* 定義 *)
Check [set true] : set_type bool_finType. (* {set bool} *) (* 「台」 *)
Check true \in [set true].                  (* \in の例 *)
(*
  コアーションを表示すると、
  true \in pred_of_set [set true]
  になっている。変換関数がコアーションに出てくるのはおかしいので、

 *)
Compute true \in [set true].                (* \in の例 *)
Check [set true] : set_predType bool_finType.
Check set_predType bool_finType : predType bool_finType. (* predType のインスタンス型 *)

(**
## predPredType

- 「台」pred T（bool述語、T -> bool）
- 「変換関数」id
 *)
Print predPredType.                         (* 定義 *)
Check [pred n : nat | n < 3] : pred nat.    (* 「台」 *)
Check 1 \in [pred n : nat | n < 3].         (* \in の例 *)
Compute 1 \in [pred n : nat | n < 3].       (* \in の例 *)
Check [pred n : nat | n < 3] : predPredType nat.
Check predPredType nat : predType nat. (* predType のインスタンス型 *)

(**
## simplPredType

- 「台」simpl_pred T
- 「変換関数」pred_of_simpl
 *)
Print simplPredType.                               (* 定義 *)
Check (pred_of_argType nat_eqType) : simpl_pred nat. (* 「台」 *)

(* 趣旨から、\in の右には型を直接書きますが、 *)
Check 1 \in nat_eqType.                     (* \in の例 *)
(* ここの``\in``の右に関しては、コアーションが効いていることに注意してください。 *)
Check nat_eqType : predArgType.
Check pred_of_argType : forall T : predArgType, simpl_pred T.
(* コアーションの説明終わり。 *)

Check 1 \in (pred_of_argType nat_eqType).   (* \in の例 *)
Compute 1 \in (pred_of_argType nat_eqType). (* \in の例 *)
Check (pred_of_argType nat_eqType) : simplPredType nat.
Check simplPredType nat : predType nat. (* predType のインスタンス型 *)

(**
# ``mem``と``in_memの``中身

最後に``mem``と``in_memの``中身をみてみます。
*)

Print mem.
(**
```
fun (T : Type) (pT : predType T) =>
let '{| pred_sort := pred_sort0; topred := toP |} as pT0 :=
     pT return (pT0 -> mem_pred T) in
fun A : {| pred_sort := pred_sort0; topred := toP |} => Mem (T:=T) [eta toP A]
     : forall (T : Type) (pT : predType T), pT -> mem_pred T
```
memの定義は複雑なように見えますが、``predType T``型のインスタンスに
含まれる「変換関数」を``toP``として取り出して、実行しているのが判ります。
*)

Print in_mem.
(**
```
fun (T : Type) (x : T) => pred_of_mem^~ x
     : forall T : Type, T -> mem_pred T -> bool
```
これに対して、in_memは、pred_of_memで型を変換して、
引数の順番を入れ替えているだけのようです。
*)
Check @pred_of_mem : forall T : Type, mem_pred T -> {pred T}.
Check @pred_of_mem : forall T : Type, mem_pred T -> predPredType T.

(**

# まだ説明していないもの

## in_mem 内部使用

```
mem_pred   <- pred_sort ( memPredType )
```

## 他の型

```
bseq_of    <- pred_sort ( bseq_predType )
nat_pred   <- pred_sort ( nat_pred_pred )
bitseq     <- pred_sort ( bitseq_predType )
forall _, _ <- pred_sort ( boolfunPredType )
```
 *)

(* END *)


Require Import Coq.Bool.Bool.
Require Import Coq.Arith.PeanoNat.

(*FW:
i better off at FIRST implement a variant of [taboo] called [r2l] which is neither random nor taboo, namely bruteforce,  -- otherwise you can not keep my motivation at all I bet. hence let's get started. *)

(** *Objective function *)

(** so far, [designspace] is only supported a subset of nat. *)
Definition designSpace := nat.
Definition range := nat.
Definition objFun := designSpace -> range.
Definition ev (x:designSpace) (f:objFun) := f x.

(** *Non-randomized taboo alg. [r2l] *)
Definition r2l (f:objFun) : range :=
  (fix r2l' x xBest yBest :=
     let y := (ev x f) in
     let (xBest', yBest') := if y <? yBest then (x, y) else (xBest, yBest) in
     match x with
       | 0   => xBest
       | S n => r2l' n xBest' yBest'
     end) 10 10 100.

(* Fixpoint r2l'': f (x xBest: designSpace) (yBest : range) : designSpace := *)
Fixpoint r2l'' f (x: designSpace) (xBest: designSpace) (yBest : range) : designSpace :=
  let y := (ev x f) in
  let (xBest', yBest') := if y <? yBest then (x, y) else (xBest, yBest) in
  match x with
    | 0   => xBest
    | S n => r2l'' f n xBest' yBest'
  end.

Fixpoint r2l' f xInit := r2l'' f xInit 10 100.

Lemma defaultArgumentsWork: forall f, (r2l f) = (r2l' f 10).
Proof.
  intros.
  auto.
Qed.

Definition r2l' (f:objFun) (x__init : designSpace) :=

  Module TEST1.
  Definition parabola : objFun := fun x => (x-2)*2.
  Check parabola.
  Compute parabola.
  Check (ev 3 parabola).
  (* ev 3 parabola *)
  (*      : range *)
  Compute (ev 3 parabola).
  (* = 6 *)
  (* : range *)
  Compute (r2l TEST1.parabola).
End TEST1.

(*FW:
 Well done! next is multi-stared xor randomized ver. well both are hard! but former is relatively easy.

But before moving on, let's me try refoctoring: default argumenting.
*)

Module FW__DefaultArgument.
  Definition foo x y := x*y.
  Print foo.
  Definition foo2 x := x*2.
  Print foo2.
  Definition foo2' x := foo x 2.

  Theorem defaltArgumentWorks : forall x, foo2 x = foo2' x.
  Proof.
    intro.
    unfold foo2.
    unfold foo2'.
    unfold foo.
    reflexivity.
  Qed.
End FW__DefaultArgument.

(*FW:
 Making multi-started ver. is useful because, end of the day, I have to GA and SA -- both are population-based alg., namely multi started.
*)
(** **Vevify exhaustness *)
(** *[r2l__pop]: a population-based [r2l] *)
(*FW:
well, ok, now I have to import List lib. to deal with a bunch of particles. to do so, cf.
https://github.com/STakashimizu/ConShift/blob/master/Main.v
would be useful.
*)

Require Import Coq.Lists.List.
Import ListNotations.

Module FW__recallHowToHandleLists.
  Check [3; 4].
  Check [].
  Check ([] : list nat).
  Theorem empty_list_annotation: forall A:Type, ([] : list A) = (nil : list A).
    reflexivity.
  Qed.

  Check cons nil.
  Check cons 111 nil.
  Check cons 111 (cons 222 nil).

  Fixpoint len {A : Type} (ns: list A) : nat :=
    (fix len' ns l := match ns with
                       | nil => l
                       | cons _ ms => len' ms l+1
                     end
    ) ns 0.
  Theorem lis3: len [11; 22; 33] = 3.
    unfold len.
    simpl.
    reflexivity.
  Qed.

  (** FW: Good on us! *)
End FW__recallHowToHandleLists.

Check r2l.

Definition r2l__pop xs (f : objFun) :=
  let fix map__f xs := match xs with
                     | nil         => nil
                     | cons x' xs' => cons (f x') (map__f xs')
                   end in
  map__f xs.                      (* Refa: Find and use the built-in [map] function. *)

Theorem ifObjFunIsConvexThenAllPopsAreEndUpToMeetASamePositon: forall x x' : designSpace, forall f : objFun, (r2l f x) = (r2l f x').


(* On definit le predicat suivant *)

Definition multiple_de_3 (n : nat) := exists p:nat, n = 3 * p.

(* On admet le resultat suivant (demonstration non demandée) : *)

Lemma mult3_inv : forall n, multiple_de_3 n ->
                            n = 0 \/
                            exists p, n = 3 + p /\ multiple_de_3 p.
Admitted.

(* Note : on rappelle que "discriminate H" permet de resoudre tout
but contenant une hypothese H : n = p, ou n et p seont deux entiers
differents.

Par exemple :

Goal  forall n, 2 <> 4+ n.
intros n H;discriminate H.
Qed.
*)

(* Prouver le lemme ci-dessous (on utilisera mult3_inv) *)

Lemma One_not_mult3 : ~multiple_de_3 1.
  Proof.

(*
1 subgoal
______________________________________(1/1)
~ multiple_de_3 1
*)

  intro H.

(*
1 subgoal
H : multiple_de_3 1
______________________________________(1/1)
False
*)

  destruct (mult3_inv 1 H).

(*
2 subgoals
H : multiple_de_3 1
H0 : 1 = 0
______________________________________(1/2)
False

______________________________________(2/2)
False
*)

  discriminate H0.

(*
1 subgoal
H : multiple_de_3 1
H0 : exists p : nat, 1 = 3 + p /\ multiple_de_3 p
______________________________________(1/1)
False
*)

  destruct H0 as [p Hp].

(*
1 subgoal
H : multiple_de_3 1
p : nat
Hp : 1 = 3 + p /\ multiple_de_3 p
______________________________________(1/1)
False
*)

  destruct Hp as [H1 H2].

(*
1 subgoal
H : multiple_de_3 1
p : nat
H1 : 1 = 3 + p
H2 : multiple_de_3 p
______________________________________(1/1)
False
*)

  discriminate H1.
  Qed.


Require Import ZArith Omega Znumtheory.
Require Import Natsets MyNat Ztools Zeqm.

(** * Number theory : factorisation, computation of Bezout coefficients and modular inverse *)

(*
TODO : idéalement, on aurait un Z_prime_rect rapide, pour l'extraction
avec une fonction de factorisation.
Encore mieux, la preuve du un schéma d'induction devrait utiliser
la factorisation

  p1^a1 * p2^a2 * ..

en mémoizant le calcul sur les nombres premiers. (En supposant que la
compatibilité wrt. multiplication est plus économique pour la propriété
sur les nombres premiers, ce qui est probablement largement le cas pour
lagrange)

*)

(** Informative version, derived from the stdlib *)

Definition prime_dec_aux_inf:
  forall p m,
    { n | 1 < n < m /\ ~ rel_prime n p } +
    { forall n, 1 < n < m -> rel_prime n p }.
Proof.
  intros p m.
  case (Z_lt_dec 1 m); intros H1;
    [ | right; intros; exfalso; omega ].
  pattern m; apply natlike_rec; auto with zarith;
    [ right; intros; exfalso; omega | ].
  intros x Hx IH; destruct IH as [E|F].
    left; destruct E as (n,((H0,H2),H3));exists n; auto with zarith.

    destruct (rel_prime_dec x p) as [Y|N].
      right; intros n [HH1 HH2].
      case (Zgt_succ_gt_or_eq x n); auto with zarith.
      intros HH3; subst x; auto.

      case (Z_lt_dec 1 x); intros HH1.
        left; exists x; split; auto with zarith.
        right; intros n [HHH1 HHH2]; contradict HHH1; auto with zarith.
Defined.

(** Informative version, derived from the stdlib *)

Theorem not_prime_divide_inf:
 forall p, 1 < p -> ~ prime p -> { n | 1 < n < p  /\ (n | p) }.
Proof.
  intros p Hp Hp1.
  case (prime_dec_aux_inf p p); intros H1.
    case H1; intros n [Hn1 Hn2].
    generalize (Zgcd_is_pos n p); intros Hpos.
    case (Z_le_lt_eq_dec 0 (Z.gcd n p)); auto with zarith; intros H3.
      case (Z_le_lt_eq_dec 1 (Z.gcd n p)); auto with zarith; intros H4.
        exists (Z.gcd n p); split; auto.
          split; auto.
          apply Z.le_lt_trans with n; auto with zarith.
          generalize (Zgcd_is_gcd n p); intros tmp; inversion_clear tmp as [Hr1 Hr2 Hr3].
          case Hr1; intros q Hq.
          case (Zle_or_lt q 0); auto with zarith; intros Ht.
            absurd (n <= 0 * Z.gcd n p) ; auto with zarith.
            pattern n at 1; rewrite Hq; auto with zarith.

            apply Z.le_trans with (1 * Z.gcd n p); auto with zarith.
            pattern n at 2; rewrite Hq; auto with zarith.

          generalize (Zgcd_is_gcd n p); intros Ht; inversion Ht; auto.

        case Hn2; red.
        rewrite H4; apply Zgcd_is_gcd.

      generalize (Zgcd_is_gcd n p); rewrite <- H3; intros tmp;
        inversion_clear tmp as [Hr1 Hr2 Hr3].
      absurd (n = 0); auto with zarith.
      case Hr1; auto with zarith.

    elim Hp1; constructor; auto.
    intros n [Hn1 Hn2].
    case Zle_lt_or_eq with ( 1 := Hn1 ); auto with zarith.
    intros H2; subst n; red; apply Zis_gcd_intro; auto with zarith.
Defined.

Lemma Pcompare_notEq_notEq : forall a b,
    (Pcompare a b Lt <> Eq) /\ (Pcompare a b Gt <> Eq).
Proof.
  intros a; induction a; intros b; destruct b; split; intros E; simpl in E;
    try solve [
          inversion E |
          auto |
          eapply (proj1 (IHa _)); eauto |
          eapply (proj2 (IHa _)); eauto
        ].
Qed.

Lemma Pcompare_Eq_eq : forall a b, Pcompare a b Eq = Eq -> a = b.
Proof.
  intros a; induction a; intros b; destruct b; intros E; simpl in E;
    try solve [
          inversion E |
          auto |
          f_equal; apply IHa; eauto
        ].
  exfalso; eapply Pcompare_notEq_notEq; eauto.
  exfalso; eapply (proj1 (Pcompare_notEq_notEq _ _)); eauto.
Defined.

Lemma Zcompare_Eq_eq : forall n m : Z, (n ?= m) = Eq -> n = m.
Proof.
  intros [ | p | p ] [ | q | q] E; simpl in E;
    reflexivity ||
                solve [ inversion E ] ||
                (f_equal; eapply Pcompare_Eq_eq; eauto).
  fold (p ?= q)%positive; destruct ((p ?= q)%positive); auto || inversion E.
Defined.

Definition Z_le_lt_eq_dec x y : x <= y -> {x < y} + {x = y}.
Proof.
  pose (Zcompare_Eq_iff_eq :=
    fun x y => conj (fun E : (x ?= y) = Eq => Zcompare_Eq_eq x y E)
      (fun E : x = y =>
        eq_ind_r (fun x0 => (x0 ?= y) = Eq) (Z.compare_refl y) E)).
  intro H.
  apply Zcompare_rec with (n := x) (m := y); intros E.
    right. elim (Zcompare_Eq_iff_eq x y); auto with arith.
    left. elim (Zcompare_Eq_iff_eq x y); auto with arith.
    absurd (x > y); auto with arith.
Defined.

(** Induction on natural numbers via prime numbers and multiplication *)

Lemma Z_prime_rect : forall P : Z -> Type,
  ((P 0) ->
  (P 1) ->
  (forall n, prime n -> P n) ->
  (forall a b, P a -> P b -> P (a * b)) ->
    forall n, 0 <= n -> P n)%Z.
Proof.
  intros P P0 P1 Pprime Psplit.
  assert (Hind : forall (N : nat) n, 0 <= n -> (Z.abs_nat n < N)%nat -> P n).
    intro n ; induction n ; intros i ipos imax.
      (* i = n is the only interesting case *)
      exfalso; inversion imax.
      destruct (Z_le_lt_eq_dec i (Z_of_nat n)) as [|E]. zify; omega. apply IHn; zify; omega.
      rewrite E in *; clear E i ipos imax.

      (* Case: n is prime *)
      destruct (prime_dec (Z_of_nat n)) as [Hprime | Hnprime]. apply Pprime ; assumption.

      (* Case: n <= 1 *)
      destruct n. subst; apply P0.
      destruct n. subst; apply P1.

      (* Case: n = a * b *)
      set (z := Z_of_nat (S (S n))).
      assert (n_big : 1 < z) by (unfold z; zify; omega).
      destruct (not_prime_divide_inf _ n_big Hnprime) as [a [[amin amax] b_eqz]].
      destruct (Zdivide_inf _ _ b_eqz) as [b eqz]; clear b_eqz; rewrite eqz.

      (* Bounds on b come from bounds on a *)
      assert (Bb : 1 < b < z).
        assert (1 < b) by (apply Zmult_lt_reg_r with a; omega).
        split; auto.
        rewrite <- (Zmult_1_r b), eqz.
        apply Zmult_lt_compat_l; try omega.

      (* Empêche un bug d'omega (uncaught exception) *)
      assert (z = Z_of_nat (S (S n))) by auto; clearbody z.

      (* Main argument *)
      apply Psplit; apply IHn; zify; omega.

  intros n n_pos ; apply Hind with (S (Z.abs_nat n)) ; auto.
Defined.

Lemma Z_prime_ind : forall P : Z -> Prop,
  ((P 0) ->
  (P 1) ->
  (forall n, prime n -> P n) ->
  (forall a b, P a -> P b -> P (a * b)) ->
    forall n, 0 <= n -> P n)%Z.
Proof.
  intros; apply Z_prime_rect; auto.
Qed.

(** Bezout coefficients: a lot easier to use than the stdlib *)

Lemma bezout_inj : forall a b,
  {u : Z & {v | u * a + v * b = Z.gcd a b}}.
Proof.
  intros a b.
  destruct (euclid a b) as (u, v, d, E, H).
  destruct (Z_le_dec 0 d) as [L|L].
    exists u; exists v.
    rewrite (Zis_gcd_gcd _ _ _ L H).
    auto.

    exists (- u); exists (- v).
    assert (L2 : 0 <= - d) by omega.
    rewrite (Zis_gcd_gcd _ _ _ L2).
      rewrite <- E; ring.
      apply Zis_gcd_opp, Zis_gcd_sym; auto.
Qed.

Lemma rel_prime_bezout : forall a b, rel_prime a b ->
  {u : Z & {v | u * a + v * b = 1}}.
Proof.
  intros a b RP.
  rewrite <- (proj2 (Zgcd_1_rel_prime a b)); auto.
  apply bezout_inj.
Qed.

(** Multiplication is often injective in Z/pZ *)

Lemma modular_mult_inj : forall p n, prime p ->
  ~ (0 ≡ n [p]) -> forall x y, x * n ≡ y * n [p] -> x ≡ y [p].
Proof.
  intros p n Pp Nn x y E.
  apply eqm_minus_0, divide_eqm; notzero.

  assert (D : (p | (x - y) * n)).
    apply divide_eqm; notzero.
    ring_simplify.
    rewrite E.
    red; f_equal; ring.

  destruct (prime_mult _ Pp _ _ D) as [D1|D2]; auto.
  exfalso; apply Nn.
  symmetry; apply divide_eqm; auto.
  notzero.
Qed.

(** Computing the modular inverse in Z_pZ *)

Lemma modular_inverse : forall p x, prime p -> ~(x ≡ 0 [p]) -> { y | x * y ≡ 1 [p] }.
Proof.
  intros p x Pp Nd.
  assert (rel_prime (x mod p) p).
    apply Pp.
    assert (A : p > 0) by notzero; pose proof Z_mod_lt x p A.
    unfold eqm in Nd; rewrite Zmod_0_l in Nd.
    omega.

    destruct (rel_prime_bezout _ _ H) as (u, (v, Huv)).
    exists u.
    rewrite <- Huv.
    assert (REW : x mod p ≡ x [p]) by (red; rewrite Zmod_mod; auto) (* TODO dans un lemme *).
    rewrite REW.
    apply eqm_minus_0.
    ring_simplify.
    apply divide_eqm. notzero.
    exists (- v); auto.
Qed.


Require Import utf8.
Require Import TacticEx.
Require Import Discharge.
Require Import Coercions.

Require Import Comparison.
Require DecidableOrder.

Lemma trans_simp : ∀ A B : Type, ∀ R : A ⇒ A ⇒ B,
(∀ x y z, (R x y) = (R y z) ⇒ {(R x y) = (R x z)} + {(R y z) = (R x z)}) ⇒
∀ x y z, (R x y) = (R y z) ⇒ (R x y) = (R x z) ∧ (R y z) = (R x z).
Proof.
intros.
split;
induction (X x y z);
congruence.
Qed.

Module Type ComparisonSig.
Parameter A : Type.
Parameter compare : A ⇒ A ⇒ comparison.

Infix "?=" := compare (at level 70) : order_scope.
Open Scope order_scope.

Axiom compare_refl : ∀ x y, x ?= y = Eq ⇔ x = y.
Axiom compare_antisym : ∀ x y, CompOpp (x ?= y) = (y ?= x).
Axiom compare_trans : ∀ x y z, (x ?= y) = (y ?= z) ⇒ (x ?= y) = (x ?= z) ∧ (y ?= z) = (x ?= z).

End ComparisonSig.

Module CompareDecOrd (M : ComparisonSig) <: DecidableOrder.Sig.

Definition A :Type := M.A.
Definition le (x y : A) : bool := comparisonLe (M.compare x y).

Infix "≤" := le : order_scope.
Open Scope order_scope.

Lemma le_refl : ∀ x, x ≤ x.
Proof.
intros.
unfold le.
replace (M.compare x x) with Eq.
constructor.
symmetry.
applyRev M.compare_refl.
reflexivity.
Qed.

Lemma le_antisym : ∀ x y, x ≤ y ⇒ y ≤ x ⇒ x = y.
Proof.
unfold le.
intros.
applyFwd M.compare_refl.
pose (M.compare_antisym x y).
discharge [H, H0, e].
induction (M.compare x y); intros.
reflexivity.
rewrite <- e in H0.
elim H0.
elim H.
Qed.

Lemma le_trans : ∀ x y z, x ≤ y ⇒ y ≤ z ⇒ x ≤ z.
Proof.
unfold le.
intros x y z.
pose (s := (M.compare_trans x y z)).
discharge s.
pose (s := (M.compare_refl x y)).
discharge s.
pose (s := (M.compare_refl y z)).
discharge s.
dcase (M.compare x y); dcase (M.compare y z);
intros;
try elim H1; try elim H2;
try (destruct (s1 (refl_equal _)); rewrite <- H3; constructor).
replace x with y.
rewrite H.
constructor.
firstorder.
replace z with y.
rewrite H0.
constructor.
firstorder.
Qed.

Lemma le_total : ∀ x y, {x ≤ y} + {y ≤ x}.
Proof.
intros.
unfold le.
rewrite <- (M.compare_antisym x y).
induction (M.compare x y);
simpl;
auto.
Defined.

End CompareDecOrd.


Require Import Coq.Lists.List.

Import ListNotations.

Fixpoint merge {A : Type} (leb : A -> A -> bool) (l1 l2 : list A) : list A :=
  let fix aux (l2 : list A) : list A :=
    match (l1, l2) with
    | ([], _) => l2
    | (_, []) => l1
    | (x1 :: l1, x2 :: l2) =>
      if leb x1 x2 then
        x1 :: merge leb l1 (x2 :: l2)
      else
        x2 :: aux l2
    end in
  aux l2.

Module Stack.
  Definition t (A : Type) := list (option (list A)).

  Fixpoint add {A : Type} (leb : A -> A -> bool) (s : t A) (l : list A) : t A :=
    match s with
    | [] => [Some l]
    | None :: s => Some l :: s
    | Some l' :: s => None :: add leb s (merge leb l l')
    end.

  Fixpoint of_list {A : Type} (leb : A -> A -> bool) (l : list A) : t A :=
    match l with
    | [] => []
    | x :: l => add leb (of_list leb l) [x]
    end.

  Fixpoint to_list {A : Type} (leb : A -> A -> bool) (s : t A) : list A :=
    match s with
    | [] => []
    | None :: s => to_list leb s
    | Some l :: s => merge leb l (to_list leb s)
    end.
End Stack.

Definition sort {A : Type} (leb : A -> A -> bool) (l : list A) : list A :=
  Stack.to_list leb (Stack.of_list leb l).

Module Test.
  Require Import Coq.Arith.Compare_dec.

  Definition l := [5; 1; 3; 7; 8 ;0; 0; 3 ;6 ;5 ;4].
  Definition sorted_l := [0; 0; 1; 3; 3; 4; 5; 5; 6; 7; 8].

  Definition ok : sort leb l = sorted_l :=
    eq_refl.
End Test.


Require Import ZArith.
Require Import Ring.

Require Import Basics.

Theorem plus_inverse_left (x y : _) : x = (x + y - y)%Z.
ring.
Qed.

Theorem plus_inverse_right (x y : _) : y = (x + y - x)%Z.
ring.
Qed.

Print plus_inverse_left.

Definition Image {A B} (func : A -> B) :=
  {y : B | exists x : A, y = func x}.

Program Definition makeImage {A B} (func : A -> B) (x : A) : Image func.
refine (exist _ _ _).
eauto.
Unshelve.
assumption.
Defined.

Definition unwrapImage {A B} {func : A -> B} (img: Image func) := proj1_sig img.

Theorem compose_image_weaken {A B C} {g : B -> C} {f : A -> B}
  : Image (compose g f) -> Image g.
intro.
destruct X.
refine (exist _ x _).
destruct e.
unfold compose in H.
refine (ex_intro _ _ _).
exact H.
Defined.

Theorem lemma_zwei :

(* This bijection only requires
bwd to be a left inverse of fwd.

Equivalently, fwd must be injective and bwd
only has to be injective respectively to the image of fwd. *)
Record LeftBijection (A B : Type) := {
  fwd : A -> B;
  bwd : Image fwd -> A;
  left_inv : forall x, bwd (makeImage fwd x) = x
}.
Arguments fwd {_ _}.
Arguments bwd {_ _}.
Arguments left_inv {_ _}.
Notation "x <->> y" := (LeftBijection x y)
  (at level 99, right associativity, y at level 200).
(*Infix "<->>" := LeftBijection (at level 10).*)

Program Definition plus_right : Z -> Z <->> Z := fun x => {|
  fwd y := (x + y)%Z;
  bwd z := (z - x)%Z;
|}.
Next Obligation.
symmetry.
apply plus_inverse_right.
Defined.

Program Definition plus_left : Z <->> Z -> Z := {|
  fwd := Z.add;
  bwd img := unwrapImage img 0%Z;
|}.
Next Obligation.
destruct x; reflexivity.
Defined.

(* Idk what this means *)
Program Definition plus_inv : Z <->> Z <->> Z := {|
  fwd x := {|
    fwd y := (x + y)%Z;
    bwd z := (z - x)%Z;
  |};
  bwd img := (unwrapImage img).(fwd) 0%Z;
|}.
Next Obligation.
symmetry.
apply plus_inverse_right.
Qed.
Next Obligation.
destruct x; reflexivity.
Qed.

Program Definition comp_inv {A B C} (f : A <->> B) (g : B <->> C)
  : A <->> C := {|
  fwd := compose g.(fwd) f.(fwd);
  bwd := _;
|}.
Next Obligation.
Check (f.(left_inv)).
(* apply (compose_image_weaken) in X. *)
refine (f.(bwd) _).
(* Stash this doge for later *)
set (fwd_g := compose_image_weaken X).
refine (exist _ (g.(bwd) fwd_g) _).
refine (ex_intro _ _ _).
rewrite <- (left_inv g (fwd f _)).
f_equal.
(* apply lemma_zwei *)

destruct X.
unfold compose in *.
destruct e.
refine (ex_intro _ x0 _).
exact H.

Next Obligation.
symmetry.
apply plus_inverse_right.
Defined.


Coq < Section Scottish.

Coq < Require Import Classical.

Coq < Variables S R W M G : Prop.
S is assumed
R is assumed
W is assumed
M is assumed
G is assumed

Coq < Hypothesis rule1 : ~S -> R.
rule1 is assumed

Coq < Hypothesis rule2 : W \/ ~R.
rule2 is assumed

Coq < Hypothesis rule3 : M -> ~G.
rule3 is assumed

Coq < Hypothesis rule4 : G <-> S.
rule4 is assumed

Coq < Hypothesis rule5 : W -> S /\ M.
rule5 is assumed

Coq < Hypothesis rule6 : S -> W.
rule6 is assumed

Coq < Lemma NoMember : False.
1 subgoal

  S : Prop
  R : Prop
  W : Prop
  M : Prop
  G : Prop
  rule1 : ~ S -> R
  rule2 : W \/ ~ R
  rule3 : M -> ~ G
  rule4 : G <-> S
  rule5 : W -> S /\ M
  rule6 : S -> W
  ============================
   False

NoMember < tauto.
No more subgoals.

NoMember < Qed.
tauto.

NoMember is defined


(*Definicion de LP*)
Inductive LP: Type :=
  | T
  | F
  | var
  | neg (F1: LP)
  | dis (F1: LP) (F2: LP)
  | con (F1: LP) (F2: LP)
  | imp (F1: LP) (F2: LP).

Compute dis.

(*Parentesis*)
Fixpoint parentesis (alpha: LP): nat :=
    match alpha with
    | T => 0
    | F => 0
    | var => 0
    | neg F1 => 2 + parentesis(F1)
    | dis F1 F2 => 2 + parentesis(F1) + parentesis(F2)
    | con F1 F2 => 2 + parentesis(F1) + parentesis(F2)
    | imp F1 F2 => 2 + parentesis(F1) + parentesis(F2)
    end.

Compute parentesis (dis (con (neg (var)) (var)) (imp (var) (var))).

(*Negacion*)
Fixpoint negacion (alpha: LP): nat :=
    match alpha with
    | T => 0
    | F => 0
    | var => 0
    | neg F1 => 1 + negacion(F1)
    | dis F1 F2 => negacion(F1) + negacion(F2)
    | con F1 F2 => negacion(F1) + negacion(F2)
    | imp F1 F2 => negacion(F1) + negacion(F2)
    end.

Compute negacion (con (neg (T)) (neg (T))).

(*Variables*)
Fixpoint variables (alpha: LP): nat :=
    match alpha with
    | T => 1
    | F => 1
    | var => 1
    | neg F1 => variables(F1)
    | dis F1 F2 => variables(F1) + variables(F2)
    | con F1 F2 => variables(F1) + variables(F2)
    | imp F1 F2 => variables(F1) + variables(F2)
    end.

Compute variables (imp (neg (T)) (dis (T) (F))).

Notation "~ p" := (neg (p)).
Notation "p && q" := (con (p) (q)).
Notation "p || q" := (dis (p) (q)).
Notation "p -> q" := (imp (p) (q)).

Compute parentesis ((T && F) && ~ (T -> F)).

(*Definicion de arbol binario*)
Inductive Tree: Type :=
    | nil
    | leave (n: nat)
    | branch (n: nat) (l1: Tree) (l2: Tree).

(*Suma arbol*)
Fixpoint suma (t: Tree): nat :=
    match t with
    | nil => 0
    | leave n => n
    | branch n l1 l2 => n + suma(l1) + suma(l2)
    end.

Compute suma (branch (5) (branch (3) (leave (1)) (leave (1))) (leave (4))).

(*Contar nodos*)
Fixpoint contNodos (t: Tree): nat :=
    match t with
    | nil => 0
    | leave n => 1
    | branch n l1 l2 => 1 + contNodos(l1) + contNodos(l2)
    end.

Compute contNodos (branch (5) (branch (3) (leave (1)) (leave (1))) (leave (4))).

(*Arbol horizontal*)
Fixpoint refHorizontal (t: Tree): Tree :=
    match t with
    | nil => t
    | leave n => t
    | branch n l1 l2 => branch n (refHorizontal(l2)) (refHorizontal(l1))
    end.

Compute refHorizontal (branch (5) (branch (3) (leave (1)) (leave (2))) (leave (4))).

(*Potencia*)
Fixpoint potencia (n1: nat) (n2: nat): nat :=
    match n1, n2 with
    | _, O => 1
    | O, _ => 0
    | S a, S b => n1 * (potencia (n1) (b))
    end.

Compute potencia 0 5.

(*Igualdad*)
Fixpoint igualdad (n1: nat) (n2:nat): Prop :=
    match n1, n2 with
    | O, O => True
    | O, _ => False
    | _, O => False
    | S a, S b => igualdad (a) (b)
    end.

Compute igualdad 5 5.

(*Resta*)
Fixpoint resta (n1: nat) (n2: nat): nat :=
    match n1, n2 with
    | O, O => 0
    | _, O => n1
    | O, _ => 0
    | S a, S b => resta a b
    end.

Compute resta 112 100.


From mathcomp Require Export ssreflect eqtype ssrbool.

Lemma sval_inj_pred {A: Type} (P: pred A) (a b: {x : A | P x}):
  sval a = sval b -> a = b.
Proof.
  destruct a, b. rewrite /sval. intros. subst; f_equal. apply bool_irrelevance.
Qed.

Require ProofIrrelevance.

Lemma sval_inj_pi {A: Type} (P: A -> Prop) (a b: {x : A | P x}):
  sval a = sval b -> a = b.
Proof.
  destruct a, b. rewrite /sval. intros. subst; f_equal. apply ProofIrrelevance.proof_irrelevance.
Qed.


(* Nuevo constructor inteligente. *)
Definition smartTrie2 (t1 t2: binTrie2): binTrie2 :=
match t1, t2 with
| empty2, empty2 => empty2
| leaf2 j x, empty2 => leaf2 (2*j) x
| empty2, leaf2 j x => leaf2 (2*j+1) x
| _, _ => trie2 t1 t2
end.


(* -*- mode: coq; mode: visual-line -*-  *)
(** * Connectedness *)
Require Import Basics.
Require Import Types.
Require Import TruncType.

Require Import UnivalenceImpliesFunext.
Require Import HProp.
Require Import EquivalenceVarieties.
Require Import Extensions.
Require Import Factorization.
Require Export Modality.        (* [Export] since the actual definitions of connectednes appear there, in the generality of a modality. *)
Require Import Truncations.Core.
Import TrM.

Local Open Scope path_scope.
Local Open Scope trunc_scope.

(** There is a slight controversy of indexing for connectedness — in particular, how the indexing for maps shoud relate to the indexing for types.  One may reasonably take the connectedness of a map to correspond either to that of its *fibers*, or of its *cofiber*; these differ by 1.  The traditional topological indexing uses the cofiber.  We use the fiber, as does Lurie in [HTT]; but we choose to agree with the traditional indexing on types, while Lurie agrees with it on maps.

Currently, the translation is therefore as follows:

       HoTT              Traditional       Lurie

Map    (n-1)-connected   n-connected       n-connective
Type   n-connected       n-connected       (n+1)-connective

A handy benchmark: under our indexing, the map [S1 -> 1] is 0-connected but not 1-connected, while the map [1 -> S1] is (–1)–connected but not 0-connected.

One reason for our choice is that this way, the n-truncated and n-connected maps are the modal and modally-connected maps for the n-truncation modality.  Many of the basic lemmas about connected maps are in fact true for any modality, and can be found in [Modality.v].  Thus, here we consider mainly properties that involve the interaction of connectedness at different truncation levels. *)

Section Extensions.
  Context `{Univalence}.

(** ** Truncatedness of the type of extensions *)

(** A key lemma on the interaction between connectedness and truncatedness: suppose one is trying to extend along an n-connected map, into a k-truncated family of types (k ≥ n).  Then the space of possible extensions is (k–n–2)-truncated.

(Mnemonic for the indexing: think of the base case, where k=n; then we know we can eliminate, so the space of extensions is contractible.)

This lemma is most useful via corollaries like the wedge-inclusion, the wiggly wedge, and their n-ary generalizations. *)
Lemma istrunc_extension_along_conn {m n : trunc_index}
  {A B : Type} (f : A -> B) `{IsConnMap n _ _ f}
  (P : B -> Type) {HP : forall b:B, IsTrunc (m +2+ n) (P b)}
  (d : forall a:A, P (f a))
: IsTrunc m (ExtensionAlong f P d).
Proof.
  revert P HP d. induction m as [ | m' IH]; intros P HP d; simpl in *.
  (* m = –2 *)
  - exists (extension_conn_map_elim n f P d).
    intros y. apply (allpath_extension_conn_map n); assumption.
    (* m = S m' *)
  - intros e e'. refine (trunc_equiv _ (path_extension e e')).
(* magically infers: paths in extensions = extensions into paths,
                       which by induction is m'-truncated. *)
Defined.

(** ** Connectivity of pointed types *)

(** The connectivity of a pointed type and (the inclusion of) its point are intimately connected. *)

(** We can't make both of these [Instance]s, as that would result in infinite loops. *)
Global Instance conn_pointed_type {n : trunc_index} {A : Type} (a0:A)
 `{IsConnMap n _ _ (unit_name a0)} : IsConnected n.+1 A | 1000.
Proof.
  apply isconnected_from_elim.
  intros C HC f. exists (f a0).
  refine (conn_map_elim n (unit_name a0) _ (fun _ => idpath)).
Defined.

Definition conn_point_incl {n : trunc_index} {A : Type} (a0:A)
       `{IsConnected n.+1 A} : IsConnMap n (unit_name a0).
Proof.
  apply conn_map_from_extension_elim.
  intros P ?. set (PP := fun a => BuildTruncType n (P a)).
  assert (QQ := isconnected_elim n.+1 (TruncType n) PP).
  destruct QQ as [[Q0 HQ] e].
  assert (e' := fun a => ap trunctype_type (e a)); simpl in e'. clear HQ e.
  intros d. set (d0 := d tt).
  exists (fun a => (transport idmap (e' a0 @ (e' a)^) d0)).
  intros []. change (d tt) with (transport idmap 1 d0).
  apply ap10, ap, concat_pV.
Defined.

Hint Immediate conn_point_incl : typeclass_instances.

(** TODO: generalise the above to any map with a section. *)

End Extensions.

(** ** Decreasing connectedness *)

(** An [n.+1]-connected type is also [n]-connected.  This obviously can't be an [Instance]! *)
Definition isconnected_pred n A `{IsConnected n.+1 A}
: IsConnected n A.
Proof.
  apply isconnected_from_elim; intros C ? f.
  refine (isconnected_elim n.+1 C f).
Defined.

(** By induction, an [n.+1]-connected type is also [-1]-connected. *)
Definition merely_isconnected n A `{IsConnected n.+1 A}
  : merely A.
Proof.
  induction n as [|n IHn].
  - apply center; assumption.
  - apply IHn, isconnected_pred; assumption.
Defined.

Definition isconnected_pred_add n m A `{H : IsConnected (n +2+ m) A}
  : IsConnected m A.
Proof.
  induction n.
  1: assumption.
  apply IHn.
  apply isconnected_pred.
  assumption.
Defined.

(** ** Connectedness of path spaces *)

Global Instance isconnected_paths `{Univalence} {n A}
       `{IsConnected n.+1 A} (x y : A)
: IsConnected n (x = y).
Proof.
  refine (contr_equiv' _ (equiv_path_Tr x y)^-1).
Defined.

(** ** 0-connectedness *)

(** To be 0-connected is the same as to be (-1)-connected and that any two points are merely equal.  *)
Definition merely_path_is0connected `{Univalence}
           (A : Type) `{IsConnected 0 A} (x y : A)
: merely (x = y).
Proof.
  refine ((equiv_path_Tr x y)^-1 (path_contr (tr x) (tr y))).
Defined.

Definition is0connected_merely_allpath `{Univalence}
           (A : Type) `{merely A}
           (p : forall (x y:A), merely (x = y))
: IsConnected 0 A.
Proof.
  strip_truncations.
  apply (contr_inhabited_hprop).
  - apply hprop_allpath; intros z w.
    strip_truncations.
    refine (equiv_path_Tr z w (p z w)).
  - apply tr; assumption.
Defined.

(** 0-connected types are indecomposable *)
Global Instance indecomposable_0connected `{Univalence}
       (X : Type) `{IsConnected 0 X}
: Indecomposable X.
Proof.
  assert (IsConnected (-1) X) by refine (isconnected_pred (-1) X).
  constructor.
  - intros A B f.
    assert (z := center (merely X) : merely X); generalize z.
    refine (Trunc_rec _).
    + apply ishprop_sum; try exact _.
      intros l r. strip_truncations.
      exact (not_is_inl_and_inr' (f z) (l z) (r z)).
    + intros x.
      remember (f x) as y eqn:p.
      destruct y as [a|b]; [ left | right ]; intros x'.
      all:assert (q := merely_path_is0connected X x x');
        strip_truncations.
      all:refine (transport _ (ap f q) _).
      all:exact (transport _ p^ tt).
  - intros nx.
    apply (Trunc_rec (n := -1) nx).
    exact (center (merely X)).
Defined.

(* Truncation preserves connectedness. Note that this is for different levels. *)
Global Instance isconnected_trunc {X : Type} n m `{IsConnected n X}
  : IsConnected n (Tr m X).
Proof.
  unfold IsConnected.
  serapply (contr_equiv' _ (Trunc_swap n m X)^-1).
Defined.

Section Wedge_Incl_Conn.

(** ** Connectivity of the wedge into the product.

A very useful form of the key lemma [istrunc_extension_along_conn] is the connectivity of the wedge into the product, for a pair of pointed spaces.  In fact this can be formulated without mentioning the wedge per se (so, without requiring HIT’s), since the statement only needs to talk about maps out of the wedge.

Once again, we believe that the type of the conclusion is an hprop (though we do not prove it) — essentially because it is wrapping up an elimination principle and its corresponding computation rule — and so we make the proof of this result opaque. *)

Context `{Univalence}
  {m n : trunc_index}
  {A : Type} (a0 : A) `{IsConnected m.+1 A}
  {B : Type} (b0 : B) `{IsConnected n.+1 B}
  (P : A -> B -> Type) {HP : forall a b, IsTrunc (m +2+ n) (P a b)}
  (f_a0 : forall b:B, P a0 b)
  (f_b0 : forall a:A, P a b0)
  (f_a0b0 : f_a0 b0 = f_b0 a0).

Corollary isconn_wedge_incl
: { f : forall a b, P a b
  & { e_a0 : forall b, f a0 b = f_a0 b
  & { e_b0 : forall a, f a b0 = f_b0 a
  & e_b0 a0 = (e_a0 b0) @ f_a0b0 }}}.
Proof.
  assert (goal_as_extension :
    ExtensionAlong (unit_name a0)
      (fun a => ExtensionAlong (unit_name b0) (P a) (unit_name (f_b0 a)))
      (unit_name (f_a0 ; (unit_name f_a0b0)))).
  - apply (extension_conn_map_elim m).
    + apply (conn_point_incl a0).
    + intros a.
      apply (istrunc_extension_along_conn (n := n)).
      * apply (conn_point_incl b0).
      * apply HP.
  - destruct goal_as_extension as [f_eb name_ea_eab].
    assert (ea_eab := name_ea_eab tt); clear name_ea_eab.
    exists (fun a => pr1 (f_eb a)).
    exists (fun b => apD10 (ea_eab ..1) b).
    exists (fun a => pr2 (f_eb a) tt).
    (* The last component is essentially (g' ..2), wrapped in a bit of path-algebra. *)
    apply moveL_Mp.
    apply (concatR (apD10 (ea_eab ..2) tt)).
    set (ea := ea_eab ..1). generalize ea; simpl. clear ea_eab ea. intros.
    rewrite transport_arrow. rewrite transport_const. rewrite transport_paths_Fl.
    exact 1%path.
Qed.

(** It is easier to apply the above result with its components separated. *)
Definition wedge_incl_elim : forall a b, P a b
  := isconn_wedge_incl.1.

Definition wedge_incl_comp1 : forall b, wedge_incl_elim a0 b = f_a0 b
  := isconn_wedge_incl.2.1.

Definition wedge_incl_comp2 : forall a, wedge_incl_elim a b0 = f_b0 a
  := isconn_wedge_incl.2.2.1.

Definition wedge_incl_comp3
  : wedge_incl_comp2 a0 = (wedge_incl_comp1 b0) @ f_a0b0
  := isconn_wedge_incl.2.2.2.

End Wedge_Incl_Conn.

Definition wedge_incl_elim_uncurried `{Univalence}
  {m n : trunc_index}
  {A : Type} (a0 : A) `{IsConnected m.+1 A}
  {B : Type} (b0 : B) `{IsConnected n.+1 B}
  (P : A -> B -> Type) {HP : forall a b, IsTrunc (m +2+ n) (P a b)}
  (fs : {f_a0 : forall b:B, P a0 b
        & { f_b0 : forall a:A, P a b0
        & f_a0 b0 = f_b0 a0 }})
  : forall (a : A) (b : B), P a b.
Proof.
  destruct fs as [f_a0 [f_b0 f_a0b0]].
  refine (wedge_incl_elim _ _ _ _ _ f_a0b0).
Defined.


(** This file defines the countable types. There is some liberty in
    the notion of countable in a constructive setting. In this file we
    choose countable types to be equipped with a retraction into the
    natural number (which, because of [ConstructiveEpsilon], is
    equivalent to a surjection from natural number and decidable
    equality). Decidability of equality plays an important role in the
    design of concrete quotients of countable types, both to lift
    [ConstructiveEpsilon] and to define quotients.

    A type [A] is called countable if [option A] is a retract of the
    natural numbers. When [A] is inhabited, then it is equivalent to a
    retraction of [A] into the natural numbers, but this definition
    also includes the empty set.

    Being countable is defined here as a type class, making the
    hypothesis that the chosen retraction is unlikely to be tractable
    (few of the instances defined in this file are) and that it's not
    to be used in a real program, where some control will be
    needed. *)

Require Import Coq.Classes.RelationClasses.
Require Import Coq.NArith.NArith.
Require Import DProp.
Require FinSet.Lib.CEExt.
Require Import FinSet.Quotients.Retract.

Import List.ListNotations.
Local Open Scope list_scope.

Class Countable A := countable : Retract nat (option A).

(** We also use an inhabitation type class, which will help avoid the
    [option] type in our calculation. *)
Class Inhabited A := inhabitant : A.

Definition to_nat {A} {_:Countable A} (x:A) : nat :=
  countable.(inj) (Some x).
Definition of_nat {A} {_:Countable A} {_:Inhabited A} : nat -> A :=
  (retract_nat_inh countable inhabitant).(proj).

Lemma nat_retract A {_:Countable A} {_:Inhabited A} : forall x, of_nat (to_nat x) = x.
Proof.
  intros *. unfold of_nat, to_nat. cbn.
  now rewrite !retract.
Qed.

(** The typical way of proving that a type is countable is to exhibit
    a retraction towards a known countable type. *)
Program Definition countable_of_retract {A B} {_:Countable A} (r:Retract A B) : Countable B :=
  Retract.compose countable (Retract.opt_lift r).

(** In some more advanced cases, we may need [B] to be lifted to
    provide a default element. *)
Program Definition countable_of_opt_retract
        {A B} {_:Countable A} (r:Retract A (option B)) : Countable B :=
  Retract.opt_compose countable r.

(** Countable types have decidable equality: it is sufficient to test
    the equality of their code. *)
Program Definition countable_eq_dec {A} {_:Countable A} (x y:A) : {x=y}+{x<>y} :=
  dec_lift (
      PeanoNat.Nat.eq_dec
        (countable.(inj) (Some x))
        (countable.(inj) (Some y)))
.
Next Obligation.
  intros * h.
  apply f_equal with (f:=countable.(proj)) in h.
  rewrite !retract in h.
  congruence.
Qed.
Next Obligation.
  intros * h.
  congruence.
Qed.

Program Definition eq_countable {A} {_:Countable A} (x y:A) : DProp := {|
  dec := countable_eq_dec x y
|}.

Instance eq_countable_eq {A} {_:Countable A} : Equivalence eq_countable.
Proof eq_equivalence.

(** * Inhabited instances *)

Instance inhabited_unit : Inhabited unit := tt.
Instance inhabited_option A : Inhabited (option A) := None.
Instance inhabited_list   A : Inhabited (list   A) := [].

Instance inhabited_pair {A B} {_:Inhabited A} {_:Inhabited B} : Inhabited (A*B) :=
  (inhabitant,inhabitant).

Instance inhabited_sum_left  {A B} {_:Inhabited A} : Inhabited (A+B) := inl inhabitant.
Instance inhabited_sum_right {A B} {_:Inhabited B} : Inhabited (A+B) := inr inhabitant.

(** * Countable instances *)

Instance countable_nat : Countable nat := retract_nat_opt Retract.id.
Instance countable_n   : Countable N := retract_nat_opt retract_nat_N.

Program Instance countable_empty_set : Countable Empty_set := {|
  inj x := 0;
  proj x := None
|}.
Next Obligation.
  intros [ [] | ].
  reflexivity.
Qed.

(** Lists of a countable type are countable. The essential component
    is [Retract.retract_N_list_nat]. This particular instance will be
    used to define most others. *)
Instance countable_list {A} {_:Countable A} : Countable (list A).
Proof.
  refine (countable_of_retract (A:=list nat) _).
  { exact (countable_of_retract retract_N_list_nat). }
  refine {| inj  := List.map (fun x => countable.(inj) (Some x));
            proj := List.flat_map (fun x => match countable.(proj) x with
                                            | Some x => [x]
                                            | None   => []
                                            end)
         |}.
  intros l.
  rewrite List.flat_map_concat_map, List.map_map.
  transitivity (List.concat (List.map (fun x => [x]) l)). all:cycle 1.
  { induction l as [ | a l hl ].
    + cbn. reflexivity.
    + cbn. rewrite hl. reflexivity. }
  f_equal.
  apply List.map_ext. intros x.
  now rewrite retract.
Defined.

Program Instance countable_unit : Countable unit :=
  countable_of_retract {|
      inj  x := [];
      proj x := tt
  |}
.
Next Obligation. now intros []. Qed.

(** This could be established using [Retract.retract_nat_opt]. But to
    demonstrate how lists can be used, we shall prefer a definition
    based on lists. *)
Program Instance countable_option {A} {_:Countable A} : Countable (option A) :=
   countable_of_retract {|
       inj  x := match x return _ with
                 | Some x => [x]
                 | None   => []
                 end;
       proj l := match l return _ with
                 | [x] => Some x
                 | []  => None
                 | _ => None
                 end
     |}.
Next Obligation.
  intros A ? [x|].
  all:reflexivity.
Qed.

Program Instance countable_pair {A B} {_:Countable A} {_:Countable B} : Countable (A*B) :=
  countable_of_opt_retract {|
      inj  x := match x return _ with
                | Some(a,b) => [to_nat (Some a);to_nat (Some b)]
                | None      => []
                end;
      proj l := match l return _ with
                | [] => None
                | [a;b] => match of_nat a , of_nat b return _ with
                           | Some a',Some b' => Some (a',b')
                           | _      ,_       => None
                           end
                | _ => None
                end
    |}.
Next Obligation.
  intros A B ? ? [[a b]|].
  + now rewrite !nat_retract.
  + reflexivity.
Qed.

Program Instance countable_sum {A B} {_:Countable A} {_:Countable B} : Countable (A+B) :=
  countable_of_opt_retract {|
      inj  x := match x return _ with
                | Some (inl a) => [0;to_nat (Some a)]
                | Some (inr b) => [1;to_nat (Some b)]
                | None         => []
                end;
      proj l := match l return _ with
                | []    => None
                | [0;a] => match of_nat a return _ with
                           | Some a' => Some (inl a')
                           | _ => None
                           end
                | [1;b] => match of_nat b return _ with
                           | Some b' => Some (inr b')
                           | _ => None
                           end
                | _ => None
                end
    |}.
Next Obligation.
  intros A B ? ? [[a|b]|].
  all:rewrite ?nat_retract.
  all: reflexivity.
Qed.

(** * Constructive indefinite description *)

(** The results of [CEExt] can be lifted to countable types. This
    liting is not quite the identity because of the extra [option] in
    the definition of countable types. *)

(** The main ingredient of the lifting is a lifting of (decidable)
    predicate to the option type, such that [{x:A|P x}] is isomorphic
    to [{x:option A|Liftp P x}]. *)

Definition Liftp {A} (P:A->DProp) : option A -> DProp := fun x =>
  match x with
  | Some a => P a
  | None   => DFalse
  end
.

Lemma Liftp_exists {A} {P:A->DProp} : (exists x, P x) -> exists x, Liftp P x.
Proof.
  intros [x h].
  now exists (Some x).
Qed.

Program Definition liftp_extract {A} {P:A->DProp} (x : {x|Liftp P x}) : {x|P x} :=
  match x return Liftp P x -> {x|P x} with
  | Some x => fun h => x
  | None => fun h => _
  end _
.
Next Obligation.
  cbn.
  intros ? ? ? [].
Qed.
Next Obligation.
  intros **.
  apply proj2_sig.
Defined.

Lemma liftp_extract_ext A (P:A->DProp) P' (x:{x|Liftp P x}) (y:{y|Liftp P' y}) :
  proj1_sig x = proj1_sig y -> proj1_sig (liftp_extract x) = proj1_sig (liftp_extract y).
Proof.
  destruct x as [[x|] hx], y as [[y|] hy]. all:cbn in *.
  all:try contradiction.
  congruence.
Qed.

Section Choice.

 Context {A} {cA:Countable A}.
 Context (P:A->DProp).

 Definition choice (h:exists x, P x) : {x|P x} :=
   liftp_extract (
       CEExt.choice
         countable.(inj)
         countable.(proj)
         countable.(retract _ _)
         (Liftp P)
         (Liftp_exists h))
 .

 Definition choose (h:exists x, P x) : A := proj1_sig (choice h).

 Lemma choose_spec : forall h, P (choose h).
 Proof.
   intros **. unfold choose.
   apply proj2_sig.
 Qed.

End Choice.
Arguments choose_spec A cA P h : clear implicits.

Section ChoiceExt.

 Import Morphisms.

 Context (A:Type) (cA:Countable A).

 Local Notation "'Π' x y ':' R ',' S" := (respectful_hetero _ _ _ _ R%signature (fun x y => S)%signature) (at level 200, x ident, y ident).

 Lemma choose_ext : Proper (Π P P' : eq==>eq_dprop, Π _ _:(fun _ _ => True), @eq A) choose.
 Proof.
   unfold Proper,respectful_hetero,respectful,choose,choice.
   intros P P' hP eP eP' _.
   apply liftp_extract_ext.
   apply CEExt.choose_ext. all:unfold respectful.
   all: eauto.
   congruence.
   { intros [x|] [y|] [=]. all:subst;cbn in hP|-*.
     + eauto.
     + tauto. }
 Qed.

End ChoiceExt.


Require Export D.

(** **** Exercise: 2 stars (ins_SearchTree)  *)
(** This one is pretty easy, even without proof automation.
  Copy-paste your proof of insert_SearchTree from Extract.v.
  You will need to apply [balance_SearchTree] in two places.
 *)
 Lemma ins_SearchTree:
 forall x vx s lo hi,
                  lo <= int2Z x ->
                  int2Z x < hi ->
                  SearchTree' lo s hi ->
                  SearchTree' lo (ins x vx s) hi.
Proof. exact FILL_IN_HERE. Qed.


(*|
#################################################################
Coq - return value of type which is equal to function return type
#################################################################

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

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

By some theorem we know that type ``A`` equals type ``B``. How can I
tell this to Coq compiler during type checking?

I want to implement a non-empty tree such that each node know its
size:
|*)

Require Import Coq.ZArith.ZArith. (* .none *)
Inductive Struct: positive -> Type :=
| Leaf : Struct 1%positive
| Inner: forall {n m}, Struct n -> Struct m -> Struct (n + m).

(*|
I want to create a function which generates a tree of a given size of
logarithmic depth. E.g. ``7 -> 6 + 1 -> (3 + 3) + 1 -> ((2 + 1) + (2 +
1)) + 1 -> (((1 + 1) + 1) + ((1 + 1) + 1)) + 1``
|*)

Fail Fixpoint nat2struct n : (Struct n) :=
  match n with
  | xH => Leaf
  | xO n => Inner (nat2struct n) (nat2struct n)
  | xI n => Inner Leaf (Inner (nat2struct n) (nat2struct n))
  end. (* .unfold .fails *)

(*|
However, I get the error. How can I fix this? We know that ``(1 + n +
n) = xI n``, but Coq doesn't. If I state this theorem before, it
doesn't change anything:
|*)

Theorem nBy2p1: forall n, Pos.add 1%positive (n + n) = xI n.
Proof. Admitted.
Hint Resolve nBy2p1.

(*|
Are there some hints for Coq to be aware of this theorem?

PS1: is this theorem already proved in standard library? I didn't find
one.

PS2: I actually want to split more naturally: ``7 -> 4 + 3 -> (2 + 2)
+ (2 + 1) -> ((1 + 1) + (1 + 1)) + ((1 + 1) + 1)``. Is it possible? I
don't know how to write it so that Coq understands that the function
converges.
|*)

(*|
Answer
******

When type-checking, Coq uses a weaker form of equality (sometimes
called definitional, judgemental, or computational equality). Unlike
propositional equality (what ``=`` binds to by default), definitional
equality is decidable. Coq can take any two terms and decide if one is
convertible into the other. If propositional equality were allowed in
type-checking, type-checking would no longer be decidable [1]_.

To fix your problem (and it is a pretty big problem) you have a few
options.

Make ``Struct`` a record
========================

I'll demonstrate the principle using lists. First, we have the notion
of unsized lists.
|*)

Inductive UnsizedList (A: Type) :=
| unil
| ucons (a: A) (u: UnsizedList A).

Arguments unil {A}, A.
Arguments ucons {A} a u, A a u.

Fixpoint length {A: Type} (u: UnsizedList A) :=
match u with
| unil => 0
| ucons _ u' => S (length u')
end.

(*|
We can also define a sized list, where every element of ``SizedList A
n`` has length ``n``.
|*)

Inductive SizedList (A: Type): nat -> Type :=
| snil: SizedList A 0
| scons {n: nat} (a: A) (u: SizedList A n): SizedList A (S n).

(*|
This definition runs into the exact same problem as yours. For
example, if you want to show that concatenation is associative, you
can't simply prove ``concat (concat u v) w = concat u (concat v w)``,
since the two sides of the equality have different types (``(i + j) +
k vs i + (j + k)``). If we could simply tell Coq what size we expect
the list to be, then prove it later, we could solve this. That's what
this definition does, which packs together an ``UnsizedList`` with a
proof that that list has the desired length.
|*)

Record SizedListPr (A: Type) (n: nat): Type :=
  {
  list: UnsizedList A;
  list_len_eq: length list = n;
  }.

(*|
Now we can have ``concat (concat u v) w = concat u (concat v w)``; we
just need to prove that both sides have length ``(i + j) + k``.

Use coercions
=============

This approach can get pretty messy if you aren't careful, so it's not
often the preferred approach.

Let me define a sort of coercion that maps elements of type ``P x`` to
elements of type ``P y`` if ``x = y``\ [2]_.
|*)

Definition coercion {A: Type} (P: A -> Type) {x y: A} (p: x = y): P x -> P y :=
  match p with
  | eq_refl => fun t => t
  end.

(*|
Here we use induction on the term ``p: x = y``. The induction
principle says, essentially, that if we can prove something when ``x``
and ``y`` are definitionally equal, then we can prove it when they're
propositionaly equal [3]_. When ``P x`` and ``P y`` are the same, we
can just use the identity function.

Now, for example, the statement of associativity of concatenation for
sized lists is ``concat (concat u v) w = coercion (SizedList A)
(add_assoc) (concat u (concat v w))``. So we coerce something of type
``SizedList A (i + (j + k))`` to something of type ``SizedList A ((i +
j) + k)`` using the equality ``add_assoc: i + (j + k) = (i + j) + k``
(I've left out some parameters for readability).

----

What choice you make is up to you. A discussion of this problem and
related problems, as well as some additional resolutions can be found
at the *Certified Programming with Dependent Types* page `Equality
<http://adam.chlipala.net/cpdt/html/Equality.html>`_.

----

.. [1] See *extensional type theory* for a class of theories where
       this typically happens. `Martin Hofmann's thesis
       <http://www.lfcs.inf.ed.ac.uk/reports/95/ECS-LFCS-95-327/>`_
       has an overview of the difference between intensional and
       extensional theories.
.. [2] If you're familiar with Homotopy Type Theory, this is
       ``transport``.
.. [3] There are enough caveats on this statement that the differences
       between propositional and definitional equality still exist.
|*)