(*|
##############################################
 A compiler from expressions to stack machine
##############################################
|*)

(*|

.. contents:: Table of Contents

|*)

From QuickChick Require Import QuickChick.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From mathcomp Require Import zify. (* lia *)
Import GenLow GenHigh.
Set Warnings "-extraction-opaque-accessed,-extraction".

Global Set Bullet Behavior "None".
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(*|
*******************************
 Simple Arithmetic Expressions
******************************* |*)

Module ArithExpr.

(*|
Expressions
=========== |*)

(*|
Abstract Syntax Tree
-------------------- |*)

(*| Abstract Syntax Tree (AST) for arithmetic expressions: we support numerals
(`Const`) and three arithmetic operations: addition (represented with the `Plus`
constructor), truncating subtraction (`Minus`), multiplication (`Mult`). |*)

Inductive aexp : Type :=
| Const of nat
| Plus of aexp & aexp
| Minus of aexp & aexp
| Mult of aexp & aexp.

(*| QuickChick (see below) comes with a derivation mechanism for random
generators and conversion to strings for a wide class of inductive types. |*)
Derive (Arbitrary, Show) for aexp.

Implicit Types (e : aexp).

(*|
Evaluator
========= |*)

Section Evaluator.

(*| Computable big-step semantics for arithmetic expressions: |*)
Fixpoint aeval (e : aexp) : nat :=
  match e with
  | Const n     => n
  | Plus e1 e2  => aeval e1 + aeval e2
  | Minus e1 e2 => aeval e1 - aeval e2
  | Mult e1 e2  => aeval e1 * aeval e2
  end.

End Evaluator.

(*| Unit and notation tests: |*)
Check erefl : aeval (Minus (Const 0) (Const 4)) = 0.
Check erefl : aeval (Minus (Minus (Const 40) (Const 3)) (Const 1)) = 36.
Check erefl : aeval (Minus (Const 40) (Minus (Const 3) (Const 1))) = 38.
Check erefl : aeval (Plus (Const 2) (Mult (Const 2) (Const 2))) = 6.
Check erefl : aeval (Mult (Plus (Const 2) (Const 2)) (Const 2)) = 8.
Check erefl : aeval (Minus (Plus (Const 40) (Const 3)) (Const 1)) = 42.

(*|
Simple Stack Machine
==================== |*)

(*|
Abstract Syntax for Simple Stack Machine
---------------------------------------- |*)

(*| The stack machine instructions: |*)
Inductive instr := Push (n : nat) | Add | Sub | Mul.

(*| QuickChick (see below) comes with a derivation mechanism for random
generators and conversion to strings for a wide class of inductive types. |*)
Derive (Arbitrary, Show) for instr.

(*| A program for our stack machine is simply a sequence of instructions: |*)
Definition prog := seq instr.

(*| The stack of our stack machine is represented as a list of natural numbers |*)
Definition stack := seq nat.

Implicit Types (p : prog) (s : stack).

(*|
Stack Programs Semantics
------------------------ |*)

Fixpoint run p s : stack :=
  match p, s with
  | (Push n) :: p, s          => run p (n :: s)
  | Add :: p, (a1 :: a2 :: s) => run p ((a2 + a1) :: s)
  | Sub :: p, (a1 :: a2 :: s) => run p ((a2 - a1) :: s)
  | Mul :: p, (a1 :: a2 :: s) => run p ((a2 * a1) :: s)
  | _ :: p, s                 => run p s
  | _, _                      => s
  end.

Arguments run : simpl nomatch.

(*| Unit and notation tests: |*)
Check erefl : run [:: Push 21; Push 21; Add] [::] = [:: 42].

(*|
Compiler from Simple Arithmetic Expressions to Stack Machine Language
===================================================================== |*)

Fixpoint compile e : prog :=
  match e with
  | Const n     => [:: Push n]
  | Plus e1 e2  => compile e1 ++ compile e2 ++ [:: Add]
  | Minus e1 e2 => compile e1 ++ compile e2 ++ [:: Sub]
  | Mult e1 e2  => compile e1 ++ compile e2 ++ [:: Mul]
  end.

Check erefl: run (compile (Minus (Plus (Const 40) (Const 3)) (Const 1))) [::] = [:: 42].

(*|
Property-based randomized testing
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |*)
(*
+++ Passed 10000 tests (0 discards)
*)

(*|
Compiler correctness: specification and first steps to prove it
--------------------------------------------------------------- |*)

(* TODO: maybe show the non-generalized version first *)

QuickChick (fun (a : instr) l s  =>
  run (cons a l) s == run l (run (cons a nil) s)).

Lemma run_cons_comm a l s :
  run (a :: l) s = run l (run (cons a nil) s).
Proof.
case: a.
- move=> n /=.
  exact: erefl.
- (* Proove for Plus *)
  case: s.
  + by [].
  + move=> a1 l1 /=.
    case: l1.
    * by [].
    * move=> a2 l2 /=.
      exact: erefl.
- (* Proove for Minus *)
  case: s.
  + by [].
  + move=> a1 l1 /=.
    case: l1.
    * by [].
    * move=> a2 l2 /=.
      exact: erefl.
- (* Proove for Mult *)
  case: s.
  + by [].
  + move=> a1 l1 /=.
    case: l1.
    * by [].
    * move=> a2 l2 /=.
      exact: erefl.
Qed.

Lemma run_cons_comm' a l s :
  run (a :: l) s = run l (run (cons a nil) s).
Proof.
case: a.
- move=> n /=.
  exact: erefl.
all: case: s => // a1 l1 //; case: l1 => // a2 l2 /=; exact: erefl.
Qed.

QuickChick (fun (p1 p2 : prog) s  =>
  run (p1 ++ p2) s == run p2 (run p1 s)).

Lemma run_cat_comm :
  forall p1 p2 s, run (p1 ++ p2) s = run p2 (run p1 s).
Proof.
elim => /=.
- move=> p2 s.
  exact: erefl.
- move=> a l IHl /= p2 s.
  rewrite run_cons_comm.
  rewrite IHl.
  rewrite -run_cons_comm.
  exact: erefl.
Qed.

Theorem compile_correct_helper e :
  forall s, run (compile e) s = (aeval e) :: s.
Proof.
elim: e.
- by [].
- (* Proove for Plus *)
  move=> e1 IHe1 e2 IHe2 s /=.
  rewrite run_cat_comm.
  rewrite IHe1.
  rewrite run_cat_comm.
  rewrite IHe2.
  rewrite /IHe2.
  move => /=.
  exact: erefl.
- (* Proove for Minus *)
  move=> e1 IHe1 e2 IHe2 s /=.
  rewrite run_cat_comm.
  rewrite IHe1.
  rewrite run_cat_comm.
  rewrite IHe2.
  rewrite /IHe2.
  move => /=.
  exact: erefl.
- (* Proove for Mult *)
  move=> e1 IHe1 e2 IHe2 s /=.
  rewrite run_cat_comm.
  rewrite IHe1.
  rewrite run_cat_comm.
  rewrite IHe2.
  rewrite /IHe2.
  move => /=.
  exact: erefl.
Qed.

Theorem compile_correct_helper' e :
  forall s, run (compile e) s = (aeval e) :: s.
Proof.
elim: e=> // e1 IHe1 e2 IHe2 s /=; rewrite ?run_cat_comm IHe1 IHe2 //=.
Qed.

Theorem compile_correct_helper'' e :
  forall s, run (compile e) s = (aeval e) :: s.
Proof.
elim: e.
- by [].
all: move=> e1 IHe1 e2 IHe2 s /=; rewrite ?run_cat_comm IHe1 IHe2 //=.
Qed.

Theorem compile_correct e :
  run (compile e) nil = [ :: aeval e ].
Proof.
exact: (compile_correct_helper e nil).
Qed.

(*|
Compiler is not very inefficient
-------------------------------- |*)

(*| Let us show the compiler does not produce very inefficient code: we are
going to assume that the measure of inefficiency in our case is the length of
the code the compiler produces. In our case the length of produced code should
not exceed the number of symbols (operations and constants) in the source
arithmetic expression. In fact, our compiler is efficient in a sense, for
instance, it does not add spurious instructions like `<some-code>; ⧐ 0; ⊕; ...`
but our specification so far does not ensure that. |*)

Fixpoint nsymb (e : aexp) : nat :=
  match e with
  | Const n                               => 1
  | Plus e1 e2 | Minus e1 e2 | Mult e1 e2 => S (nsymb e1 + nsymb e2)
  end.

(*| First, let's check the property holds using QuickChick: |*)

Print size.

QuickChick (fun e =>
  size (compile e) <= nsymb e).

Lemma compile_is_not_very_inefficient e :
  size (compile e) <= nsymb e.
Proof.
elim: e => // => e1 IHe1 e2 IHe2 /=.
- rewrite ?size_cat => /=.
  rewrite addnA addn1.
  apply: leq_ltS (leq_add IHe1 IHe2).
- rewrite ?size_cat => /=.
  rewrite addnA addn1.
  apply: leq_ltS (leq_add IHe1 IHe2).
- rewrite ?size_cat => /=.
  rewrite addnA addn1.
  apply: leq_ltS (leq_add IHe1 IHe2).
Qed.

Lemma compile_is_not_very_inefficient' e :
  size (compile e) <= nsymb e.
Proof.
elim: e => // e1 IHe1 e2 IHe2 /=;
  rewrite ?size_cat => /=;
  rewrite addnA addn1;
  apply: leq_ltS (leq_add IHe1 IHe2).
Qed.

End ArithExpr.


Inductive natlist : Type :=
  | nil
  | cons (n : nat) (l : natlist).

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).
Inductive natoption : Type :=
  | Some (n : nat)
  | None.

Definition hd (default : nat) (l : natlist) : nat :=
  match l with
  | nil => default
  | h :: t => h
  end.

Definition option_elim (d : nat) (o : natoption) : nat :=
  match o with
  | Some n' => n'
  | None => d
  end.

(* EXERCISE *)
Definition hd_error (l : natlist) : natoption :=
    match l with
    | nil => None
    | h :: t => Some h
    end.

Example test_hd_error1 : hd_error [] = None.
Proof. reflexivity. Qed.
Example test_hd_error2 : hd_error [1] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_error3 : hd_error [5;6] = Some 5.
Proof. reflexivity. Qed.

(* EXERCISE *)
Theorem option_elim_hd : forall (l:natlist) (default:nat),
  hd default l = option_elim default (hd_error l).
Proof.
    intros l n. induction l as [| l' IHl'].
    - simpl. reflexivity.
    - simpl. reflexivity.
    Qed.


(*
 * その5: https://www.fos.kuis.kyoto-u.ac.jp/~igarashi/class/cal/handout5.pdf
 * タクティクスの練習
 *)

Require Import Arith List Omega ZArith.
From mathcomp Require Import all_ssreflect.
Import ListNotations.

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

Theorem trans_eq : forall (X : Type) (n m o : X),
  n = m -> m = o -> n = o.
Proof.
  congruence.
Qed.

(*
 * ただの apply では m が推測できないが with でヒントを与えることが出来る
 *)

Example trans_eq_example :
  forall (a b c d e f : nat),
  [a;b] = [c;d] -> [c;d] = [e;f] -> [a;b] = [e;f].
Proof.
  intros.
  apply trans_eq with (m := [c;d]).
  - exact.
  - exact.
Qed.

(*
 * 帰納的定義では、イコールは構築の仕方から自明なもの
 *)

Theorem S_injective : forall n m,
  S n = S m -> n = m.
Proof.
  intros.
  assert (H2 : n = (n.+1).-1). {
    by simpl.
  }
  rewrite H2.
  rewrite H.
  by simpl.
Qed.

(*
 * これをやってくれる injection というタクティクがある
 *)

Theorem S_injective' : forall n m,
  S n = S m -> n = m.
Proof.
  intros.
  injection H.
  apply.
Qed.

Theorem injection_ex1 : forall n m o : nat,
  [n;m] = [o;o] -> [n] = [m].
Proof.
  intros.
  injection H.
  intros.
  rewrite H0.
  rewrite H1.
  trivial.
Qed.

Theorem injection_ex2 : forall n m : nat,
  [n] = [m] -> n = m.
Proof.
  intros n m.
  intros H.
  injection H as Hnm.
  exact.
Qed.

Theorem injection_ex2' : forall n m : nat,
  Some n = Some m -> n = m.
Proof.
  intros n m H.
  injection H as Hnm.
  exact.
Qed.

(*
* 同様にイコールでないことも構築の仕方から自明に分かる
* それを即座に使うのが discriminate
*)

Theorem eqb_0_1 : forall n, 0 = n -> n = 0.
Proof.
  intros [|m].
  - done.
  - discriminate.
Qed.

Theorem explosion_ex1 : forall n, n.+1 = 0 -> 0 = 100.
Proof.
  discriminate.
Qed.

(*
* ちなみに injection の逆は定理である
*)

Check f_equal.

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

(*
自然数の二倍にする関数 double が injective であることを
数学的帰納法で示す練習
*)

Check double.
Compute (double 3). (* 6 *)

Theorem double_injective : forall n m,
  double n = double m -> n = m.
Proof.
  induction n.
  - (* when n = 0; m must be 0 *)
    case.
    + (* when m = 0; ok *)
      done.
    + (* when m = _.+1; ng *)
      discriminate.
  - (* when n = _.+1 *)
    induction m.
    + (* when m = 0; ng *)
      discriminate.
      rewrite -! muln2.
      rewrite !mulSn.
      rewrite !muln2.
      intro SS.
      injection SS.
      move/IHn.
      apply f_equal.
Qed.

(*
量化に気をつけないと失敗する
*)

Theorem double_injective_FAILED : forall n m,
  double n = double m -> n = m.
Proof.
  intros n m.
  induction n as [|n'].
  - (* when n = 0 *)
    intro eq.
    destruct m.
    + done.
    + discriminate.
  - (* when n = S n' *)
    intro eq.
    destruct m as [|m'].
    + (* when m = 0 *)
      discriminate.
    + (* when m = S m' *)
Abort.

(*
generalize dependent タクティクは全称量化を導入できる
move: とか revert と同じ？
*)

Theorem double_injective_take2 : forall n m,
  double n = double m -> n = m.
Proof.
  intros n m.
  generalize dependent n.
  (*
  move: n.
  revert n.
  *)
  induction m.
Abort.

(*
条件式の場合分け
*)

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

Theorem silly_fun_returns_false : forall n, silly_fun n = false.
Proof.
  intro n.
  unfold silly_fun.
  - case (n == 3).
    done.
  - case (n == 5).
    done.
  - (* else *)
    done.
Qed.

Check odd.
Compute (odd 3).
Compute (odd 4).

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

Theorem silly_fun1_is_true : forall n : nat,
  silly_fun1 n = true -> odd n = true.
Proof.
  intro n.
  unfold silly_fun1.
  - case (n == 3) eqn:n_is_3.
    move/eqP in n_is_3.  (* _ == _ -> _ = _ *)
    rewrite n_is_3.
    done.
  - case (n == 5) eqn:n_is_5.
    move/eqP in n_is_5.
    rewrite n_is_5.
    done.
  - discriminate.
Qed.


Set Warnings "-notation-overridden,-parsing".
Require Export IndProp.

Print ev.
Check ev_SS.

Theorem ev_4: ev 4.
Proof.
  apply ev_SS. apply ev_SS. apply ev_0.
  Qed.

Print ev_4.

Check (ev_SS 2 (ev_SS 0 ev_0)).

Theorem ev_4'': ev 4.
Proof.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_0.
  Show Proof.
  Qed.

(* Exercise eight_is_even *)

Theorem ev_plus4: forall n, ev n -> ev (4+n).
Proof.
  intros n H. simpl.
  apply ev_SS.
  apply ev_SS.
  apply H.
  Qed.

Definition ev_plus4' : forall n,
  ev n -> ev (4+n) :=
  fun (n:nat) => fun (H:ev n) =>
  ev_SS (S (S n)) (ev_SS n H).

Definition ev_plus4''(n:nat)(H:ev n) : ev (4+n) :=
  ev_SS (S (S n)) (ev_SS n H).

Check ev_plus4''.

Definition ev_plus2 : Prop :=
  forall n, forall (E:ev n), ev (n+2).

Definition ev_plus2' : Prop :=
  forall n, forall (_:ev n), ev (n+2).

Definition ev_plus2'' : Prop :=
  forall n, ev n -> ev (n+2).

Definition add1 : nat->nat.
intro n.
Show Proof.
apply S.
Show Proof.
apply n.
Show Proof.
Defined.

Print add1.
Compute add1 2.

Module Props.

Module And.

Inductive and (P Q : Prop) : Prop :=
  | conj : P->Q->and P Q.

End And.

Print prod.

Lemma and_comm : forall P Q : Prop,
  P/\Q <-> Q/\P.
Proof.
  intros P Q. split.
  - intros [HP HQ]. split.
    apply HQ. apply HP.
  - intros [HQ HP]. split.
    apply HP. apply HQ.
  Qed.

Definition and_comm'_aux P Q (H:P/\Q) :=
  match H with
  | conj HP HQ => conj HQ HP
  end.

Definition and_comm' P Q : P/\Q <-> Q/\P :=
  conj (and_comm'_aux P Q) (and_comm'_aux Q P).

(* Exercise conj_fact *)
Definition conj_fact: forall P Q R,
  P/\Q ->
  Q/\R ->
  P/\R.
Proof.
  intros P Q R [HP HQ1] [HQ2 HR].
  split.
  apply HP.
  apply HR.
  Qed.

Module Or.

Inductive or(P Q : Prop) : Prop :=
  | or_introl: P->or P Q
  | or_intror: Q->or P Q.

End Or.

(* Exercise or_commut'' *)
Definition or_comm: forall P Q,
  P\/Q -> Q\/P.
Proof.
  intros P Q [HP|HQ].
  - right. apply HP.
  - left. apply HQ.
  Qed.

Module Ex.

Inductive ex{A:Type}(P:A->Prop) : Prop :=
  | ex_intro: forall x:A, P x -> ex P.

End Ex.

Check ex (fun n => ev n).

Definition some_nat_is_even : exists n, ev n :=
  ex_intro ev 4 (ev_SS 2 (ev_SS 0 ev_0)).

(* Exercise ex_ev_Sn *)

Inductive True : Prop :=
  | I : True.

Inductive False : Prop :=.

End Props.

Module MyEquality.

Inductive eq{X:Type} : X->X->Prop :=
  | eq_refl: forall x, eq x x.

Notation "x = y" := (eq x y)
        (at level 70, no associativity)
        : type_scope.

(* Exercise leibniz_equality *)
Lemma leibniz_equality: forall (X:Type)(x y : X),
  x = y ->
  forall P:X->Prop,
  P x -> P y.
Proof.
  intros X x y eqxy Px Hx.
  induction eqxy.
  apply Hx.
  Qed.

Lemma four: 2+2 = 1+3.
Proof.
  apply eq_refl.
  Qed.

Definition four': 2+2=1+3 :=
  eq_refl 4.

Definition singleton: forall (X:Type)(x:X),
  [] ++ [x] = x::[] :=
  fun (X:Type)(x:X) => eq_refl [x].

End MyEquality.


Require Import Coq.Classes.SetoidClass.
Require Import MyInductions.
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.Peano_dec.

Module NatList.

Inductive natprod : Type :=
| pair : nat -> nat -> natprod.

Check (pair 3 5).

Definition fst(p : natprod) : nat :=
  match p with
      | pair x y => x
end.

Definition snd(p : natprod) : nat :=
  match p with
      | pair x y => y
end.

Compute (fst (pair 3 5)).

Notation "( x , y )" := (pair x y).

Compute (fst(3,5)).

Definition fst' (p : natprod) : nat :=
  match p with
      | (x,y) => x
  end.

Definition snd' (p : natprod) : nat :=
  match p with
      | (x,y) => y
  end.

Definition swap_pair(p : natprod) : natprod :=
  match p with
      | (x,y) => (y,x)
  end.

Theorem surjective_pairing' : forall (n m : nat),
    (n,m) = (fst(n,m), snd(n,m)).
Proof.
reflexivity.
Qed.

Theorem surjective_pairing_stuck : forall (p : natprod), p = (fst p, snd p).
Proof.
  intros p.
  destruct p as [n m].
  simpl.
  reflexivity.
Qed.

Theorem snd_fst_is_swap : forall (p : natprod), (snd p, fst p) = swap_pair p.
Proof.
  intros p.
  destruct p as [n m].
  simpl.
  reflexivity.
Qed.

Theorem fst_swap_is_snd : forall (p : natprod), fst(swap_pair p) = snd p.
Proof.
  intros p.
  destruct p as [n m].
  simpl.
  reflexivity.
Qed.

Inductive natlist : Type :=
  | nil : natlist
  | cons : nat -> natlist -> natlist.

Definition mylist := cons 1 (cons 2 (cons 3 nil)).

Notation "x :: l" := (cons x l) (at level 60, right associativity).

Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Definition mylist1 := 1 :: (2 :: (3 :: nil)).
Definition mylist2 := 1 :: 2 :: 3 :: nil.
Definition mylist3 := [1;2;3].

Notation "x + y" := (plus x y)
                      (at level 50, left associativity).

Fixpoint repeat (n count : nat) : natlist :=
  match count with
      | 0 => nil
      | S count' => n :: (repeat n count')
  end.

Fixpoint length (l : natlist) : nat :=
  match l with
      | nil => 0
      | h :: t => S (length t)
end.

Fixpoint app (l1 l2 : natlist) : natlist :=
  match l1 with
      | nil => l2
      | h :: t => h :: (app t l2)
  end.

Notation "x ++ y" := (app x y)
                       (right associativity, at level 60).

Example test_app1: [1;2;3] ++ [4;5] = [1;2;3;4;5].
Proof. reflexivity. Qed.

Example test_app2: nil ++ [4;5] = [4;5].
Proof. reflexivity. Qed.

Example test_app3: [1;2;3] ++ nil = [1;2;3].
Proof. reflexivity. Qed.

Definition hd (default : nat) (l : natlist) : nat :=
  match l with
      | nil => default
      | h :: t => h
  end.

Definition tl (l:natlist) : natlist :=
  match l with
    | nil => nil
    | h :: t => t
  end.

Example test_hd1 : hd 0 [1;2;3] = 1.
Proof. reflexivity. Qed.

Example test_hd2 : hd 0 [] = 0.
Proof. reflexivity. Qed.

Example test_tl : tl [1;2;3] = [2;3].
Proof. reflexivity. Qed.

Fixpoint nonzeros (l : natlist) : natlist :=
  match l with
    |    nil => nil
    | h :: t => match h with
                  | 0 => (nonzeros t)
                  | _ => h::(nonzeros t)
                end
  end.

Example test_nonzeros: nonzeros [0;1;0;2;3;0;0] = [1;2;3].
Proof. reflexivity. Qed.

Fixpoint odd(n : nat) :=
  match n with
    | 0 => false
    | 1 => true
    | S p => odd(p-1)
  end.

Check odd.

Example tst_odd : odd(31) = true.
Proof. simpl. reflexivity. Qed.

Fixpoint oddmembers (l : natlist) : natlist :=
  match l with
    | nil => nil
    | h :: t => match (odd h) with
                    | true => h::(oddmembers t)
                    | false => (oddmembers t)
                end
  end.

Example test_oddmembers : oddmembers([2;3;4;5;6;7;8;9;10;111;12;0;0;0;0;0;0;0]) = [3;5;7;9;111].
Proof. reflexivity. Qed.

Fixpoint countoddnumbers (l : natlist) : nat :=
  match l with
      | nil => 0
      | h :: t => match (odd h) with
                      | true => 1+(countoddnumbers t)
                      | false => (countoddnumbers t)
                  end
  end.

Example test_countoddnumbers : countoddnumbers [1;0;3;1;4;5] = 4.
Proof. reflexivity. Qed.

Example test_coundoddnumbers2 : countoddnumbers [0;2;4] = 0.
Proof. reflexivity. Qed.

Example test_countoddnumbers3 : countoddnumbers nil = 0.
Proof. reflexivity. Qed.

Fixpoint alternate(l1 l2 : natlist) : natlist :=
  match l1 with
      | nil => l2
      | h1 :: t1 => match l2 with
                    | nil => l1
                    | h2 :: t2 => h1::h2::(alternate t1 t2)
                    end
  end.

Example test_alternate1:
  alternate [1;3;5] [2;4;6] = [1;2;3;4;5;6].
Proof. reflexivity. Qed.

Example test_aternate2:
  alternate [1] [4;5;6] = [1;4;5;6].
Proof. reflexivity. Qed.

Definition bag := natlist.

Check (1=1).

Fixpoint myeq_nat n m  :=
  match n, m with
    | O, O => true
    | O, S _ => false
    | S _, O => false
    | S n1, S m1 => myeq_nat n1 m1
  end.

Theorem myeq_nat_eq : forall n, (myeq_nat n n) = true.
Proof.
induction n.
simpl.
reflexivity.
simpl.
assumption.
Qed.

Fixpoint count (v : nat) (s:bag) : nat :=

  match s with
      | nil => 0
      | h1 :: t1 => (if (myeq_nat v h1) then
                      1+(count v t1)
                    else
                      (count v t1))

  end.

Example test_count1: count 1 [1;2;3;4;1;4;1] = 3.
Proof. reflexivity. Qed.

Definition sum : bag -> bag -> bag := app.

Example test_sum1 : count 1 (sum [1;2;3] [1;4;1]) = 3.
Proof. reflexivity. Qed.

Definition add (v:nat) (s:bag) : bag := (cons v s).

Example test_add1: count 1 (add 1 [1;4;1]) = 3.
Proof. reflexivity. Qed.

Example test_add2 : count 5 (add 1 [1;4;1]) = 0.
Proof. reflexivity. Qed.

Definition member (v:nat) (s:bag) : bool :=
  match (myeq_nat (count v s) 0) with
    |      true => false
    |      false => true
  end.

Example test_member1 : member 1 [1;4;1] = true.
Proof. reflexivity. Qed.

Example test_member2 : member 2 [1;4;1] = false.
Proof. reflexivity. Qed.

Fixpoint remove (v:nat) (s:bag) : bag :=
 match s with
  |   [] => []
  |   h::t => if (myeq_nat v h) then
                (remove v t)
              else
                (h::remove v t)
 end.

Example test_remove1 : remove 1 [1;4;1] = [4].
Proof. reflexivity. Qed.

Theorem nat_p_1 : forall n : nat, S(n) <> 0.
Proof.
intros.
induction n.
auto.
auto.
Qed.

Theorem bag_theorem : forall n : nat, forall b : bag, ((count n (add n b)) <> 0).
Proof.
intros.
simpl.
induction b.
induction n.
simpl.
auto.
induction n.
replace (myeq_nat 1 1) with true.
simpl.
auto.
simpl.
reflexivity.
replace (myeq_nat (S (S n)) (S (S(n)))) with true.
induction n.
simpl.
auto.
set (count (S (S (S n))) []).
apply nat_p_1.
set (S (S n)).
simpl.
rewrite -> myeq_nat_eq.
reflexivity.
rewrite -> myeq_nat_eq.
set (count n (n0 :: b)).
apply nat_p_1.
Qed.

Theorem bag_theorem2 : forall n : nat, forall b : bag, ((count n (add n b)) = S(count n b)).
intros.
simpl.
rewrite -> myeq_nat_eq.
set (count n b).
reflexivity.
Qed.

Theorem nil_app : forall l : natlist, [] ++ l = l.
Proof. reflexivity. Qed.

Theorem tl_length_pred : forall l : natlist, pred (length l) = length(tl l).
Proof.
intros l.
destruct l as [|n l'].
reflexivity.
reflexivity.
Qed.

Theorem app_assoc : forall l1 l2 l3 : natlist,
                      (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
intros l1 l2 l3.
induction l1 as [|n l1' IHl1'].
reflexivity.
simpl. rewrite -> IHl1'. reflexivity. Qed.

Fixpoint rev (l : natlist) : natlist :=
  match l with
    | nil => nil
    | h :: t => rev t ++ [h]
  end.

Example test_rev1 : rev [1;2;3] = [3;2;1].
Proof. reflexivity. Qed.

Theorem rev_length_firsttry : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros.
  induction l as [|n l' IHl'].
  reflexivity.
  simpl.
  rewrite <- IHl'.
Abort.

Theorem app_length : forall l1 l2 : natlist,
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
intros.
induction l1 as [|n l1' IHl1'].
reflexivity.
simpl.
rewrite -> IHl1'.
reflexivity.
Qed.

Theorem rev_length : forall l : natlist, length (rev l) = length l.
Proof.
intros l.
induction l as [|n l' IHl'].
simpl.
reflexivity.
simpl.
rewrite -> app_length, plus_comm.
rewrite -> IHl'.
reflexivity.
Qed.

Theorem app_nil_r : forall l : natlist, l ++ [] = l.
Proof.
intros.
induction l.
simpl.
reflexivity.
replace ((n::l) ++ []) with (n::(l++[])).
rewrite ->IHl.
reflexivity.
simpl.
reflexivity.
Qed.

Theorem rev_involutive : forall l : natlist,
 rev (rev l) = l.
Proof.
intros.
induction l as [|n l' IHl'].
reflexivity.
simpl.
replace (rev ( rev l' ++ [n])) with (n::(rev (rev l'))).
rewrite -> IHl'.
reflexivity.
set (rev l').
induction n0.
reflexivity.
simpl.
rewrite <- IHn0.
simpl.
reflexivity.
Qed.

Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist, l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  intros.
  induction l1.
  simpl.
  induction l2.
  simpl.
  reflexivity.
  rewrite <- app_assoc.
  reflexivity.
  set (l1 ++ l2).
  set (n::l1).
  replace (((n1 ++ l2) ++ l3 ) ++ l4) with (n1 ++ (l2 ++ l3 ++ l4)).
  reflexivity.
  rewrite -> app_assoc.
  unfold n1.
  set (l3 ++ l4).
  rewrite -> app_assoc.
  reflexivity.
Qed.

Lemma nonzeros_app : forall l1 l2 : natlist, nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  intros.
  induction l1.
  reflexivity.
  induction l2.
  rewrite -> app_nil_r.
  replace (nonzeros []) with ([]).
  replace (nonzeros (n::l1) ++ []) with (nonzeros(n::l1)).
  reflexivity.
  rewrite -> app_nil_r.
  reflexivity.
  reflexivity.
  induction n.
  induction n0.
  simpl.
  rewrite ->IHl1.
  simpl.
  reflexivity.
  simpl.
  rewrite ->IHl1.
  simpl.
  reflexivity.
  simpl.
  induction n0.
  rewrite ->IHl1.
  simpl.
  reflexivity.
  rewrite ->IHl1.
  simpl.
  reflexivity.
Qed.

Fixpoint beq_natlist (l1 l2 : natlist) : bool :=
  match l1 with
|      [] => match l2 with
               |  [] => true
               | h::t => false
             end
|       h1::t1 => match l2 with
                 | [] => false
                 | h2::t2 => (if (myeq_nat h1 h2) then (beq_natlist t1 t2) else false)
                  end
  end.

Example test_beq_natlist1 : (beq_natlist nil nil = true).
Proof. reflexivity. Qed.

Example test_beq_natlist2 : (beq_natlist [1;2;3] [1;2;3] = true).
Proof. reflexivity. Qed.

Example test_beq_natlist3 : (beq_natlist [1;2;3] [1;2;4] = false).
Proof. reflexivity. Qed.

Theorem beq_natlist_refl : forall l : natlist, true = beq_natlist l l.
Proof.
  intros.
  induction l.
  reflexivity.
  induction n.
  simpl.
  assumption.
  simpl.
  replace (myeq_nat n n) with true.
  assumption.
  rewrite -> myeq_nat_eq.
  reflexivity.
Qed.

(*SearchAbout rev.*)

Theorem count_member_nonzero : forall (s : bag), leb 1 (count 1 (1 :: s)) = true.
Proof.
  intros.
  induction s.
  simpl.
  reflexivity.
  reflexivity.
Qed.

Theorem ble_n_Sn : forall n, leb n (S n) = true.
Proof.
  intros.
  induction n.
  simpl.
  reflexivity.
  simpl.
  assumption.
Qed.

Fixpoint remove_one (v : nat) (s : bag) : bag :=
  match s with
|      [] => []
|      h::t => (if (myeq_nat v h) then t else h::(remove_one v (t)) )
  end.

Example test_remove_one1 : count 5 (remove_one 5 [2;1;5;4;1]) = 0.
Proof.
  reflexivity.
Qed.

Example test_remove_one2 : count 5 (remove_one 5 [2;1;4;1]) = 0.
Proof.
  reflexivity.
Qed.

Theorem remove_decreases_count : forall s : bag, leb (count 0 (remove_one 0 s)) (count 0 s) = true.
Proof.
  intros.
  induction s.
  reflexivity.
  induction n.
  simpl.
  set (count 0 s).
  rewrite -> ble_n_Sn.
  reflexivity.
  simpl.
  assumption.
Qed.

Inductive natoption : Type :=
  | Some : nat -> natoption
  | None : natoption.

Fixpoint nth_error (l : natlist) (n : nat) : natoption :=
  match l with
    | nil => None
    | (aa :: t) => (match myeq_nat n 0 with
                   | true => Some aa
                   | false => nth_error t (pred n)
               end)
  end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.

Example test_nth_error2 : nth_error [4;5;6;7] 3 = Some 7.
Proof. reflexivity. Qed.

Example test_nth_error3 : nth_error [4;5;6;7] 9 = None.
Proof. reflexivity. Qed.

End NatList.


Require Import Nat Arith Bool.

Inductive Nat : Type := zero : Nat | succ : Nat -> Nat.

Scheme Equality for Nat.

Inductive Lst : Type := nil : Lst | cons : Nat -> Lst -> Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint less (less_arg0 : Nat) (less_arg1 : Nat) : bool
           := match less_arg0, less_arg1 with
              | x, zero => false
              | zero, succ x => true
              | succ x, succ y => less x y
              end.

Definition leq (x : Nat) (y : Nat) : bool :=
  Nat_beq x y || less x y.

Fixpoint insort (insort_arg0 : Nat) (insort_arg1 : Lst) : Lst
           := match insort_arg0, insort_arg1 with
              | i, nil => cons i nil
              | i, cons x y => if less i x then cons i (cons x y) else cons x (insort i y)
              end.

Fixpoint sorted (sorted_arg0 : Lst) : bool
           := match sorted_arg0 with
              | nil => true
              | cons x l => match l with
                | nil => true
                | cons z y => andb (sorted l) (leq x z)
                end
              end.

Fixpoint sort (sort_arg0 : Lst) : Lst
           := match sort_arg0 with
              | nil => nil
              | cons x y => insort x (sort y)
              end.

Lemma not_less : forall (x y : Nat), less x y = false -> leq y x = true.
Proof.
  intros.
  generalize dependent y.
  induction x.
  - intros. unfold leq. destruct y.
    + reflexivity.
    + discriminate.
  - intros. unfold leq. destruct y.
    + reflexivity.
    + simpl in H. apply IHx in H. unfold leq in H. simpl. assumption.
Qed.

Theorem theorem0 : forall (x : Lst) (y : Nat), sorted x = true -> sorted (insort y x) = true.
Proof.
  intros.
  induction x.
  - reflexivity.
  - destruct x.
    + simpl. destruct (less y n) eqn:?.
      * simpl. unfold leq. rewrite Heqb. apply orb_true_r.
      * simpl. apply not_less. assumption.
    + simpl in H. apply andb_true_iff in H. destruct H. simpl in IHx. simpl. destruct (less y n) eqn:?.
      * simpl. rewrite H. rewrite H0. unfold leq. rewrite Heqb. apply orb_true_r.
      * destruct (less y n0) eqn:?.
        -- simpl. rewrite H. apply not_less in Heqb. rewrite Heqb. unfold leq. rewrite Heqb0. rewrite orb_true_r. reflexivity.
        -- simpl. apply IHx in H. simpl in H. rewrite H. rewrite H0. reflexivity.
Qed.


Require Import List.

Inductive Typ : Set :=
  | Top : Typ
  | Imp : Typ -> Typ -> Typ
  | Cnj : Typ -> Typ -> Typ.

Inductive Trm : Set :=
  | top : Trm
  | hyp : nat -> Trm
  | lam : Typ -> Trm -> Trm
  | app : Trm -> Trm -> Trm
  | cnj : Trm -> Trm -> Trm
  | proj_1 : Trm -> Trm
  | proj_2 : Trm -> Trm.

Definition  Cntxt := list Typ.

Inductive Tyty : Cntxt -> Trm -> Typ -> Prop :=
  | ND_top_intro : forall G, Tyty G top Top
  | ND_hypO : forall G A, Tyty (A :: G) (hyp 0) A
  | ND_hypS :
      forall G A B I,
      Tyty G (hyp I) A -> Tyty (B :: G) (hyp (S I)) A
  | ND_lam :
      forall G t A B,
      Tyty (A :: G) t B -> Tyty G (lam A t) (Imp A B)
  | ND_app :
      forall G t s A B,
      Tyty G t (Imp A B) -> Tyty G s B -> Tyty G (app t s) B
  | ND_cnj :
      forall G t s A B,
      Tyty G t A -> Tyty G s B -> Tyty G (cnj t s) (Cnj A B)
  | ND_proj_1 :
      forall G t A B,
      Tyty G t (Cnj A B) -> Tyty G (proj_1 t) A
  | ND_proj_2 :
      forall G t A B,
      Tyty G t (Cnj A B) -> Tyty G (proj_2 t) B.

Notation "G '⊢' t '[:]' A" := (Tyty G t A) (at level 70, no associativity) : type_scope.

Notation "'⊢' t '[:]' A" := (Tyty nil t A) (at level 70, no associativity) : type_scope.

Lemma problem_1 : forall A B, exists t, ⊢ t [:] (Imp A (Imp B A)).
Proof.
  intros.
  exists (lam A (lam B (hyp 1))).
  apply ND_lam.
  apply ND_lam.
  apply ND_hypS.
  apply ND_hypO.
  Show Proof.
Qed.

github-repos/coq/mozow01-logic_and_category/logic_and_category-7ee90681839be81f7a70b78f0c518df903b9086d/mindenfele/natural deduction for the negative fragment.v


(**************************************************************)
(*   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 Bool.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_list finite fin_quotient fin_dec utils_decidable.

From Undecidability.FOL.TRAKHTENBROT
  Require Import notations utils decidable.

Set Implicit Arguments.

Local Infix "∊" := In (at level 70, no associativity).

Section discernable.

  Variable (X : Type).

  Definition discernable x y := exists δ : X -> bool, δ x <> δ y.

  Infix "≢" := discernable (at level 70, no associativity).

  Fact discernable_equiv1 x y : x ≢ y <-> exists δ, δ x = true /\ δ y = false.
  Proof.
    split.
    + intros (f & Hf).
      case_eq (f x); intros Hx.
      * exists f; split; auto.
        now rewrite Hx in Hf; destruct (f y).
      * exists (fun x => negb (f x)).
        rewrite Hx in *; split; auto.
        now destruct (f y).
    + intros (f & E1 & E2); exists f.
      now rewrite E1, E2.
  Qed.

  Definition undiscernable x y := forall δ : X -> bool, δ x = δ y.

  Infix "≡" := undiscernable (at level 70, no associativity).

  Fact discernable_undiscernable x y : x ≢ y -> x ≡ y -> False.
  Proof. intros (f & Hf) H; apply Hf, H. Qed.

  Fact undiscernable_spec x y : x ≡ y <-> ~ x ≢ y.
  Proof.
    split.
    + intros H1 H2; revert H2 H1; apply discernable_undiscernable.
    + intros H f.
      destruct (bool_dec (f x) (f y)); auto.
      destruct H; exists f; auto.
  Qed.

  Fact undiscernable_refl x : x ≡ x.
  Proof. red; auto. Qed.

  Fact undiscernable_sym x y : x ≡ y -> y ≡ x.
  Proof. red; auto. Qed.

  Fact undiscernable_trans x y z : x ≡ y -> y ≡ z -> x ≡ z.
  Proof. unfold undiscernable; eauto. Qed.

  Fact undiscernable_discrete D (δ : X -> D) x y : discrete D -> x ≡ y -> δ x = δ y.
  Proof.
    intros d H.
    set (g z := if d (δ x) (δ z) then true else false).
    specialize (H g); unfold g in H.
    destruct (d (δ x) (δ x)) as [ _ | [] ]; auto.
    destruct (d (δ x) (δ y)) as [ | ]; easy.
  Qed.

  Fact discrete_undiscernable_implies_equal x y : discrete X -> x ≡ y -> x = y.
  Proof. intro; now apply undiscernable_discrete with (δ := fun x => x). Qed.

  Fact undiscernable_Prop_dec x y : x ≡ y -> forall P, (forall x, decidable (P x)) -> P x <-> P y.
  Proof.
    intros H P HP.
    set (f x := if HP x then true else false).
    specialize (H f); unfold f in H.
    destruct (HP x); destruct (HP y); try tauto; easy.
  Qed.

  Hypothesis (H2 : forall x y, decidable (x ≢ y)).

  Fact discernable_dec_undiscernable_dec x y : decidable (x ≡ y).
  Proof using H2.
    destruct (H2 x y); [ right | left ]; rewrite undiscernable_spec; tauto.
  Qed.

  Hint Resolve discernable_dec_undiscernable_dec : core.

  (* There is a simultaneously discerning function for a list l *)

  Definition discriminable_list l :=
    { D & { _ : discrete D & { _ : finite_t D & { δ : X -> D
             | forall x y, x ∊ l -> y ∊ l -> x ≡ y <-> δ x = δ y } } } }.

  Hint Resolve undiscernable_refl undiscernable_sym undiscernable_trans : core.

  Theorem discernable_discriminable_list l : discriminable_list l.
  Proof using H2.
    apply DEC_PER_list_proj_finite_discrete with (l := l) (R := undiscernable).
    + split; eauto.
    + red; apply discernable_dec_undiscernable_dec.
    + intros; auto.
  Qed.

  (* There is a simultaneously discerning function for a type *)

  Definition discriminable_type :=
    { D & { _ : discrete D & { _ : finite_t D & { δ : X -> D
             | forall x y, x ≡ y <-> δ x = δ y } } } }.

  Hypothesis (H1 : finite_t X).

  (* undiscernable is equivalent to a equality after mapping on some finite datatype *)

  Theorem finite_discernable_discriminable_type : discriminable_type.
  Proof using H1 H2.
    destruct H1 as (l & Hl).
    destruct discernable_discriminable_list with l
      as (D & D1 & D2 & f & Hf).
    exists D, D1, D2, f; intros; eauto.
  Qed.

End discernable.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Reals.Rbasic_fun.
Require BuiltIn.
Require real.Real.

Import Rbasic_fun.

(* Why3 comment *)
(* abs is replaced with (Reals.Rbasic_fun.Rabs x) by the coq driver *)

(* Why3 goal *)
Lemma abs_def :
forall (x:R),
 ((0%R <= x)%R -> ((Reals.Rbasic_fun.Rabs x) = x))
 /\ ((~ (0%R <= x)%R) -> ((Reals.Rbasic_fun.Rabs x) = (-x)%R)).
split ; intros H.
apply Rabs_right.
now apply Rle_ge.
apply Rabs_left.
now apply Rnot_le_lt.
Qed.

(* Why3 goal *)
Lemma Abs_le :
forall (x:R) (y:R),
 ((Reals.Rbasic_fun.Rabs x) <= y)%R <-> (((-y)%R <= x)%R /\ (x <= y)%R).
intros x y.
unfold Rabs.
case Rcase_abs ; intros H ; (split ; [intros H0;split | intros (H0,H1)]).
rewrite <- (Ropp_involutive x).
now apply Ropp_le_contravar.
apply Rlt_le.
apply Rlt_le_trans with (1 := H).
apply Rle_trans with (2 := H0).
rewrite <- Ropp_0.
apply Ropp_le_contravar.
now apply Rlt_le.
rewrite <- (Ropp_involutive y).
now apply Ropp_le_contravar.
apply Rge_le in H.
apply Rle_trans with (2 := H).
apply Rle_trans with (Ropp x).
now apply Ropp_le_contravar.
rewrite <- Ropp_0.
now apply Ropp_le_contravar.
exact H0.
exact H1.
Qed.

(* Why3 goal *)
Lemma Abs_pos :
forall (x:R), (0%R <= (Reals.Rbasic_fun.Rabs x))%R.
exact Rabs_pos.
Qed.

(* Why3 goal *)
Lemma Abs_sum :
forall (x:R) (y:R),
 ((Reals.Rbasic_fun.Rabs (x + y)%R) <= ((Reals.Rbasic_fun.Rabs x) + (Reals.Rbasic_fun.Rabs y))%R)%R.
exact Rabs_triang.
Qed.

(* Why3 goal *)
Lemma Abs_prod :
forall (x:R) (y:R),
 ((Reals.Rbasic_fun.Rabs (x * y)%R) = ((Reals.Rbasic_fun.Rabs x) * (Reals.Rbasic_fun.Rabs y))%R).
exact Rabs_mult.
Qed.

(* Why3 goal *)
Lemma triangular_inequality :
forall (x:R) (y:R) (z:R),
 ((Reals.Rbasic_fun.Rabs (x - z)%R) <= ((Reals.Rbasic_fun.Rabs (x - y)%R) + (Reals.Rbasic_fun.Rabs (y - z)%R))%R)%R.
intros x y z.
replace (x - z)%R with ((x - y) + (y - z))%R by ring.
apply Rabs_triang.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.ZArith.Znumtheory.
Require Import Coq.micromega.Lia.
Local Open Scope Z_scope.

Module Z.
  Lemma prime_odd_or_2 : forall p (prime_p : prime p), p = 2 \/ Z.odd p = true.
  Proof.
    intros p prime_p.
    apply Decidable.imp_not_l; try apply Z.eq_decidable.
    intros p_neq2.
    pose proof (Zmod_odd p) as mod_odd.
    destruct (Sumbool.sumbool_of_bool (Z.odd p)) as [? | p_not_odd]; auto.
    rewrite p_not_odd in mod_odd.
    apply Zmod_divides in mod_odd; try lia.
    destruct mod_odd as [c c_id].
    rewrite Z.mul_comm in c_id.
    apply Zdivide_intro in c_id.
    apply prime_divisors in c_id; auto.
    destruct c_id; [lia | destruct H; [lia | destruct H; auto] ].
    pose proof (prime_ge_2 p prime_p); lia.
  Qed.

  Lemma odd_mod : forall a b, (b <> 0)%Z ->
    Z.odd (a mod b) = if Z.odd b then xorb (Z.odd a) (Z.odd (a / b)) else Z.odd a.
  Proof.
    intros a b H.
    rewrite Zmod_eq_full by assumption.
    rewrite <-Z.add_opp_r, Z.odd_add, Z.odd_opp, Z.odd_mul.
    case_eq (Z.odd b); intros; rewrite ?Bool.andb_true_r, ?Bool.andb_false_r; auto using Bool.xorb_false_r.
  Qed.
End Z.


(******************************************************************************)
(* Solutions of exercises : A script language for structured proofs           *)
(******************************************************************************)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq.
Require Import path choice fintype tuple finset.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(******************************************************************************)
(* Exercise 3.2.1                                                             *)
(******************************************************************************)

Section Tauto.

Variables A B C : Prop.

(* The exact tactic takes its argument on top of the goal stack *)
Lemma tauto1 : A -> A.
Proof.
exact.
Qed.

(* exact: hAB behaves like (by apply: hAB) and hence finds the hypothesis A
in the context needed to solve the goal *)
Lemma tauto2 : (A -> B) -> (B -> C) -> A -> C.
Proof.
move=> hAB hBC hA.
apply: hBC.
exact: hAB.
Qed.

Lemma tauto3 : A /\ B <-> B /\ A.
Proof. by split; case=> h1 h2; split. Qed.

End Tauto.

(******************************************************************************)
(* Exercise 3.2.2                                                             *)
(******************************************************************************)

Section MoreBasics.

Variables A B C : Prop.
Variable P : nat -> Prop.

Lemma foo1 : ~(exists x, P x) -> forall x, ~P x.
move=> h x Px.
apply: h.
by exists x.
Qed.

Lemma foo2 : (exists x, A -> P x) -> (forall x, ~P x) -> ~A.
Proof.
case=> x hx hP hA.
apply: (hP x).
exact: hx.
Qed.
End MoreBasics.

(******************************************************************************)
(* Exercise 3.2.3                                                             *)
(******************************************************************************)

(* Try Search "<=" to see the various notations featuring <= *)

(* The first line of the returned answer gives the name of
   the predicate (leq) *)
Search "_ <= _".

(* The Print command shows that leq is defined using subtraction *)
Print leq.

(* This time we see that the first line of the answer gives the *)
(*answer: there is no constant defining "<" but the notation hides a *)
(* defintiion using leq *)

Search "_ < _".

(* Both cases gereated by the induction lead to trivial goals *)
Lemma tuto_subnn : forall n : nat, n - n = 0.
Proof. by elim=> [|n ihn]. Qed.

(* This proof is an induction on m, followed by a case  analysis on *)
(* the second n. Base case is trivial (hence discarded by the // *)
(* switch. *)
Lemma tuto_subn_gt0 : forall m n, (0 < n - m) = (m < n).
Proof. elim=> [|m IHm] [|n] //; exact: IHm. Qed.

(* This proof starts the same way as the one of subn_gt0. *)
(* Then two rewriting are chained to reach to trivial subgoals *)
Lemma tuto_subnKC : forall m n : nat, m <= n -> m + (n - m) = n.
Proof.
elim=> [|m IHm] [|n] // Hmn.
Search _ (_.+1 + _ = _.+1).
by rewrite addSn IHm.
Qed.

(* The first Search command suggests we need to use something like *)
(*subn_add2r, hence to transform n into n - p + p *)
(* The second Search command finds the appropriate lemma. We rewrite *)
(*it from right to left, only at the second occurrence of n, the *)
(*condition of the lemma is fullfilled thanks to the le_pn hypothesis, *)
(*hence the generated subgoal is closed by the // switch *)

Lemma tuto_subn_subA : forall m n p, p <= n -> m - (n - p) = m + p - n.
Proof.
move=> m n p le_pn.
Search _ (_ + _ - _ = _) in ssrnat.
Search _ (_ - _ + _).
rewrite -{2}(subnK le_pn) // subn_add2r.
done.
Qed.

(******************************************************************************)
(* Exercise 3.5.1                                                             *)
(******************************************************************************)

(* The Check instruction only gives the type of a constant, the *)
(*statement of a lemma. The Print command gives the body of the *)
(*definition, and possibly some extra information (scope, implicit *)
(*arguments,...). Print should not be used in general on lemmas *)
(* since the body of a proof is seldom relevant...*)

Print edivn.
Print edivn_rec.
Print edivn_spec.
(* The edivn_spec is defined as a CoInductive predicate. The intended *)
(* meaning is not to define an coinductive structure, but rather an *)
(* inductive one. CoInductive in this case indeed behaves as Inductive *)
(*but does not generate an induction principle, which would be is *)
(*useless in this case. *)

(******************************************************************************)
(* Exercise 3.5.2                                                             *)
(******************************************************************************)

(* At this point, the top of the goal stack was featuring three *)
(*natural numers: an induction on the first one generated two subgoals. *)
(*In the second subgoal, corresponding to the inductive case, the *)
(*generated natural number and induction hypothesis have  been *)
(*introduced by the branching intro pattern [| n IHn], which leaves *)
(*the first subgoal, corresponding to the base case of the induction, *)
(*unchanged. Then [|m] performs in both subgoals a case analysis on the *)
(*second natural number. This case analysis again leads to two new *)
(*subgoal for each initial branch (which makes four subgoals). In the *)
(*second case of the analysis, the new natural number is introduced *)
(*and named m. Then the third natural number is uniformly introdued in *)
(*the four cases under the name q. Finally the //= switch simplifies *)
(*in the four bracnhes and closes the goals that have become trivial *)
(*(i.e. which are solved by done). *)

(******************************************************************************)
(* Exercise 3.5.3                                                             *)
(******************************************************************************)

(* The pattern [// | le_dm] closes the first subgoal and introduces an *)
(*hypothesis named le_dm in the second subgoal. This is equivalent to *)
(* // le_dm. *)

(******************************************************************************)
(* Exercise 3.5.4                                                             *)
(******************************************************************************)

(* Replacing (ltnP m d) by ltnP does not change the behaviour of the *)
(*script: Coq's unification is powerful enough to guess the arguments *)
(*in this case since there is only one instance of the comparison in *)
(* (_ <_) the goal. Arguments are mandatory only in the case the frist *)
(*occurrence of the comparison is not the one the user whould like to *)
(*pick as support for ase analysis. *)

Check ltnP.
Print ltn_xor_geq.

(* For any two natural numbers n and m, (ltn_xor_geq m n) is a binary *)
(*relation on boolean. Its inductive definition has two constructors *)
(*and states that *)
(* - (false, true) is in the relation(ltn_xor_geq m n) as soon as
     m < n *)
(* - (true, false) is in the relation(ltn_xor_geq m n) as soon as
     n <= m *)
(* The inductive construction implies that these two rules are the *)
(*only ways to populate the relation.*)
(* Now the theorem:*)
(* ltnP :  forall m n : nat, ltn_xor_geq m n (n <= m)(m < n)*)
(*proves that for any two natural numbers m and n, there are only two*)
(*possible situations:*)
(* - either m < n (first rule of the relation definition), and in this *)
(*case n <= m = false and m < n = true *)
(* - or n <= m (second rule of the relation definition, and in this *)
(*case n <= m = true and m < n = false *)
(* A case analysis on this result hence generates two subgoals, one *)
(*for each constructor of ltn_xor_gep. In each subgoal the hypothesis *)
(*of the rule (repectively m < n and n <= m) appears on the stack. Also *)
(*every occurrence of (n <= m) and (m < n) is replaced by the value *)
(*imposed by the ltn_xor_gep constructor used in the branch.*)

CoInductive tuto_compare_nat (m n : nat) : bool -> bool -> bool -> Set :=
  | TCompareNatLt of m < n : tuto_compare_nat m n true false false
  | TCompareNatGt of m > n : tuto_compare_nat m n false true false
  | TCompareNatEq of m = n : tuto_compare_nat m n false false true.

(* Let's check against what is defined in the ssrnat library *)
Print compare_nat.

Lemma tuto_ltngtP : forall m n, compare_nat m n (m < n) (n < m) (m == n).
Proof.
move=> m n; rewrite ltn_neqAle eqn_leq; case: ltnP; first by constructor.
by rewrite leq_eqVlt orbC; case: leqP => Hm; first move/eqnP; constructor.
Qed.


Require Import Coq.Program.Equality.
Require Import Setoid.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import PeanoNat.
Import Nat.

Require Import Lib.LinearOrder.
Require Import Lib.Sorted.

Inductive BT(A : Type) : Type :=
  | leaf : A -> BT A
  | node : BT A -> BT A -> BT A.

Arguments leaf {A}.
Arguments node {A}.

Fixpoint BTInsert {A : Type} (x : A) (tree : BT A) :=
  match tree with
  | leaf y => node (leaf x)(leaf y)
  | node l r => node r (BTInsert x l)
  end.

Fixpoint BTSize{A : Type}(tree : BT A) :=
  match tree with
  | leaf y => 1
  | node l r => BTSize l + BTSize r
  end.

Fixpoint listToBT{A : Type}(x : A)(list : list A): BT A :=
  match list with
  | nil => leaf x
  | cons y list' => BTInsert x (listToBT y list')
  end.

Fixpoint merge {A : Type} (ord : A -> A -> bool) (l1 : list A): (list A) -> list A :=
  match l1 with
  | [] => fun (l2 : list A) => l2
  | h1::t1 => fix anc (l2 : list A) : list A :=
    match l2 with
    | [] => l1
    | h2::t2 => if ord h1 h2
                then h1::(merge ord t1) l2
                else h2::anc t2
    end
  end.

Fixpoint BTSort {A : Type} (ord : A -> A -> bool) (t : BT A): list A :=
  match t with
  | leaf x => [x]
  | node l r => merge ord (BTSort ord l) (BTSort ord r)
  end.

Definition mergeSort {A: Type} (ord : A -> A -> bool) (l: list A): list A :=
  match l with
  | [] => []
  | x::l' => BTSort ord (listToBT x l')
  end.

Fixpoint BTToList{A: Type}(t: BT A) : list A :=
  match t with
  | leaf a => [a]
  | node l r => (BTToList l) ++ (BTToList r)
  end.

(* Perm def *)
Fixpoint BTCount {A: Type} (p: A -> bool) (t: BT A) :=
  match t with
  | leaf x => if p x then 1 else 0
  | node l r => BTCount p l + BTCount p r
  end.

Definition BTListPermutation{A: Type}(t: BT A)(l: list A) : Prop :=
  forall p: A->bool, BTCount p t = count p l.

Definition BTPermutation{A: Type}(t1 t2: BT A) : Prop :=
  forall p: A->bool, BTCount p t1 = BTCount p t2.

Lemma merge_perm {A: Type} (p: A->bool) (ord: A->A->bool) (l1 l2 : list A) :
  count p l1 + count p l2 = count p (merge ord l1 l2).
Proof.
  revert l2. induction l1; intros l2; auto.
  induction l2.
  - cbn. rewrite add_0_r. trivial.
  - cbn. destruct (ord a a0).
    + destruct (ord a0 a); cbn; destruct (p a); cbn;
      f_equal; rewrite <- IHl1; auto.
    + destruct (ord a0 a); cbn in *; destruct (p a0);
      try rewrite Nat.add_succ_r; try f_equal;
      rewrite <- IHl2; auto.
Qed.

Lemma BTSort_is_perm (A:Type) (ord: A->A->bool) (t : BT A) (p: A->bool) :
  BTCount p t = count p (BTSort ord t).
Proof.
  revert p. induction t; intro p; auto. cbn.
  rewrite IHt1, IHt2, <- merge_perm. auto.
Qed.

Lemma BT_insert_count (A : Type) (p: A->bool) (x : A) (t : BT A):
  BTCount p (BTInsert x t) = if p x then S (BTCount p t) else BTCount p t.
Proof.
  induction t; cbn.
  - destruct (p x), (p a); auto.
  - rewrite IHt1. destruct (p x); cbn.
    1: rewrite add_succ_r; f_equal.
    1-2: rewrite add_comm; auto.
Qed.

Lemma BTSort_perm (A: Type) (ord: A->A->bool) (l : list A) (x: A) :
   permutation (x::l) (BTSort ord (listToBT x l)).
Proof.
  revert x. induction l; intro x; cbn; try constructor.
  unfold permutation in *. intros p. rewrite <- BTSort_is_perm.
  rewrite BT_insert_count. cbn. destruct (p x) eqn:e.
  1: f_equal.
  1-2: cbn in *; rewrite IHl, <- BTSort_is_perm; auto.
Qed.

Lemma merged_sorted_lists (A: Type) `{lo: LinearOrder A} (l1 l2: list A) :
  Sorted l1 -> Sorted l2 -> Sorted (merge ord l1 l2).
Proof.
  intros s1. revert l2. induction s1; auto.
  - intros l2 s2. induction s2; cbn; try constructor.
    + destruct (ord h h0) eqn:o; constructor; try constructor; auto.
      apply ord_false_true. auto.
    + cbn. destruct (ord h h0) eqn:o.
      * assert (ord h h' = true) by (apply (trans h h0 h'); auto).
        cbn in IHs2. rewrite H0 in IHs2.
        constructor; try constructor; [dependent destruction IHs2 | | ]; auto.
      * cbn in IHs2. destruct (ord h h') eqn:o2; constructor; auto.
        apply ord_false_true; auto.
  - intros l2 s2. induction s2.
    + cbn. constructor; auto.
    + specialize (IHs1 [h0]). cbn in *. destruct (ord h' h0) eqn:o1.
      * assert (ord h h0 = true) by (apply (trans _ h' _); auto).
        rewrite H0. constructor; auto. apply IHs1. constructor.
      * destruct (ord h h0) eqn:o2; constructor; auto.
        -- apply IHs1; constructor.
        -- constructor; auto.
        -- apply ord_false_true; auto.
    + destruct (ord h h0) eqn:o1.
      * specialize (IHs1 (h0 :: h'0 :: t1)). cbn. rewrite o1.
        destruct (ord h' h0) eqn:o2; constructor; auto.
        1-2: cbn in IHs1; rewrite o2 in IHs1; apply IHs1; constructor; auto.
      * cbn in *. rewrite o1. destruct (ord h h'0) eqn:o2; constructor; auto.
        apply ord_false_true; assumption.
Qed.

Lemma BT_sorts (A: Type) `{lo: LinearOrder A} (t: BT A) : Sorted (BTSort ord t).
Proof.
  induction t; cbn.
  - constructor.
  - apply merged_sorted_lists; assumption.
Qed.

Theorem mergeSort_is_sorted (A: Type) `{lo: LinearOrder A} (l: list A):
  Sorted (mergeSort ord l).
Proof.
  induction l; cbn; try constructor. now apply BT_sorts.
Qed.

Theorem mergeSort_is_perm (A: Type) `{lo: LinearOrder A} (l: list A):
  permutation l (mergeSort ord l).
Proof.
  induction l; cbn.
  - unfold permutation. intro. cbn. reflexivity.
  - now apply BTSort_perm.
Qed.

Theorem merge_sort_idempotent (A: Type) `{lo: LinearOrder A} (l: list A):
  (mergeSort ord l) = (mergeSort ord (mergeSort ord l)).
Proof.
  apply sorted_unique_representation; auto.
  - apply mergeSort_is_perm.
  - apply mergeSort_is_sorted.
  - apply mergeSort_is_sorted.
Qed.


(**************************************************************)
(*   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 Relations Permutation.

Require Import rel_utils.

Require Import list_aux.
Require Import list_perm.
Require Import list_prod.
Require Import list_forall.

(*
Require Import finite.
*)

Set Implicit Arguments.

Section list_fan.

  Variable (X : Type).

  Fixpoint list_fan (lw : list (list X)) :=
    match lw with
      | nil => nil::nil
      | w::lw => list_prod (@cons _) w (list_fan lw)
    end.

  (* list_fan [l1;...;lk] contains all the list of the form [x1;...;xk]
     with x1 in l1, x2 in l2 ... xk in lk
  *)

  Fact list_fan_eq_nil lw : list_fan lw = nil -> exists w, In w lw /\ w = nil.
  Proof.
    induction lw as [ | w lw IH ]; simpl.
    discriminate 1.
    intros H.
    apply list_prod_nil in H.
    destruct H as [ H | H ].
    exists w; auto.
    destruct (IH H) as (w' & ? & ?).
    exists w'; auto.
  Qed.

  Fact list_fan_spec lw : forall w, In w (list_fan lw) <-> Forall2 (@In _) w lw.
  Proof.
    induction lw as [ | w lw ]; intros x; simpl.
    destruct x as [ | ].
    split; auto.
    split.
    intros [ H | [] ]; discriminate H.
    intros H; inversion H.
    rewrite list_prod_spec.
    split.
    intros (a & u & H1 & H2 & ?); subst.
    constructor; auto.
    revert H2; apply IHlw.
    intros H; destruct x as [ | a x ]; inversion_clear H.
    exists a, x; repeat split; auto.
    apply IHlw; auto.
  Qed.

  Fact list_fan_cons_In w lw l : In l (list_fan (w::lw)) <-> exists x l', In x w /\ In l' (list_fan lw) /\ l = x::l'.
  Proof.
    simpl.
    rewrite list_prod_spec.
    split; auto.
  Qed.

  Fact list_fan_app w1 w2 lw : list_fan ((w1++w2)::lw) ~p list_fan (w1::lw) ++ list_fan (w2::lw).
  Proof.
    apply list_prod_app_left.
  Qed.

  Fact list_fan_cons a w lw : list_fan ((a::w)::lw) ~p list_fan ((a::nil)::lw) ++ list_fan (w::lw).
  Proof.
    apply (list_fan_app (a::nil)).
  Qed.

  Fact list_fan_nil lw rw : list_fan (lw++nil::rw) = nil.
  Proof.
    induction lw as [ | w lw IH ]; simpl.
    apply list_prod_nil_left.
    rewrite IH, list_prod_nil_right; auto.
  Qed.

  Fact list_fan_sg_left lw a : list_fan ((a::nil)::lw) = map (cons a) (list_fan lw).
  Proof.
    simpl list_fan at 1.
    unfold list_prod.
    generalize (list_fan lw); clear lw.
    induction l; simpl; f_equal; auto.
  Qed.

  Fact list_fan_sg_right lw a : list_fan (lw++(a::nil)::nil) = map (fun w => w++a::nil) (list_fan lw).
  Proof.
    induction lw as [ | w lw IH ]; simpl; auto.
    rewrite IH.
    unfold list_prod.
    rewrite map_flat_map, flat_map_map.
    apply flat_map_ext.
    intros x _.
    rewrite map_map.
    apply map_ext.
    intros ?; auto.
  Qed.

  Fact list_fan_middle_app lw w1 w2 rw : list_fan (lw++(w1++w2)::rw) ~p list_fan (lw++w1::rw) ++ list_fan (lw++w2::rw).
  Proof.
    induction lw as [ | w lw IHlw ].
    simpl app at 1 3.
    rewrite list_fan_app; auto; simpl.
    apply list_prod_perm with (f := @cons X) (1 := Permutation_refl w) in IHlw.
    apply Permutation_trans with (1 := IHlw),
          Permutation_trans with (1 := list_prod_app_right _ _ _ _); auto.
  Qed.

  Fact list_fan_middle_cons lw a w rw : list_fan (lw++(a::w)::rw) ~p list_fan (lw++(a::nil)::rw) ++ list_fan (lw++w::rw).
  Proof.
    apply list_fan_middle_app with (w1 := a::nil).
  Qed.

  Fact list_fan_mono lw mw : Forall2 (@incl _) lw mw -> incl (list_fan lw) (list_fan mw).
  Proof.
    induction 1 as [ | l m lw mw H1 H2 IH2 ].
    apply incl_refl.
    intros x Hx.
    rewrite list_fan_spec in Hx.
    rewrite list_fan_spec.
    destruct x as [ | a x ].
    inversion Hx.
    apply Forall2_cons_inv in Hx.
    destruct Hx as [ Ha Hx ].
    constructor 2.
    revert Ha; auto.
    revert Hx; do 2 rewrite <- list_fan_spec; auto.
  Qed.

  Let list_fan_rev_alt x lw : In x (list_fan lw) -> In (rev x)  (list_fan (rev lw)).
  Proof.
    do 2 rewrite list_fan_spec.
    induction 1; simpl.
    constructor.
    apply Forall2_app; auto.
  Qed.

  Fact list_fan_rev x lw : In (rev x)  (list_fan (rev lw)) <-> In x (list_fan lw).
  Proof.
    split; auto.
    rewrite <- (rev_involutive lw) at 2.
    rewrite <- (rev_involutive x) at 2.
    auto.
  Qed.

  Fact list_fan_length lw w : In w (list_fan lw) -> length w = length lw.
  Proof.
    rewrite list_fan_spec.
    apply Forall2_length.
  Qed.

  Section list_fan_Forall.

    Variable P : list X -> Prop.

    Fact list_fan_Forall_cons a lw : Forall (fun l => P (a::l)) (list_fan lw)
                                  -> Forall P (list_fan ((a::nil)::lw)).
    Proof.
      do 2 rewrite Forall_forall.
      intros H x Hx.
      rewrite list_fan_sg_left, in_map_iff in Hx.
      destruct Hx as (y & H1 & Hx); subst; auto.
    Qed.

    Fact list_fan_Forall w lw : Forall (fun a => Forall (fun l => P (a::l)) (list_fan lw)) w
                             -> Forall P (list_fan (w::lw)).
    Proof.
      induction w as [ | a w IH ].
      generalize (list_fan_nil nil lw); simpl; intros H; rewrite H; constructor.
      intros H; rewrite (Forall_perm _ (list_fan_cons _ _ _)), Forall_app; split.
      apply list_fan_Forall_cons.
      apply Forall_inv in H; auto.
      apply IH.
      inversion_clear H; auto.
    Qed.

  End list_fan_Forall.

  Fact list_fan_Forall_Forall P ll : Forall (Forall P) ll -> Forall (Forall P) (list_fan ll).
  Proof.
    induction 1 as [ | x ll Hx Hll IHll ].
    constructor; constructor.
    apply list_fan_Forall.
    revert Hx; do 2 rewrite Forall_forall; intros Hx u Hu.
    revert IHll; apply Forall_impl; constructor; auto.
  Qed.

End list_fan.

Fact list_fan_map_map U V (f : U -> V) (ll : list (list U)) : list_fan (map (map f) ll) = map (map f) (list_fan ll).
Proof.
  induction ll as [ | ? ? IH ]; simpl; f_equal.
  rewrite IH.
  rewrite <- list_prod_map, map_list_prod.
  auto.
Qed.