(** * Sort: Insertion Sort *)

(** Sorting can be done in expected O(N log N) time by various
    algorithms (quicksort, mergesort, heapsort, etc.).  But for
    smallish inputs, a simple quadratic-time algorithm such as
    insertion sort can actually be faster.  It's certainly easier to
    implement -- and to verify. *)

(** If you don't recall insertion sort or haven't seen it in
    awhile, see Wikipedia or read any standard textbook; for example:

    - Sections 2.0 and 2.1 of _Algorithms, Fourth Edition_, by
      Sedgewick and Wayne, Addison Wesley 2011; or

    - Section 2.1 of _Introduction to Algorithms, 3rd Edition_, by
      Cormen, Leiserson, and Rivest, MIT Press 2009. *)

From VFA Require Import Perm.

(* ################################################################# *)
(** * The Insertion-Sort Program *)

(** Insertion sort is usually presented as an imperative program
    operating on arrays.  But it works just as well as a functional
    program operating on linked lists. *)

(* [insert i l] inserts [i] into its sorted place in list [l].
   Precondition: [l] is sorted. *)
Fixpoint insert (i : nat) (l : list nat) :=
  match l with
  | [] => [i]
  | h :: t => if i <=? h then i :: h :: t else h :: insert i t
  end.

Fixpoint sort (l : list nat) : list nat :=
  match l with
  | [] => []
  | h :: t => insert h (sort t)
  end.

Example sort_pi :
  sort [3;1;4;1;5;9;2;6;5;3;5]
  = [1;1;2;3;3;4;5;5;5;6;9].
Proof. simpl. reflexivity. Qed.

(** We won't analyze or prove anything about the efficiency of
    [sort]. Instead, we will verify its correctness: that it produces
    the correct output for a given input. *)

(* ################################################################# *)
(** * Specification of Correctness *)

(** A sorting algorithm must rearrange the elements into a list
    that is totally ordered. There are many ways we might express that
    idea formally in Coq.  One is with an inductively-defined
    relatio that says: *)

(** - The empty list is sorted.

    - Any single-element list is sorted.

    - For any two adjacent elements, they must be in the proper order. *)

Inductive sorted: list nat -> Prop :=
| sorted_nil:
    sorted []
| sorted_1: forall x,
    sorted [x]
| sorted_cons: forall x y l,
    x <= y -> sorted (y :: l) -> sorted (x :: y :: l).

Hint Constructors sorted.

(** This definition might not be the most obvious. Another definition,
    perhaps more familiar, might be: for any two elements of the list
    (regardless of whether they are adjacent), they should be in the
    proper order.  Let's try formalizing that.

    We can think in terms of indices into a list [lst], and say: for
    any valid indices [i] and [j], if [i < j] then [index lst i <=
    index lst j], where [index lst n] means the element of [lst] at
    index [n].  Unfortunately, formalizing this idea becomes messy,
    because any Coq implementing [index] must be total: it must return
    some result even if the index is out of range for the list.
    The Coq standard library contains two such functions: *)

Check nth : forall A : Type, nat -> list A -> A -> A.
Check nth_error : forall A : Type, list A -> nat -> option A.

(** These two functions ensure totality in different ways:

    - [nth] takes an additional argument of type [A] --a _default_
      value-- to be returned if the index is out of range, whereas

    - [nth_error] returns [Some v] if the index is in range and [None]
      --an error-- otherwise.

    If we use [nth], we must ensure that indices are in range: *)

Definition sorted'' (al: list nat) := forall i j,
    i < j < length al ->
    nth i al 0 <= nth j al 0.

(** The choice of default value, here 0, is unimportant, because it
    will never be returned for the [i] and [j] we pass.

    If we use [nth_error], we must add additional antecedents: *)

Definition sorted' (al: list nat) := forall i j iv jv,
    i < j ->
    nth_error al i = Some iv ->
    nth_error al j = Some jv ->
    iv <= jv.

(** Here, the validity of [i] and [j] are implicit in the fact that we
    get [Some] results back from each call to [nth_error].

    All three definitions of sortedness we have given are reasonable.
    In practice, [sorted'] is easier to work with than [sorted'']
    because it doesn't need to mention the [length] function. And
    [sorted] is easier than either.  *)

(** Using [sorted], we specify what it means to be a correct sorting
    algorthm: *)

Definition is_a_sorting_algorithm (f: list nat -> list nat) := forall al,
    Permutation al (f al) /\ sorted (f al).

(** Function [f] is a correct sorting algorithm if [f al] is
    [sorted] and is a permutation of its input. *)

(* ################################################################# *)
(** * Proof of Correctness *)

(** In the following exercises, you will prove the correctness of
    insertion sort. *)

(** **** Exercise: 3 stars, standard (insert_sorted)  *)

(* Prove that insertion maintains sortedness. Make use of tactic
   [bdestruct], defined in [Perm]. *)

Lemma insert_sorted:
  forall a l, sorted l -> sorted (insert a l).
Proof.
  intros a l S. induction S; simpl.
  (* SOLUTION: *)
  - constructor.
  - bdestruct (x >=? a); auto.
    constructor; auto. omega.
  - bdestruct (x >=? a); auto.
    bdestruct (y >=? a).
    + constructor; auto. omega.
    + constructor; auto.
      simpl in IHS. bdestruct (y >=? a); auto. omega.
Qed.

(** [] *)

(** **** Exercise: 2 stars, standard (sort_sorted)  *)

(** Using [insert_sorted], prove that insertion sort makes a list
    sorted. *)

Theorem sort_sorted: forall l, sorted (sort l).
Proof.
(* SOLUTION: *)
  induction l; simpl; auto.
  apply insert_sorted. auto.
Qed.

(** [] *)

(** **** Exercise: 3 stars, standard (insert_perm)  *)

(** The following lemma will be useful soon as a helper. Take
    advantage of helpful theorems from the [Permutation] library. *)

Lemma insert_perm: forall x l,
    Permutation (x :: l) (insert x l).
Proof.
  (* SOLUTION: *)
  induction l; simpl.
  - apply Permutation_refl.
  - destruct (x <=? a).
    + apply Permutation_refl.
    + apply perm_trans with (a :: x :: l).
      * apply perm_swap.
      * apply perm_skip. assumption.
Qed.

(** [] *)

(** **** Exercise: 3 stars, standard (sort_perm)  *)

(** Prove that [sort] is a permutation, using [insert_perm]. *)

Theorem sort_perm: forall l, Permutation l (sort l).
Proof.
(* SOLUTION: *)
  induction l.
  - apply Permutation_refl.
  - simpl. apply Permutation_trans with (a :: (sort l)).
    + apply perm_skip. assumption.
    + apply insert_perm.
Qed.

(** [] *)

(** **** Exercise: 1 star, standard (insertion_sort_correct)  *)

(** Finish the proof of correctness! *)

Theorem insertion_sort_correct:
    is_a_sorting_algorithm sort.
Proof.
  (* SOLUTION: *)
  split.
  - apply sort_perm.
  - apply sort_sorted.
Qed.

(** [] *)

(* ################################################################# *)
(** * Validating the Specification (Advanced) *)

(** You can prove that a program satisfies a specification, but how
    can you prove you have the right specification?  Actually, you
    cannot.  The specification is an informal requirement in your
    mind.  As Alan Perlis quipped, "One can't proceed from the
    informal to the formal by formal means."

    But one way to build confidence in a specification is to state it
    in two different ways, then prove they are equivalent. *)

(** **** Exercise: 4 stars, advanced (sorted_sorted')  *)
Lemma sorted_sorted': forall al, sorted al -> sorted' al.

(** Hint: Instead of doing induction on the list [al], do induction on
    the sortedness of [al]. This proof is a bit tricky, so you may
    have to think about how to approach it, and try out one or two
    different ideas.*)
Proof.
(* SOLUTION: *)
  unfold sorted'; induction 1; intros i j iv jv LT Hi Hj.
  - destruct i; inv Hi.
  - destruct j as [|j'].
    + omega.
    + destruct j'; inv Hj.
  - destruct j as [|j'].
    + omega.
    + destruct i as [|i'].
      * inv Hi.
        destruct j' as [|j''].
        -- inv Hj.  auto.
        -- apply le_trans with y. auto.
            eapply (IHsorted 0 (S j'')). omega. auto. auto.
      * apply (IHsorted i' j'). omega. auto. auto. Qed.
(** [] *)

(** **** Exercise: 3 stars, advanced (sorted'_sorted)  *)
Lemma sorted'_sorted : forall al, sorted' al -> sorted al.
Proof.
(** Here, you can't do induction on the sortedness of the list,
    because [sorted'] is not an inductive predicate. But the proof
    is not hard. *)
(* SOLUTION: *)
  unfold sorted'. induction al; intros.
  - constructor.
  - destruct al.
    + constructor.
    + constructor.
      * eapply (H 0 1). omega. auto. auto.
      * apply IHal. intros.
        apply (H (S i) (S j)). omega. auto. auto. Qed.
(** [] *)

(* ################################################################# *)
(** * Proving Correctness from the Alternative Spec (Optional) *)

(** Depending on how you write the specification of a program, it can
    be harder or easier to prove correctness.  We saw that predicates
    [sorted] and [sorted'] are equivalent.  It is significantly
    harder, though, to prove correctness of insertion sort directly
    from [sorted'].

    Give it a try!  The best proof we know of makes essential use of
    the auxiliary lemma [nth_default_insert], so you may want to prove
    that first.  And some other auxiliary lemmas may be needed too.
    But maybe you will find a simpler appraoch!

    DO NOT USE [sorted_sorted'], [sorted'_sorted], [insert_sorted], or
    [sort_sorted] in these proofs.  That would defeat the purpose! *)

(** **** Exercise: 5 stars, standard, optional (insert_sorted')  *)

Lemma nth_error_insert : forall l a i iv,
    nth_error (insert a l) i = Some iv ->
    a = iv \/ exists i', nth_error l i' = Some iv.
Proof.
(* SOLUTION: *)
 induction l; intros.
 - inv H. destruct i as [|i'].
   + inv H1. auto.
   + inv H1. destruct i'; inv H0.
 - simpl in H.
   bdestruct (a0 <=? a).
   + destruct i as [|i'].
     * inv H. auto.
     * simpl in H. right. eauto.
   + destruct i as [|i'].
     * right. exists 0. auto.
     * simpl in H. destruct (IHl _ _ _ H) as [P|[i'' P]].
       -- auto.
       -- right; exists (S i''); auto. Qed.

Lemma insert_length: forall a l, length (insert a l) = S(length l).
Proof.
  intros a l. induction l.
  - auto.
  - simpl. destruct (a <=? a0).
    + auto.
    + simpl. rewrite IHl.  auto. Qed.

Lemma insert_sorted':
  forall a l, sorted' l -> sorted' (insert a l).
Proof.
(* SOLUTION: *)
  intros a l. generalize dependent a.
  induction l; intros a0 H i j iv jv LT Hi Hj.
  - simpl in Hi, Hj.
    destruct j as [|j'].
    + inversion LT.
    + inversion Hj as [C].
      destruct j'; inversion C.
  - simpl in Hi, Hj.
    destruct j as [|j'].  omega.
    bdestruct (a0 <=? a).
    + destruct i as [|i'].
      * inv Hi.
        apply le_trans with a. auto.
        simpl in Hj.
        destruct j' as [|j''].
        -- inv Hj. omega.
        -- apply (H 0 (S j'')); auto; omega.
      * apply (H i' j'); auto; omega.
    + destruct i as [|i'].
      * inv Hi. simpl in Hj.
        destruct (nth_error_insert _ _ _ _ Hj) as [P | [i' P]].
        -- omega.
        -- apply (H 0 (S i')); auto; omega.
      * eapply IHl with (a := a0) (i := i') (j:= j'); auto; try omega.
        intros i j iv0 jv0 LT0 Hi0 Hj0.
        apply (H (S i) (S j)); auto; omega.
Qed.
(** [] *)

Theorem sort_sorted': forall l, sorted' (sort l).
Proof.
  induction l.
  - unfold sorted'. intros. destruct i; inv H0.
  - simpl. apply insert_sorted'. auto.
Qed.

(** If you complete the proofs above, you will note that the proof of
    [insert_sorted] is relatively easy compared to the proof of
    [insert_sorted'], even though [sorted al <-> sorted' al].  So,
    suppose someone asked you to prove [sort_sorted'].  Instead of
    proving it directly, it would be much easier to design predicate
    [sorted], then prove [sort_sorted] and [sorted_sorted'].

    The moral of the story is therefore: _Different formulations of
    the functional specification can lead to great differences in the
    difficulty of the correctness proofs_. *)

(* Mon May 11 23:22:55 EDT 2020 *)


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Problem(s):
    Simple Semi-Thue System 01 Rewriting (SSTS01)
*)

(*
  Literature:
  [1] Dudenhefner, Andrej, and Jakob Rehof.
      "Undecidability of Intersection Type Inhabitation at Rank 3 and its Formalization."
      Fundamenta Informaticae 170.1-3 (2019): 93-110.
*)

Require Import List Relation_Operators.

(* A simple semi-Thue system consists of rules "ab -> cd" where a, b, c, d : nat *)
Definition Ssts := list ((nat * nat) * (nat * nat)).

(* one-step rewriting relation
   if (ab -> cd) in ssts, then uabv -> ucdv where u, v : list nat *)
Inductive step (ssts: Ssts) : list nat -> list nat -> Prop :=
  | step_intro {u v: list nat} {a b c d: nat} :
      In ((a, b), (c, d)) ssts -> step ssts (u ++ a :: b :: v) (u ++ c :: d :: v).

(* reflexive, transitive closure of one-step rewriting *)
Definition multi_step (ssts: Ssts) : list nat -> list nat -> Prop :=
  clos_refl_trans (list nat) (step ssts).

(* simple semi-Thue system 01 rewriting, that is
   for given a simple semi-Thue system, does 0^(1+n) ->> 1^(1+n) hold for some n? *)
Definition SSTS01 : Ssts -> Prop :=
  fun ssts => exists n, multi_step ssts (repeat 0 (1+n)) (repeat 1 (1+n)).


Welcome to Coq ciosx:/builds/workspace/coq-8.5pl3-macos,(detached from 2290dbb) (2290dbb9c95b63e693ced647731623e64297f5c8)

Coq < Module Playground2.
Interactive Module Playground2 started

Coq < Require Import Arith Classical.
[Loading ML file z_syntax_plugin.cmxs ... done]
[Loading ML file quote_plugin.cmxs ... done]
[Loading ML file newring_plugin.cmxs ... done]
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked

Coq < Fixpoint plus (n : nat) (m : nat) : nat := match n with | O => m | S n' => S (plus n' m) end.
plus is defined
plus is recursively defined (decreasing on 1st argument)

Coq < Fixpoint mult (n m : nat) : nat := match n with | O => O | S n' => plus m (mult n' m) end.
mult is defined
mult is recursively defined (decreasing on 1st argument)

Coq < Example test_mult1: (mult 3 3) = 9.
1 subgoal

  ============================
  mult 3 3 = 9

test_mult1 < Proof.
1 subgoal

  ============================
  mult 3 3 = 9

test_mult1 < simpl.
1 subgoal

  ============================
  9 = 9

test_mult1 < reflexivity.
No more subgoals.

test_mult1 < Qed.
Proof.
simpl.
reflexivity.

Qed.
test_mult1 is defined

Coq < Fixpoint minus (n m:nat) : nat := match n, m with | O , _ => O | S _ , O => n | S n', S m' => minus n' m' end.
minus is defined
minus is recursively defined (decreasing on 1st argument)

Coq < Compute (minus 8 6).
     = 2
     : nat

Coq < Example test_minus1: (minus 7 3) = 4.
1 subgoal

  ============================
  minus 7 3 = 4

test_minus1 < Proof.
1 subgoal

  ============================
  minus 7 3 = 4

test_minus1 < simpl.
1 subgoal

  ============================
  4 = 4

test_minus1 < reflexivity.
No more subgoals.

test_minus1 < Qed.
Proof.
simpl.
reflexivity.

Qed.
test_minus1 is defined

Coq < End Playground2.
Module Playground2 is defined


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

(**********************************************************************
     Aux.v

     Auxillary functions & Theorems
 **********************************************************************)
Require Export Arith.

(**************************************
  Some properties of minus
**************************************)

Theorem minus_O : forall a b : nat, a <= b -> a - b = 0.
intros a; elim a; simpl in |- *; auto with arith.
intros a1 Rec b; case b; elim b; auto with arith.
Qed.

(**************************************
  Definitions and properties of the power for nat
**************************************)

Fixpoint pow (n m: nat)  {struct m} : nat := match m with O => 1%nat | (S m1) => (n * pow n m1)%nat  end.

Theorem pow_add: forall n m p, pow n (m + p) = (pow n m * pow n p)%nat.
intros n m; elim m; simpl.
intros p; rewrite plus_0_r; auto.
intros m1 Rec p; rewrite Rec; auto with arith.
Qed.

Theorem pow_pos: forall p n, (0 < p)%nat -> (0 < pow p n)%nat.
intros p1 n H; elim n; simpl; auto with arith.
intros n1 H1; replace 0%nat with (p1 * 0)%nat; auto with arith.
repeat rewrite (mult_comm p1); apply mult_lt_compat_r; auto with arith.
Qed.

Theorem pow_monotone: forall n p q, (1 < n)%nat -> (p < q)%nat -> (pow n p < pow n q)%nat.
intros n p1 q1 H H1; elim H1; simpl.
pattern (pow n p1) at 1; rewrite <- (mult_1_l (pow n p1)).
apply mult_lt_compat_r; auto.
apply pow_pos; auto with arith.
intros n1 H2 H3.
apply lt_trans with (1 := H3).
pattern (pow n n1) at 1; rewrite <- (mult_1_l (pow n n1)).
apply mult_lt_compat_r; auto.
apply pow_pos; auto with arith.
Qed.

(************************************
  Definition of the divisibility for nat
**************************************)

Definition divide a b := exists c, b = a * c.

Theorem divide_le: forall p q, (1 < q)%nat -> divide p q -> (p <= q)%nat.
intros p1 q1 H (x, H1); subst.
apply le_trans with (p1 * 1)%nat; auto with arith.
rewrite mult_1_r; auto with arith.
apply mult_le_compat_l.
case (le_lt_or_eq 0 x); auto with arith.
intros H2; subst; contradict H; rewrite mult_0_r; auto with arith.
Qed.


(** * Types: Type Systems *)

Require Import Coq.Arith.Arith.

Require Import SfLib.
Require Import Maps.
Require Import Imp.
Require Import Smallstep.

(* INSTRUCTORS. : APT: best place I could find for these without
   requiring new Auto *)
Hint Constructors multi.

(** Our next major topic is _type systems_ -- static program
    analyses that classify expressions according to the "shapes" of
    their results.  We'll begin with a typed version of a very simple
    language with just booleans and numbers, to introduce the basic
    ideas of types, typing rules, and the fundamental theorems about
    type systems: _type preservation_ and _progress_.  Then we'll move
    on to the _simply typed lambda-calculus_, which lives at the core
    of every modern functional programming language (including
    Coq). *)

(* ###################################################################### *)
(** * Typed Arithmetic Expressions *)

(** To motivate the discussion of type systems, let's begin as
    usual with an extremely simple toy language.  We want it to have
    the potential for programs "going wrong" because of runtime type
    errors, so we need something a tiny bit more complex than the
    language of constants and addition that we used in chapter
    [Smallstep]: a single kind of data (just numbers) is too simple,
    but just two kinds (numbers and booleans) already gives us enough
    material to tell an interesting story.

    The language definition is completely routine.  *)

(* ###################################################################### *)
(** ** Syntax *)

(** Informally:
    t ::= true
        | false
        | if t then t else t
        | 0
        | succ t
        | pred t
        | iszero t
    Formally:
*)

Inductive tm : Type :=
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm
  | tzero : tm
  | tsucc : tm -> tm
  | tpred : tm -> tm
  | tiszero : tm -> tm.

(** _Values_ are [true], [false], and numeric values... *)

Inductive bvalue : tm -> Prop :=
  | bv_true : bvalue ttrue
  | bv_false : bvalue tfalse.

Inductive nvalue : tm -> Prop :=
  | nv_zero : nvalue tzero
  | nv_succ : forall t, nvalue t -> nvalue (tsucc t).

Definition value (t:tm) := bvalue t \/ nvalue t.

Hint Constructors bvalue nvalue.
Hint Unfold value.
Hint Unfold update.

(* ###################################################################### *)
(** ** Operational Semantics *)

(** Informally: *)
(**
                    ------------------------------                  (ST_IfTrue)
                    if true then t1 else t2 ==> t1

                   -------------------------------                 (ST_IfFalse)
                   if false then t1 else t2 ==> t2

                              t1 ==> t1'
                      -------------------------                         (ST_If)
                      if t1 then t2 else t3 ==>
                        if t1' then t2 else t3

                              t1 ==> t1'
                         --------------------                         (ST_Succ)
                         succ t1 ==> succ t1'

                             ------------                         (ST_PredZero)
                             pred 0 ==> 0

                           numeric value v1
                        ---------------------                     (ST_PredSucc)
                        pred (succ v1) ==> v1

                              t1 ==> t1'
                         --------------------                         (ST_Pred)
                         pred t1 ==> pred t1'

                          -----------------                     (ST_IszeroZero)
                          iszero 0 ==> true

                           numeric value v1
                      --------------------------                (ST_IszeroSucc)
                      iszero (succ v1) ==> false

                              t1 ==> t1'
                       ------------------------                     (ST_Iszero)
                       iszero t1 ==> iszero t1'
*)

(** Formally: *)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)
  | ST_Succ : forall t1 t1',
      t1 ==> t1' ->
      (tsucc t1) ==> (tsucc t1')
  | ST_PredZero :
      (tpred tzero) ==> tzero
  | ST_PredSucc : forall t1,
      nvalue t1 ->
      (tpred (tsucc t1)) ==> t1
  | ST_Pred : forall t1 t1',
      t1 ==> t1' ->
      (tpred t1) ==> (tpred t1')
  | ST_IszeroZero :
      (tiszero tzero) ==> ttrue
  | ST_IszeroSucc : forall t1,
       nvalue t1 ->
      (tiszero (tsucc t1)) ==> tfalse
  | ST_Iszero : forall t1 t1',
      t1 ==> t1' ->
      (tiszero t1) ==> (tiszero t1')

where "t1 '==>' t2" := (step t1 t2).

Hint Constructors step.
(** Notice that the [step] relation doesn't care about whether
    expressions make global sense -- it just checks that the operation
    in the _next_ reduction step is being applied to the right kinds
    of operands.

    For example, the term [succ true] (i.e., [tsucc ttrue] in the
    formal syntax) cannot take a step, but the almost as obviously
    nonsensical term
       succ (if true then true else true)
    can take a step (once, before becoming stuck). *)

(* ###################################################################### *)
(** ** Normal Forms and Values *)

(** The first interesting thing about the [step] relation in this
    language is that the strong progress theorem from the Smallstep
    chapter fails!  That is, there are terms that are normal
    forms (they can't take a step) but not values (because we have not
    included them in our definition of possible "results of
    evaluation").  Such terms are _stuck_. *)

Notation step_normal_form := (normal_form step).

Definition stuck (t:tm) : Prop :=
  step_normal_form t /\ ~ value t.

Hint Unfold stuck.

(** **** Exercise: 2 stars (some_term_is_stuck)  *)
Example some_term_is_stuck :
  exists t, stuck t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** However, although values and normal forms are not the same in this
    language, the former set is included in the latter.  This is
    important because it shows we did not accidentally define things
    so that some value could still take a step. *)

(** **** Exercise: 3 stars, advanced (value_is_nf)  *)
(** Hint: You will reach a point in this proof where you need to
    use an induction to reason about a term that is known to be a
    numeric value.  This induction can be performed either over the
    term itself or over the evidence that it is a numeric value.  The
    proof goes through in either case, but you will find that one way
    is quite a bit shorter than the other.  For the sake of the
    exercise, try to complete the proof both ways. *)

Lemma value_is_nf : forall t,
  value t -> step_normal_form t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, optional (step_deterministic)  *)
(** Using [value_is_nf], we can show that the [step] relation is
    also deterministic... *)

Theorem step_deterministic:
  deterministic step.
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** ** Typing *)

(** The next critical observation about this language is that,
    although there are stuck terms, they are all "nonsensical", mixing
    booleans and numbers in a way that we don't even _want_ to have a
    meaning.  We can easily exclude such ill-typed terms by defining a
    _typing relation_ that relates terms to the types (either numeric
    or boolean) of their final results.  *)

Inductive ty : Type :=
  | TBool : ty
  | TNat : ty.

(** In informal notation, the typing relation is often written
    [|- t \in T], pronounced "[t] has type [T]."  The [|-] symbol is
    called a "turnstile".  (Below, we're going to see richer typing
    relations where an additional "context" argument is written to the
    left of the turnstile.  Here, the context is always empty.) *)
(**
                           ----------------                            (T_True)
                           |- true \in Bool

                          -----------------                           (T_False)
                          |- false \in Bool

             |- t1 \in Bool    |- t2 \in T    |- t3 \in T
             --------------------------------------------                (T_If)
                    |- if t1 then t2 else t3 \in T

                             ------------                              (T_Zero)
                             |- 0 \in Nat

                            |- t1 \in Nat
                          ------------------                           (T_Succ)
                          |- succ t1 \in Nat

                            |- t1 \in Nat
                          ------------------                           (T_Pred)
                          |- pred t1 \in Nat

                            |- t1 \in Nat
                        ---------------------                        (T_IsZero)
                        |- iszero t1 \in Bool
*)

Reserved Notation "'|-' t '\in' T" (at level 40).

Inductive has_type : tm -> ty -> Prop :=
  | T_True :
       |- ttrue \in TBool
  | T_False :
       |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T,
       |- t1 \in TBool ->
       |- t2 \in T ->
       |- t3 \in T ->
       |- tif t1 t2 t3 \in T
  | T_Zero :
       |- tzero \in TNat
  | T_Succ : forall t1,
       |- t1 \in TNat ->
       |- tsucc t1 \in TNat
  | T_Pred : forall t1,
       |- t1 \in TNat ->
       |- tpred t1 \in TNat
  | T_Iszero : forall t1,
       |- t1 \in TNat ->
       |- tiszero t1 \in TBool

where "'|-' t '\in' T" := (has_type t T).

Hint Constructors has_type.

(* ###################################################################### *)
(** *** Examples *)

(** It's important to realize that the typing relation is a
    _conservative_ (or _static_) approximation: it does not calculate
    the type of the normal form of a term. *)

Example has_type_1 :
  |- tif tfalse tzero (tsucc tzero) \in TNat.
Proof.
  apply T_If.
    apply T_False.
    apply T_Zero.
    apply T_Succ.
      apply T_Zero.
Qed.

(** (Since we've included all the constructors of the typing relation
    in the hint database, the [auto] tactic can actually find this
    proof automatically.) *)

Example has_type_not :
  ~ (|- tif tfalse tzero ttrue \in TBool).
Proof.
  intros Contra. solve by inversion 2.  Qed.

(** **** Exercise: 1 star, optional (succ_hastype_nat__hastype_nat)  *)
Example succ_hastype_nat__hastype_nat : forall t,
  |- tsucc t \in TNat ->
  |- t \in TNat.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** ** Canonical forms *)

(** The following two lemmas capture the basic property that defines
    the shape of well-typed values.  They say that the definition of value
    and the typing relation agree. *)

Lemma bool_canonical : forall t,
  |- t \in TBool -> value t -> bvalue t.
Proof.
  intros t HT HV.
  inversion HV; auto.

  induction H; inversion HT; auto.
Qed.

Lemma nat_canonical : forall t,
  |- t \in TNat -> value t -> nvalue t.
Proof.
  intros t HT HV.
  inversion HV.
  inversion H; subst; inversion HT.

  auto.
Qed.

(* ###################################################################### *)
(** ** Progress *)

(** The typing relation enjoys two critical properties.  The first is
    that well-typed normal forms are values (i.e., not stuck). *)

Theorem progress : forall t T,
  |- t \in T ->
  value t \/ exists t', t ==> t'.

(** **** Exercise: 3 stars (finish_progress)  *)
(** Complete the formal proof of the [progress] property.  (Make sure
    you understand the informal proof fragment in the following
    exercise before starting -- this will save you a lot of time.) *)

Proof with auto.
  intros t T HT.
  induction HT...
  (* The cases that were obviously values, like T_True and
     T_False, were eliminated immediately by auto *)
  - (* T_If *)
    right. inversion IHHT1; clear IHHT1.
    + (* t1 is a value *)
    apply (bool_canonical t1 HT1) in H.
    inversion H; subst; clear H.
      exists t2...
      exists t3...
    + (* t1 can take a step *)
      inversion H as [t1' H1].
      exists (tif t1' t2 t3)...
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced (finish_progress_informal)  *)
(** Complete the corresponding informal proof: *)

(** _Theorem_: If [|- t \in T], then either [t] is a value or else
    [t ==> t'] for some [t']. *)

(** _Proof_: By induction on a derivation of [|- t \in T].

      - If the last rule in the derivation is [T_If], then [t = if t1
        then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T] and [|- t3
        \in T].  By the IH, either [t1] is a value or else [t1] can step
        to some [t1'].

            - If [t1] is a value, then by the canonical forms lemmas
              and the fact that [|- t1 \in Bool] we have that [t1]
              is a [bvalue] -- i.e., it is either [true] or [false].
              If [t1 = true], then [t] steps to [t2] by [ST_IfTrue],
              while if [t1 = false], then [t] steps to [t3] by
              [ST_IfFalse].  Either way, [t] can step, which is what
              we wanted to show.

            - If [t1] itself can take a step, then, by [ST_If], so can
              [t].

    (* FILL IN HERE *)
[] *)

(** This is more interesting than the strong progress theorem that we
    saw in the Smallstep chapter, where _all_ normal forms were
    values.  Here, a term can be stuck, but only if it is ill
    typed. *)

(** **** Exercise: 1 star (step_review)  *)
(** Quick review.  Answer _true_ or _false_.  In this language...
      - Every well-typed normal form is a value.

      - Every value is a normal form.

      - The single-step evaluation relation is
        a partial function (i.e., it is deterministic).

      - The single-step evaluation relation is a _total_ function.

*)
(** [] *)

(* ###################################################################### *)
(** ** Type Preservation *)

(** The second critical property of typing is that, when a well-typed
    term takes a step, the result is also a well-typed term.

    This theorem is often called the _subject reduction_ property,
    because it tells us what happens when the "subject" of the typing
    relation is reduced.  This terminology comes from thinking of
    typing statements as sentences, where the term is the subject and
    the type is the predicate. *)

Theorem preservation : forall t t' T,
  |- t \in T ->
  t ==> t' ->
  |- t' \in T.

(** **** Exercise: 2 stars (finish_preservation)  *)
(** Complete the formal proof of the [preservation] property.  (Again,
    make sure you understand the informal proof fragment in the
    following exercise first.) *)

Proof with auto.
  intros t t' T HT HE.
  generalize dependent t'.
  induction HT;
         (* every case needs to introduce a couple of things *)
         intros t' HE;
         (* and we can deal with several impossible
            cases all at once *)
         try (solve by inversion).
    - (* T_If *) inversion HE; subst; clear HE.
      + (* ST_IFTrue *) assumption.
      + (* ST_IfFalse *) assumption.
      + (* ST_If *) apply T_If; try assumption.
        apply IHHT1; assumption.
    (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced (finish_preservation_informal)  *)
(** Complete the following proof: *)

(** _Theorem_: If [|- t \in T] and [t ==> t'], then [|- t' \in T]. *)

(** _Proof_: By induction on a derivation of [|- t \in T].

      - If the last rule in the derivation is [T_If], then [t = if t1
        then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T] and [|- t3
        \in T].

        Inspecting the rules for the small-step reduction relation and
        remembering that [t] has the form [if ...], we see that the
        only ones that could have been used to prove [t ==> t'] are
        [ST_IfTrue], [ST_IfFalse], or [ST_If].

           - If the last rule was [ST_IfTrue], then [t' = t2].  But we
             know that [|- t2 \in T], so we are done.

           - If the last rule was [ST_IfFalse], then [t' = t3].  But we
             know that [|- t3 \in T], so we are done.

           - If the last rule was [ST_If], then [t' = if t1' then t2
             else t3], where [t1 ==> t1'].  We know [|- t1 \in Bool] so,
             by the IH, [|- t1' \in Bool].  The [T_If] rule then gives us
             [|- if t1' then t2 else t3 \in T], as required.

    (* FILL IN HERE *)
[] *)

(** **** Exercise: 3 stars (preservation_alternate_proof)  *)
(** Now prove the same property again by induction on the
    _evaluation_ derivation instead of on the typing derivation.
    Begin by carefully reading and thinking about the first few
    lines of the above proof to make sure you understand what
    each one is doing.  The set-up for this proof is similar, but
    not exactly the same. *)

Theorem preservation' : forall t t' T,
  |- t \in T ->
  t ==> t' ->
  |- t' \in T.
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** ** Type Soundness *)

(** Putting progress and preservation together, we can see that a
    well-typed term can _never_ reach a stuck state.  *)

Definition multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

Corollary soundness : forall t t' T,
  |- t \in T ->
  t ==>* t' ->
  ~(stuck t').
Proof.
  intros t t' T HT P. induction P; intros [R S].
  destruct (progress x T HT); auto.
  apply IHP.  apply (preservation x y T HT H).
  unfold stuck. split; auto.   Qed.

(* ###################################################################### *)
(** * Aside: the [normalize] Tactic *)

(** When experimenting with definitions of programming languages in
    Coq, we often want to see what a particular concrete term steps
    to -- i.e., we want to find proofs for goals of the form [t ==>*
    t'], where [t] is a completely concrete term and [t'] is unknown.
    These proofs are simple but repetitive to do by hand. Consider for
    example reducing an arithmetic expression using the small-step
    relation [astep]. *)

Definition amultistep st := multi (astep st).
Notation " t '/' st '==>a*' t' " := (amultistep st t t')
  (at level 40, st at level 39).

Example astep_example1 :
  (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state
  ==>a* (ANum 15).
Proof.
  apply multi_step with (APlus (ANum 3) (ANum 12)).
    apply AS_Plus2.
      apply av_num.
      apply AS_Mult.
  apply multi_step with (ANum 15).
    apply AS_Plus.
  apply multi_refl.
Qed.

(** We repeatedly apply [multi_step] until we get to a normal
    form. The proofs that the intermediate steps are possible are
    simple enough that [auto], with appropriate hints, can solve
    them. *)

Hint Constructors astep aval.
Example astep_example1' :
  (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state
  ==>a* (ANum 15).
Proof.
  eapply multi_step. auto. simpl.
  eapply multi_step. auto. simpl.
  apply multi_refl.
Qed.

(** The following custom [Tactic Notation] definition captures this
    pattern.  In addition, before each [multi_step] we print out the
    current goal, so that the user can follow how the term is being
    evaluated. *)

Tactic Notation "print_goal" := match goal with |- ?x => idtac x end.
Tactic Notation "normalize" :=
   repeat (print_goal; eapply multi_step ;
             [ (eauto 10; fail) | (instantiate; simpl)]);
   apply multi_refl.

Example astep_example1'' :
  (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state
  ==>a* (ANum 15).
Proof.
  normalize.
  (* At this point in the proof script, the Coq response shows
     a trace of how the expression evaluated.

   (APlus (ANum 3) (AMult (ANum 3) (ANum 4)) / empty_state ==>a* ANum 15)
   (multi (astep empty_state) (APlus (ANum 3) (ANum 12)) (ANum 15))
   (multi (astep empty_state) (ANum 15) (ANum 15))
*)
Qed.

(** The [normalize] tactic also provides a simple way to calculate
    what the normal form of a term is, by proving a goal with an
    existential variable in it. *)

Example astep_example1''' : exists e',
  (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state
  ==>a* e'.
Proof.
  eapply ex_intro. normalize.

(* This time, the trace will be:

    (APlus (ANum 3) (AMult (ANum 3) (ANum 4)) / empty_state ==>a* ??)
    (multi (astep empty_state) (APlus (ANum 3) (ANum 12)) ??)
    (multi (astep empty_state) (ANum 15) ??)

   where ?? is the variable ``guessed'' by eapply.
*)
Qed.

(** **** Exercise: 1 star (normalize_ex)  *)
Theorem normalize_ex : exists e',
  (AMult (ANum 3) (AMult (ANum 2) (ANum 1))) / empty_state
  ==>a* e'.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 1 star, optional (normalize_ex')  *)
(** For comparison, prove it using [apply] instead of [eapply]. *)

Theorem normalize_ex' : exists e',
  (AMult (ANum 3) (AMult (ANum 2) (ANum 1))) / empty_state
  ==>a* e'.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** ** Additional Exercises *)

(** **** Exercise: 2 stars, recommended (subject_expansion)  *)
(** Having seen the subject reduction property, it is reasonable to
    wonder whether the opposity property -- subject _expansion_ --
    also holds.  That is, is it always the case that, if [t ==> t']
    and [|- t' \in T], then [|- t \in T]?  If so, prove it.  If
    not, give a counter-example.  (You do not need to prove your
    counter-example in Coq, but feel free to do so if you like.)

    (* FILL IN HERE *)
[] *)

(** **** Exercise: 2 stars (variation1)  *)
(** Suppose, that we add this new rule to the typing relation:
      | T_SuccBool : forall t,
           |- t \in TBool ->
           |- tsucc t \in TBool
   Which of the following properties remain true in the presence of
   this rule?  For each one, write either "remains true" or
   else "becomes false." If a property becomes false, give a
   counterexample.
      - Determinism of [step]

      - Progress

      - Preservation

[] *)

(** **** Exercise: 2 stars (variation2)  *)
(** Suppose, instead, that we add this new rule to the [step] relation:
      | ST_Funny1 : forall t2 t3,
           (tif ttrue t2 t3) ==> t3
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

[] *)

(** **** Exercise: 2 stars, optional (variation3)  *)
(** Suppose instead that we add this rule:
      | ST_Funny2 : forall t1 t2 t2' t3,
           t2 ==> t2' ->
           (tif t1 t2 t3) ==> (tif t1 t2' t3)
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

[] *)

(** **** Exercise: 2 stars, optional (variation4)  *)
(** Suppose instead that we add this rule:
      | ST_Funny3 :
          (tpred tfalse) ==> (tpred (tpred tfalse))
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

[] *)

(** **** Exercise: 2 stars, optional (variation5)  *)
(** Suppose instead that we add this rule:

      | T_Funny4 :
            |- tzero \in TBool
   ]]
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

[] *)

(** **** Exercise: 2 stars, optional (variation6)  *)
(** Suppose instead that we add this rule:

      | T_Funny5 :
            |- tpred tzero \in TBool
   ]]
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

[] *)

(** **** Exercise: 3 stars, optional (more_variations)  *)
(** Make up some exercises of your own along the same lines as
    the ones above.  Try to find ways of selectively breaking
    properties -- i.e., ways of changing the definitions that
    break just one of the properties and leave the others alone.
[] *)

(** **** Exercise: 1 star (remove_predzero)  *)
(** The evaluation rule [E_PredZero] is a bit counter-intuitive: we
    might feel that it makes more sense for the predecessor of zero to
    be undefined, rather than being defined to be zero.  Can we
    achieve this simply by removing the rule from the definition of
    [step]?  Would doing so create any problems elsewhere?

(* FILL IN HERE *)
[] *)

(** **** Exercise: 4 stars, advanced (prog_pres_bigstep)  *)
(** Suppose our evaluation relation is defined in the big-step style.
    What are the appropriate analogs of the progress and preservation
    properties?

(* FILL IN HERE *)
[] *)

(** $Date: 2016-01-24 21:56:22 +0000 (Sun, 24 Jan 2016) $ *)


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

Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> lst .

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) : natural
           := match mult_arg0, mult_arg1 with
              | Zero, n => Zero
              | Succ n, m => plus (mult n m) m
              end.

Fixpoint qmult (qmult_arg0 : natural) (qmult_arg1 : natural) (qmult_arg2 : natural) : natural
           := match qmult_arg0, qmult_arg1, qmult_arg2 with
              | Zero, n, m => m
              | Succ n, m, p => qmult n m (plus p m)
              end.

Lemma plus_succ : forall (x y : natural), plus x (Succ y) = Succ (plus x y).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_assoc : forall (x y z : natural), plus (plus x y) z = plus x (plus y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_zero : forall (x : natural), plus x Zero = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_commut : forall (x y : natural), plus x y = plus y x.
Proof.
   intros.
   induction x.
   - rewrite plus_zero. reflexivity.
   - simpl. rewrite plus_succ. rewrite IHx. reflexivity.
Qed.

Lemma plus_qmult : forall (x y z a : natural), plus (qmult x y z) a = qmult x y (plus z a).
Proof.
   intro.
   induction x.
   - reflexivity.
   - intros. simpl. rewrite IHx. rewrite plus_assoc. rewrite (plus_commut y a).
     rewrite <- plus_assoc. reflexivity.
Qed.

Theorem mult_eq_qmult : forall (x : natural) (y : natural), eq (mult x y) (qmult x y Zero).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. rewrite plus_qmult. reflexivity.
Qed.


Inductive list (X:Type) : Type :=
  | nil
  | cons (x : X) (l : list X).

Arguments nil {X}.
Arguments cons {X}.

Fixpoint app {X : Type} (l1 l2 : list X) : list X :=
  match l1 with
  | nil => l2
  | cons h t => cons h (app t l2)
  end.
Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.
Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

(* exercise *)
Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
    intros X. intros l. induction l as [| n l' IHl'].
    - simpl. reflexivity.
    - simpl. rewrite -> IHl'. reflexivity.
    Qed.

(* exercise *)
Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
    intros A l m n. induction l as [| k l' IHl'].
    - simpl. reflexivity.
    - simpl. rewrite -> IHl'. reflexivity.
    Qed.

(* exercise *)
Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
    intros X l1 l2. induction l1 as [| n l1' IHl1'].
    - simpl. reflexivity.
    - simpl. rewrite -> IHl1'. reflexivity.
    Qed.


Require Export ZArith.
Require Export List.
Require Export Arith.
Require Export ZArithRing.
Require Arith.

Parameters (prime_divisor : nat->nat)
           (prime : nat->Prop)
           (divides : nat->nat->Prop).

(** Tests:

Check prime (prime_divisor 220).

Check divides (prime_divisor 220) 220.

Check divides 3.

*)

Parameter binary_word : nat->Set.

Definition short : Set := binary_word 32.
Definition long : Set := binary_word 64.

(** Tests :

Check ~ divides 3 81.

Check (let d := prime_divisor 220 in prime d /\ divides d 220).

*)

Parameters (decomp : nat -> list nat)
           (decomp2 : nat->nat*nat).

(** Tests :

Check decomp 220.

Check decomp2 284.

Check forall n:nat, 2<=n ->
       prime (prime_divisor n) /\
       divides (prime_divisor n) n.
*)

Parameter
  prime_divisor_correct :
     forall n:nat, 2 <= n ->
       let d := prime_divisor n in prime d /\ divides d n.

Parameter
  binary_word_concat :
     forall n p:nat,
       binary_word n -> binary_word p -> binary_word (n+p).

(* Tests :

Check (forall A B :Set, A->B->A*B).

*)

Definition le_36_37 := le_S 36 36 (le_n 36).

Definition le_36_38 : 36 <= 38 := le_S 36 37 le_36_37.

(** Tests :

Check (le_S _ _ (le_S _ _ (le_n 36))).

Check prime_divisor_correct 220.

*)

Fixpoint iterate (A:Type)(f:A->A)(n:nat)(x:A) : A :=
  match n with
  | O => x
  | S p => f (iterate A f p x)
  end.

(** Tests :
Check iterate nat.

Check iterate  _ (mult 2).

Check (iterate _ (mult 2) 10).

Compute iterate _ (mult 2) 10 1.

Check binary_word_concat 32.

Check binary_word_concat 32 32.
*)

Arguments iterate {A} _ _ _.
Arguments binary_word_concat {n p} _ _.
Arguments le_S {n m} _.

Definition binary_word_duplicate (n:nat)(w:binary_word n)
 : binary_word (n+n) :=
  binary_word_concat  w w.

Definition short_concat : short -> short -> long
                        := @binary_word_concat 32 32.

Theorem le_i_SSi : forall i:nat, i <= S (S i).
Proof (fun i:nat => le_S  (le_S  (le_n i))).

Definition compose {A B C : Type} :  (A->B)->(B->C)->A->C
   := fun f g x => g (f x).

(** Tests :

Check fun (A:Type)(f:Z->A) => compose  Z_of_nat f.

Check compose  Zabs_nat (plus 78) 45%Z.

Check le_i_SSi 1515.

Check le_S  (le_i_SSi 1515).

Check compose (C := Z) S.

Check @le_S 45.

*)

Definition thrice {A:Type} (f:A->A) := compose f (compose f f).

Lemma thrice_as_iter_3 {A:Type} (f: A -> A): thrice f = iterate f 3.
Proof. reflexivity. Qed.

Lemma thrice_thrice {A:Type} (f: A -> A): thrice (thrice f) = iterate f 9.
Proof. reflexivity. Qed.

Definition my_plus : nat->nat->nat := iterate  S.

Definition my_mult (n p:nat) : nat := iterate  (my_plus n) p 0.

Definition my_expt (x n:nat) : nat := iterate (my_mult x) n 1.

Definition ackermann (n:nat) : nat->nat :=
  iterate (fun (f:nat->nat)(p:nat) => iterate  f (S p) 1)
          n
          S.

(** Tests :
Compute my_plus 9 7.

Compute my_expt 2 5.

*)

(** Tests :

Check forall P:Prop, P->P.

Check fun (P:Prop)(p:P) => p.

Check @refl_equal.
*)
(*
Theorem ThirtySix : 9*4=6*6.
Proof (refl_equal 36).
 *)

Definition eq_sym  {A:Type}{x y:A}(h : x=y) : y=x :=
 eq_ind  x (fun z => z=x) (refl_equal x) y h.

(** Tests :
 Check eq_sym  ThirtySix.

Check conj.

Check or_introl.

Check or_intror.

Check and_ind.
*)

Theorem conj3 : forall P Q R:Prop, P->Q->R->P/\Q/\R.
Proof fun P Q R p q r => conj p (conj q r).

Theorem disj4_3 : forall P Q R S:Prop, R -> P\/Q\/R\/S.
Proof
 fun P Q R S r => or_intror _ (or_intror _ (or_introl _ r)).

Definition proj1' :  forall A B:Prop, A/\B->A :=
 fun (A B:Prop)(H:A/\B) => and_ind (fun (H0:A)(_:B) => H0) H.

(** Tests :

Check ex (fun z:Z => (z*z <= 37 /\ 37 < (z+1)*(z+1))%Z).

Check ex_intro.

Check ex_ind.

Check and.

*)


Theorem thm2 :
  forall A B C : Prop,
    (A \/ B) ->
    (B -> C) ->
    (A -> ~C) ->
    ~C ->
    A.
(*

前提

  A:嬰児は精霊である。
  B;嬰児は人間である。
  C:嬰児は村に帰ってくる。

  A \/ B:嬰児は精霊か人間のいずれかである。
  B -> C:嬰児が人間ならば、嬰児は村に帰ってくる。
  A -> ~C:嬰児が精霊ならば、嬰児は村に帰ってこない。
  ~C:嬰児は村に帰ってこなかった。

結論

  A:嬰児は精霊だった。

*)
Proof.
  intros A B C AorB_is_true BtoC_is_true AtoNotC_is_true NotC_is_true.
  inversion AorB_is_true; subst; clear AorB_is_true.
  - (* Aが成り立つ場合 *)
    apply H.
  - (* Bが成り立つ場合 *)
    apply BtoC_is_true in H.
    unfold not in NotC_is_true.
    apply NotC_is_true in H.
    exfalso.
    apply H.
Qed.

From mathcomp
Require Import ssreflect.

Theorem thm2_ssr :
  forall A B C : Prop,
    (A \/ B) ->
    (B -> C) ->
    (A -> ~C) ->
    ~C ->
    A.
Proof.
  move=> A B C AorB_is_true BtoC_is_true AtoNotC_is_true NotC_is_true.
  inversion AorB_is_true; subst; clear AorB_is_true.
  -
    done.
  -
    move: (BtoC_is_true H) => C_is_true.
    move: NotC_is_true.
    rewrite /not => CtoFalse_is_true.
    move: (CtoFalse_is_true C_is_true) => Hypothesis_is_False.
    done.
Qed.


(********************************************************************)
(*                                                                  *)
(*  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 BuiltIn.
Require int.Int.

(* Why3 comment *)
(* abs is replaced with (ZArith.BinInt.Z.abs x) by the coq driver *)

(* Why3 goal *)
Lemma abs_def :
forall (x:Z),
 ((0%Z <= x)%Z -> ((ZArith.BinInt.Z.abs x) = x))
 /\ ((~ (0%Z <= x)%Z) -> ((ZArith.BinInt.Z.abs x) = (-x)%Z)).
intros x.
split ; intros H.
now apply Zabs_eq.
apply Zabs_non_eq.
apply Znot_gt_le.
contradict H.
apply Zlt_le_weak.
now apply Zgt_lt.
Qed.

(* Why3 goal *)
Lemma Abs_le :
forall (x:Z) (y:Z),
 ((ZArith.BinInt.Z.abs x) <= y)%Z <-> (((-y)%Z <= x)%Z /\ (x <= y)%Z).
intros x y.
zify.
omega.
Qed.

(* Why3 goal *)
Lemma Abs_pos :
forall (x:Z), (0%Z <= (ZArith.BinInt.Z.abs x))%Z.
exact Zabs_pos.
Qed.


(**
    The "classical" definition of well-foundedness

  Pierre Casteran

 keywords :  well-founded relations, classical logic, axiom of choice

 *)

Require Import Relations.

(**
  Please consider the usual mathematical definition of well-founded relations :
 *)

Definition classic_wf {A}(R: relation A) :=
  ~ exists (s: nat-> A),  forall i,  R (s (S i)) (s i).

(** Prove that Coq's  definition entails the classical one *)

Theorem wf_classic_wf {A} (R: relation A) : well_founded R -> classic_wf R.
Proof.
  intros HR  [s Hs].
  assert (forall x:A,  ~ exists i,  s i = x).
  {
    apply (well_founded_induction  HR).
    intros x Hx [i Hi].
    subst x;  specialize (Hs i).
    specialize (Hx _ Hs).
    apply Hx ; now exists (S i).
  }
  apply (H (s 0));  now exists 0.
Qed.

(** Now, we work with some axioms (assumed in the following libraries) *)

Require Import Classical ClassicalChoice.

(** In the current context, prove that the classical definition entails Coq's *)

Section Classic_OK_R.
  Variable (A:Type)(R: relation A).

  Hypothesis H : classic_wf R.

  Section Proof_by_absurd.

    Hypothesis (H0: ~ well_founded R).

    Lemma not_acc_ex : exists a:A,  ~ Acc R a.
    Proof.
      now apply not_all_ex_not.
    Qed.

    Lemma next_not_acc : forall a,  ~ Acc R a ->
                                    exists b,  R b a /\ ~ Acc R b.
    Proof.
      intros a H1;  apply not_all_not_ex.
      intros H2; apply H1.
      split; intros y H3.
      specialize (H2 y); apply not_and_or in H2.
      destruct H2;auto.
      -  contradiction.
      -  now apply NNPP in H2.
    Qed.

    (* In order to apply choice, we use an auxiliary sig type *)

    Let B : Type := {a : A | ~ Acc R a}.

    Let R1 : relation B :=
      fun x y => R (proj1_sig y) (proj1_sig x).

    Lemma next_not_acc_R1 : forall x:B, exists y:B, R1 x y.
    Proof.
      destruct x as [a Ha].
      destruct (next_not_acc a Ha) as [y [Hy Hy1]].
      now exists (exist _ y Hy1).
    Qed.

    Fixpoint iterate {B} (f : B -> B) b n : B :=
      match n with 0 => b | S p => f (iterate f b p) end.

    Lemma L : exists f: nat -> B, forall i, R1 (f i) (f (S i)).
    Proof.
      destruct not_acc_ex as [x H1].
      destruct (choice _ next_not_acc_R1) as [h H2].
      exists (iterate h (exist _ x H1)).
      induction i; simpl; auto.
    Qed.

    Lemma L2: exists g : nat -> A, forall i, R (g (S i)) (g i).
    Proof.
      destruct L as [f Hf].
      exists (fun i =>  proj1_sig (f i)).
      intro; apply Hf.
    Qed.

    Lemma FF : False.
    Proof.
      apply H, L2.
    Qed.

  End Proof_by_absurd.

End Classic_OK_R.

Theorem classic_wf_wf  {A} (R: relation A) : classic_wf R -> well_founded R.
Proof.
  intros; apply NNPP.
  intro; now apply (FF _ R).
Qed.

Arguments classic_wf_wf {A}.

Print Assumptions classic_wf_wf.

(*

Axioms:
relational_choice : forall (A B : Type) (R : A -> B -> Prop),
                    (forall x : A, exists y : B, R x y) ->
                    exists R' : A -> B -> Prop, subrelation R' R /\ (forall x : A, exists ! y : B, R' x y)
dependent_unique_choice : forall (A : Type) (B : A -> Type) (R : forall x : A, B x -> Prop),
                          (forall x : A, exists ! y : B x, R x y) ->
                          exists f : forall x : A, B x, forall x : A, R x (f x)
classic : forall P : Prop, P \/ ~ P

*)

Print Assumptions wf_classic_wf.

(*

Closed under the global context
*)


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


Require Import init.

Require Export relation.
Require Import list_base.

Declare Scope set_scope.
Delimit Scope set_scope with set.

(* begin hide *)
Open Scope set_scope.
(* end hide *)

Definition subset {U : Type} (S T : U → Prop) := ∀ x, S x → T x.
Infix "⊆" := subset.
Infix "⊂" := (strict subset) (at level 50, no associativity).

Definition empty {U : Type} := λ x : U, False.
Definition all {U : Type} := λ x : U, True.
Notation "∅" := empty.

(** This is used for purely notational purposes and should never be used
directly. *)
Fixpoint list_to_set {U} l (a : U) :=
    match l with
    | list_end => False (* Not actually ever used *)
    | list_add x list_end => x = a
    | list_add x l' => x = a ∨ list_to_set l' a
    end.
Arguments list_to_set : simpl never.
(** Note that is not curly brackets!  That gets Coq confused with notations
like {A} + {B}.  Instead, these are U+2774 and U+2775, MEDIUM LEFT/RIGHT CURLY
BRACKET ORNAMENT *)
Notation "❴ x , .. , y ❵"
    := (list_to_set (list_add x .. (list_add y list_end) ..)).

Definition union {U : Type} (S T : U → Prop) := λ x, S x ∨ T x.
Infix "∪" := union.
Definition intersection {U : Type} (S T : U → Prop) := λ x, S x ∧ T x.
Infix "∩" := intersection.
Definition set_minus {U : Type} (S T : U → Prop) := λ x, S x ∧ ¬T x.
Infix "-" := set_minus : set_scope.
Definition symmetric_difference {U : Type} (S T : U → Prop) := (S-T) ∪ (T-S).
Infix "+" := symmetric_difference : set_scope.
(** This is "\\mathbf C" *)
Definition 𝐂 {U : Type} (S : U → Prop) := λ x, ¬S x.

Definition cartesian_product {U V : Type} (S : U → Prop) (T : V → Prop) :=
    λ (x : U * V), S (fst x) ∧ T (snd x).
Infix "*" := cartesian_product : set_scope.

Definition disjoint {U : Type} (S T : U → Prop) := S ∩ T = ∅.
Definition intersects {U : Type} (S T : U → Prop) := S ∩ T ≠ ∅.

(* begin hide *)
Section SetBase.

Context {U : Type}.

Theorem singleton_eq : ∀ a b : U, ❴a❵ b ↔ a = b.
Proof.
    reflexivity.
Qed.

Theorem pair_union : ∀ a b : U, ❴a, b❵ = ❴a❵ ∪ ❴b❵.
Proof.
    reflexivity.
Qed.

(* end hide *)
Global Instance subset_refl : Reflexive (subset (U := U)).
Proof.
    split.
    intros S x Sx.
    exact Sx.
Qed.

Global Instance subset_trans : Transitive (subset (U := U)).
Proof.
    split.
    intros R S T RS ST x Rx.
    apply ST.
    apply RS.
    exact Rx.
Qed.

Global Instance subset_antisym : Antisymmetric (subset (U := U)).
Proof.
    split.
    intros S T ST TS.
    apply predicate_ext; intro x.
    split.
    -   apply ST.
    -   apply TS.
Qed.

Theorem strict_subset_ex : ∀ (S T : U → Prop), S ⊂ T → ∃ x, ¬S x ∧ T x.
Proof.
    intros S T sub.
    classic_contradiction contr.
    apply sub.
    apply antisym; [>apply sub|].
    intros x Tx.
    rewrite not_ex in contr.
    specialize (contr x).
    rewrite and_comm, not_and_impl, not_not in contr.
    exact (contr Tx).
Qed.

Theorem empty_sub : ∀ S : U → Prop, ∅ ⊆ S.
Proof.
    intros S x contr.
    contradiction contr.
Qed.
Theorem all_sub : ∀ S : U → Prop, S ⊆ all.
Proof.
    intros S x Sx.
    exact true.
Qed.

Theorem empty_eq : ∀ S : U → Prop, S = ∅ ↔ (∀ x, ¬S x).
Proof.
    intros S.
    split.
    -   intros eq x Sx.
        rewrite eq in Sx.
        contradiction Sx.
    -   intros all_not.
        apply antisym.
        +   intros x Sx.
            exact (all_not x Sx).
        +   apply empty_sub.
Qed.

Theorem empty_neq : ∀ S : U → Prop, S ≠ ∅ ↔ (∃ x, S x).
Proof.
    intros S.
    apply not_eq_iff.
    rewrite not_not, not_ex.
    apply empty_eq.
Qed.

Theorem all_eq : ∀ S : U → Prop, S = all ↔ (∀ x, S x).
Proof.
    intros S.
    split.
    -   intros eq x.
        rewrite eq.
        exact true.
    -   intros all_in.
        apply antisym.
        +   apply all_sub.
        +   intros x Sx.
            apply all_in.
Qed.

Theorem all_neq : ∀ S : U → Prop, S ≠ all ↔ (∃ x, ¬S x).
Proof.
    intros S.
    rewrite <- not_all.
    rewrite <- not_eq_iff.
    apply all_eq.
Qed.

Theorem not_in_empty : ∀ x : U, ¬∅ x.
Proof.
    intros x contr.
    contradiction contr.
Qed.

Theorem union_comm : ∀ S T : U → Prop, S ∪ T = T ∪ S.
Proof.
    intros S T.
    apply predicate_ext; intros x.
    apply or_comm.
Qed.

Theorem union_assoc : ∀ R S T : U → Prop, R ∪ (S ∪ T) = (R ∪ S) ∪ T.
Proof.
    intros R S T.
    apply predicate_ext; intros x.
    apply or_assoc.
Qed.

Theorem union_lid : ∀ S : U → Prop, ∅ ∪ S = S.
Proof.
    intros S.
    apply predicate_ext; intros x.
    apply or_lfalse.
Qed.
Theorem union_rid : ∀ S : U → Prop, S ∪ ∅ = S.
Proof.
    intros S.
    rewrite union_comm.
    apply union_lid.
Qed.

Theorem union_lanni : ∀ S : U → Prop, all ∪ S = all.
Proof.
    intros S.
    apply predicate_ext; intros x.
    apply or_ltrue.
Qed.
Theorem union_ranni : ∀ S : U → Prop, S ∪ all = all.
Proof.
    intros S.
    rewrite union_comm.
    apply union_lanni.
Qed.

Theorem union_lsub : ∀ S T : U → Prop, S ⊆ S ∪ T.
Proof.
    intros S T x Sx.
    left; exact Sx.
Qed.
Theorem union_rsub : ∀ S T : U → Prop, T ⊆ S ∪ T.
Proof.
    intros S T.
    rewrite union_comm.
    apply union_lsub.
Qed.

Theorem union_compl_all : ∀ S : U → Prop, S ∪ 𝐂 S = all.
Proof.
    intros S.
    apply all_eq.
    intros x.
    apply em.
Qed.

Theorem union_idemp : ∀ S : U → Prop, S ∪ S = S.
Proof.
    intros S.
    apply predicate_ext; intros x.
    apply or_idemp.
Qed.

Lemma union_minus : ∀ A B : U → Prop, A ∩ B = ∅ → A ∪ B - B = A.
Proof.
    intros A B dis.
    apply antisym.
    -   intros x [[Ax|Bx] nBx].
        +   exact Ax.
        +   contradiction.
    -   intros x Ax.
        split; [>left; exact Ax|].
        intros contr.
        rewrite empty_eq in dis.
        exact (dis x (make_and Ax contr)).
Qed.

Theorem inter_comm : ∀ S T : U → Prop, S ∩ T = T ∩ S.
Proof.
    intros S T.
    apply predicate_ext; intros x.
    apply and_comm.
Qed.

Theorem inter_assoc : ∀ R S T : U → Prop, R ∩ (S ∩ T) = (R ∩ S) ∩ T.
Proof.
    intros R S T.
    apply predicate_ext; intros x.
    apply and_assoc.
Qed.

Theorem inter_lid : ∀ S : U → Prop, all ∩ S = S.
Proof.
    intros S.
    apply predicate_ext; intros x.
    apply and_ltrue.
Qed.
Theorem inter_rid : ∀ S : U → Prop, S ∩ all = S.
Proof.
    intros S.
    rewrite inter_comm.
    apply inter_lid.
Qed.

Theorem inter_lanni : ∀ S : U → Prop, ∅ ∩ S = ∅.
Proof.
    intros S.
    apply predicate_ext; intros x.
    apply and_lfalse.
Qed.
Theorem inter_ranni : ∀ S : U → Prop, S ∩ ∅ = ∅.
Proof.
    intros S.
    rewrite inter_comm.
    apply inter_lanni.
Qed.

Theorem inter_lsub : ∀ S T : U → Prop, S ∩ T ⊆ S.
Proof.
    intros S T x [Sx Tx].
    exact Sx.
Qed.
Theorem inter_rsub : ∀ S T : U → Prop, S ∩ T ⊆ T.
Proof.
    intros S T.
    rewrite inter_comm.
    apply inter_lsub.
Qed.

Theorem lsub_inter_equal : ∀ S T : U → Prop, S ⊆ T → S ∩ T = S.
Proof.
    intros S T sub.
    apply antisym.
    -   intros x [Sx Tx].
        exact Sx.
    -   intros x Sx.
        split.
        +   exact Sx.
        +   exact (sub x Sx).
Qed.

Theorem rsub_inter_equal : ∀ S T : U → Prop, T ⊆ S → S ∩ T = T.
Proof.
    intros S T sub.
    rewrite inter_comm.
    apply lsub_inter_equal.
    exact sub.
Qed.

Theorem inter_compl_empty : ∀ S : U → Prop, S ∩ 𝐂 S = ∅.
Proof.
    intros S.
    apply empty_eq.
    intros x [Sx nSx].
    contradiction.
Qed.

Theorem inter_idemp : ∀ S : U → Prop, S ∩ S = S.
Proof.
    intros S.
    apply predicate_ext; intros x.
    apply and_idemp.
Qed.

Theorem union_ldist : ∀ R S T : U → Prop, R ∪ (S ∩ T) = (R ∪ S) ∩ (R ∪ T).
Proof.
    intros R S T.
    apply predicate_ext; intros x.
    apply or_and_ldist.
Qed.
Theorem union_rdist : ∀ R S T : U → Prop, (R ∩ S) ∪ T = (R ∪ T) ∩ (S ∪ T).
Proof.
    intros R S T.
    apply predicate_ext; intros x.
    apply or_and_rdist.
Qed.
Theorem inter_ldist : ∀ R S T : U → Prop, R ∩ (S ∪ T) = (R ∩ S) ∪ (R ∩ T).
Proof.
    intros R S T.
    apply predicate_ext; intros x.
    apply and_or_ldist.
Qed.
Theorem inter_rdist : ∀ R S T : U → Prop, (R ∪ S) ∩ T = (R ∩ T) ∪ (S ∩ T).
Proof.
    intros R S T.
    apply predicate_ext; intros x.
    apply and_or_rdist.
Qed.

Theorem union_inter_self : ∀ A B : U → Prop, A ∪ (A ∩ B) = A.
Proof.
    intros A B.
    apply antisym.
    -   intros x [Ax|[Ax Bx]]; exact Ax.
    -   intros x Ax.
        left; exact Ax.
Qed.
Theorem inter_union_self : ∀ A B : U → Prop, A ∩ (A ∪ B) = A.
Proof.
    intros A B.
    apply antisym.
    -   intros x [Ax Bx]; exact Ax.
    -   intros x Ax.
        split; [>|left]; exact Ax.
Qed.

Theorem compl_compl : ∀ A : U → Prop, 𝐂 (𝐂 A) = A.
Proof.
    intros A.
    apply predicate_ext; intros x.
    unfold 𝐂.
    apply not_not.
Qed.

Theorem compl_empty : @𝐂 U ∅ = all.
Proof.
    apply predicate_ext; intros x.
    unfold 𝐂, empty.
    rewrite not_false.
    reflexivity.
Qed.

Theorem compl_all : @𝐂 U all = ∅.
Proof.
    apply predicate_ext; intros x.
    unfold 𝐂, all.
    rewrite not_true.
    reflexivity.
Qed.

Theorem union_compl : ∀ A B : U → Prop,
    𝐂 (A ∪ B) = 𝐂 A ∩ 𝐂 B.
Proof.
    intros A B.
    apply predicate_ext; intros x.
    apply not_or.
Qed.

Theorem inter_compl : ∀ A B : U → Prop,
    𝐂 (A ∩ B) = 𝐂 A ∪ 𝐂 B.
Proof.
    intros A B.
    apply predicate_ext; intros x.
    apply not_and.
Qed.

Theorem compl_eq : ∀ A B : U → Prop, 𝐂 A = 𝐂 B → A = B.
Proof.
    intros A B eq.
    apply predicate_ext; intros x.
    pose proof (func_eq _ _ eq x) as eq2.
    apply not_eq_eq in eq2.
    rewrite eq2.
    reflexivity.
Qed.

Theorem set_minus_formula : ∀ S T : U → Prop, S - T = S ∩ 𝐂 T.
Proof.
    reflexivity.
Qed.

Theorem set_minus_rempty : ∀ S : U → Prop, S - ∅ = S.
Proof.
    intros S.
    rewrite set_minus_formula.
    rewrite compl_empty.
    apply inter_rid.
Qed.

Theorem set_minus_lempty : ∀ S : U → Prop, ∅ - S = ∅.
Proof.
    intros S.
    rewrite set_minus_formula.
    apply inter_lanni.
Qed.

Theorem set_minus_inv : ∀ S : U → Prop, S - S = ∅.
Proof.
    intros S.
    rewrite set_minus_formula.
    apply inter_compl_empty.
Qed.

Theorem set_minus_twice : ∀ S T : U → Prop, S - T - T = S - T.
Proof.
    intros S T.
    do 2 rewrite set_minus_formula.
    rewrite <- inter_assoc.
    rewrite inter_idemp.
    reflexivity.
Qed.

Theorem symdif_formula : ∀ S T : U → Prop, S + T = (S ∪ T) - (S ∩ T).
Proof.
    intros S T.
    unfold symmetric_difference.
    do 3 rewrite set_minus_formula.
    rewrite inter_compl.
    rewrite union_ldist.
    do 2 rewrite union_rdist.
    rewrite (union_comm (𝐂 T)).
    do 2 rewrite union_compl_all.
    rewrite inter_lid.
    rewrite inter_rid.
    apply f_equal.
    apply union_comm.
Qed.

Theorem symdif_comm : ∀ S T : U → Prop, S + T = T + S.
Proof.
    intros S T.
    unfold symmetric_difference.
    apply union_comm.
Qed.

Theorem symdif_assoc : ∀ R S T : U → Prop, R + (S + T) = (R + S) + T.
Proof.
    intros R S T.
    rewrite (symdif_comm R S).
    rewrite (symdif_comm (S + R) T).
    rewrite symdif_formula.
    unfold symmetric_difference at 2.
    rewrite (symdif_formula S T).
    rewrite (symdif_formula T).
    unfold symmetric_difference at 2.
    rewrite (symdif_formula S R).
    do 8 rewrite set_minus_formula.
    do 4 rewrite inter_compl.
    do 2 rewrite union_compl.
    do 4 rewrite inter_compl.
    do 3 rewrite compl_compl.
    do 4 rewrite union_ldist.
    assert (∀ X Y Z : U → Prop, X ∪ (Y ∪ Z) = Z ∪ (Y ∪ X)) as lemma.
    {
        intros X Y Z.
        rewrite union_comm.
        rewrite union_assoc.
        rewrite (union_comm Y).
        reflexivity.
    }
    do 2 rewrite (lemma R).
    rewrite (lemma (𝐂 R)).
    do 2 rewrite (union_assoc _ _ S).
    rewrite (union_comm (𝐂 R) (𝐂 T)).
    do 2 rewrite <- inter_assoc.
    apply f_equal.
    do 2 rewrite inter_assoc.
    apply f_equal2; [>|reflexivity].
    apply inter_comm.
Qed.

Theorem symdif_lid : ∀ S : U → Prop, ∅ + S = S.
Proof.
    intros S.
    unfold symmetric_difference.
    rewrite set_minus_rempty.
    rewrite set_minus_lempty.
    apply union_lid.
Qed.
Theorem symdif_rid : ∀ S : U → Prop, S + ∅ = S.
Proof.
    intros S.
    rewrite symdif_comm.
    apply symdif_lid.
Qed.

Theorem symdif_inv : ∀ S : U → Prop, S + S = ∅.
Proof.
    intros S.
    unfold symmetric_difference.
    rewrite set_minus_inv.
    apply union_lid.
Qed.

Context {V : Type}.

Theorem cartesian_product_sub : ∀ (A B : U → Prop) (C D : V → Prop),
    A ⊆ B → C ⊆ D → A * C ⊆ B * D.
Proof.
    intros A B C D AB CD.
    intros x [Ax Cx].
    apply AB in Ax.
    apply CD in Cx.
    split; assumption.
Qed.

Theorem cartesian_product_inter : ∀ (A B : U → Prop) (C D : V → Prop),
    (A ∩ B) * (C ∩ D) = (A * C) ∩ (B * D).
Proof.
    intros A B C D.
    apply predicate_ext.
    intros [a b].
    unfold intersection, cartesian_product; cbn.
    do 2 rewrite and_assoc.
    do 4 rewrite <- (and_assoc (A a)).
    rewrite (and_comm (B a) (C b)).
    reflexivity.
Qed.
(* begin hide *)

End SetBase.

Close Scope set_scope.
(* end hide *)


(** Common definitions *)
From Coq Require Import Ensembles.
From RelationAlgebra Require Import prop monoid kat relalg kat_tac.
From Catincoq.lib Require Import proprel.

Definition partial_order {A} (R : relation A) := 1 ≦ R /\ R ⋅ R ≦ R /\ R ⊓ R° ≦ 1.

Definition strict_order {A} (R : relation A) := R ⋅ R ≦ R /\ R ⊓ 1 ≦ 0.

Definition is_strict_order {A} (R : relation A) :=
  relalg.is_irreflexive R /\
  is_transitive R.

Lemma is_strict_order_spec {A} (R : relation A) : is_strict_order R <-> strict_order R.
Proof.
  compute. firstorder.
Qed.

Definition is_irreflexive {X} (R : relation X) := R ⊓ 1 ≦ 0.

Definition irreflexive {A} (R : relation A) := cap R 1 ≦ bot.

Lemma is_irreflexive_spec1 {X} (R : relation X) : irreflexive R <-> is_irreflexive R.
Proof.
  reflexivity.
Qed.

Lemma is_irreflexive_spec2 {X} (R : relation X) : relalg.is_irreflexive R <-> is_irreflexive R.
Proof.
  compute. firstorder (subst; firstorder).
Qed.

Lemma is_irreflexive_spec3 {X} (R : relation X) : RelationClasses.Irreflexive R <-> is_irreflexive R.
Proof.
  compute. firstorder (subst; firstorder).
Qed.

Definition acyclic {A} (R : relation A) := leq (cap (itr _ R) 1) bot.

Definition is_acyclic {X} (R : relation X) := R^+ ⊓ 1 ≦ 0.

Lemma is_acyclic_spec {X} (R : relation X) : acyclic R <-> is_acyclic R.
Proof.
  split; intros A x y; specialize (A x y); rewrite A; compute; tauto.
Qed.

Definition total {A} (R : relation A) := !1 ≦ R ⊔ R°.

(** TODO merge those two *)
Definition total_on {A} (E : set A) (R : relation A) := [E] ⋅ !1 ⋅ [E] ≦ R ⊔ R°.

Definition linear_extension_on {A} (E : set A) (R : relation A) : set (relation A) :=
  fun S => strict_order S /\ S ≦ [E] ⋅ top ⋅ [E] /\ total_on E S /\ [E] ⋅ R ⋅ [E] ≦ S.

Definition finite_set {A} (E : set A) :=
  exists (l : list A), forall a, E a -> List.In a l.

Definition relational_image {A B} (R : A -> B -> Prop) : Ensemble A -> Ensemble B :=
  fun x b => exists a, x a /\ R a b.

Definition functional_relation_domain {A B} (dom : Ensemble A) (R : A -> B -> Prop) :=
  (forall a, dom a <-> exists b, R a b) /\
  (forall a b b', R a b -> R a b' -> b = b').

Definition one_of_each {X} : Ensemble (Ensemble X) -> Ensemble (Ensemble X) :=
  fun A b => exists f : Ensemble X -> X -> Prop,
      (forall e fe, f e fe -> e fe) /\
      functional_relation_domain A f /\
      Same_set _ b (relational_image f A).

Definition subset_image {A B} (f : A -> B) (X : Ensemble A) : Ensemble B
  := fun y => exists x, X x /\ y = f x.

Definition union_of_relations {A} : Ensemble (relation A) -> relation A :=
  fun Rs x y => exists R, Rs R /\ R x y.

Definition equivalence_classes {A} (R : relation A) : Ensemble (Ensemble A) :=
  fun C => exists x, C x /\ forall y, R x y <-> C y.


From Coq Require Import List.

Import ListNotations.
Local Open Scope list_scope.
Open Scope type_scope.

Section PERM.

  Context {A : Type}.

(** Steve's version *)

Inductive Permutation  : list A -> list A -> Type :=
| perm_id: forall l, Permutation l l
| perm_swap x y l : Permutation ([y] ++ [x] ++ l) ([x] ++ [y] ++ l)
| perm_comp l1 l2 l3 :
    Permutation l1 l2 -> Permutation l2 l3 -> Permutation l1 l3
| perm_plus l11 l12 l21 l22 :
  Permutation l11 l21 -> Permutation l12 l22 -> Permutation (l11 ++ l12) (l21 ++ l22).

Lemma PermutationSymmetric : forall (xs ys: list A),
    Permutation xs ys -> Permutation ys xs.
Proof.
  intros.
  induction X.
  - apply perm_id.
  - apply perm_swap.
  - eapply perm_comp; eauto.
  - apply perm_plus; eauto.
Qed.

(** Thorsten's Version *)

Inductive Add : A -> list A -> list A -> Type :=
| zero : forall a aS, Add a aS (a :: aS)
| succ : forall a b aS bs, Add a aS bs -> Add a (b :: aS) (b :: bs).

Arguments zero {_ _}.
Arguments succ {_ _ _ _}.

Inductive Perm : list A -> list A -> Type :=
| perm_nil  : Perm [] []
| perm_cons : forall a aS bs cs, Perm aS cs -> Add a cs bs -> Perm (a :: aS) bs.

Arguments perm_cons {_ _ _ _}.

Fixpoint reflPerm (xs:list A) : Perm xs xs :=
  match xs with
  | [] => perm_nil
  | x::xs => perm_cons (reflPerm xs) zero
  end.

Lemma addLem : forall {a b aS bs cs} (P : Add a aS bs) (Q : Add b bs cs),
    {ds : list A & Add b aS ds * (Add a ds cs)}.
Proof.
  intros.
  revert b cs Q.
  induction P; intros.
  - inversion Q; subst.
    + exists (b :: aS). split.  apply zero. apply succ. apply zero.
    + eexists. split. apply X. apply zero.
  - inversion Q; subst.
    + eexists. split. apply zero. apply succ. apply succ. apply P.
    + specialize (IHP b0 bs0 X).
      destruct IHP as [ds [HP HQ]].
      eexists (b::ds). split. eapply succ. assumption. eapply succ. assumption.
Qed.

Lemma transLem : forall {a bs cs bs'} (P : Perm bs cs) (H : Add a bs' bs),
    { cs' : list A & Perm bs' cs' * Add a cs' cs}.
Proof.
  intros.
  revert a bs' H.
  induction P; intros.
  - inversion H.
  - remember (a :: aS) as xs.
    revert a aS P a0 IHP Heqxs.
    inversion H; intros; inversion Heqxs; subst; clear Heqxs.
    + exists cs. split; auto.
    + destruct (IHP _ _ X) as [cs' [P' Q']].
      destruct (addLem Q' a2) as [ds [Y Z]].
      exists ds. split. eapply perm_cons; eauto. apply Z.
Qed.

Lemma transPerm : forall {aS bs cs} (P : Perm aS bs) (Q : Perm bs cs),
    Perm aS cs.
Proof.
  intros aS bs cs P Q.
  revert cs Q.
  induction P; intros.
  - assumption.
  - destruct (transLem Q a0) as [cs' [Q' Y]].
    apply (perm_cons (IHP cs' Q')).
    assumption.
Qed.

Lemma symLem : forall {a aS bs cs} (P: Perm cs aS) (X : Add a cs bs),
    Perm bs (a :: aS).
Proof.
  intros a aS bs cs P X.
  revert aS P.
  induction X; intros.
  - eapply perm_cons. apply P. apply zero.
  - inversion P; subst.
    eapply perm_cons.
    apply (IHX _ X0). apply succ. assumption.
Qed.

Lemma symPerm : forall {aS bs} (P : Perm aS bs),
    Perm bs aS.
Proof.
  intros.
  induction P.
  - apply perm_nil.
  - eapply symLem. apply IHP. assumption.
Qed.

Lemma remPerm : forall {a aS bs} (P : Perm (a::aS) (a::bs)),
    Perm aS bs.
Proof.
  intros.
  inversion P; subst.
  inversion X0; subst.
  - assumption.
  - eapply transPerm. apply X.
    eapply perm_cons. apply reflPerm.
    assumption.
Qed.

Lemma swapPerm : forall {a b aS}, (Perm (a::b::aS) (b::a::aS)).
Proof.
  intros.
  eapply perm_cons.
  2: { eapply succ. eapply zero. }
  apply reflPerm.
Qed.

Lemma appendAdd : forall a aS bs cs,
    Add a aS bs -> Add a (aS ++ cs) (bs ++ cs).
Proof.
  intros a aS bs cs H.
  revert cs.
  induction H; intros.
  - apply zero.
  - simpl. apply succ. apply IHAdd.
Qed.

Lemma appendPerm : forall aS bs cs ds,
    Perm aS bs -> Perm cs ds -> Perm (aS++cs) (bs++ds).
Proof.
  intros aS bs cs ds H.
  revert cs ds.
  induction H; intros.
  - simpl. assumption.
  - simpl. eapply perm_cons.
    apply IHPerm. apply X.
    apply appendAdd.
    assumption.
Qed.

Lemma Permutation_Perm : forall xs ys, Permutation xs ys -> Perm xs ys.
Proof.
  intros.
  induction X.
  - apply reflPerm.
  - apply swapPerm.
  - eapply transPerm. apply IHX1. apply IHX2.
  - apply appendPerm; auto.
Qed.

Lemma Permutation_AddLem : forall a cs bs,
    Add a cs bs -> Permutation (a::cs) bs.
Proof.
  intros.
  induction X.
  - apply perm_id.
  - eapply perm_comp.
    eapply perm_swap.
    replace (b :: bs) with ([b] ++ bs) by reflexivity.
    apply perm_plus. apply perm_id.
    apply IHX.
Qed.

Lemma Permutation_Add : forall a aS bs cs,
    Permutation aS cs -> Add a cs bs -> Permutation (a :: aS) bs.
Proof.
  intros.
  revert a bs X0.
  induction X; intros.
  - apply Permutation_AddLem. assumption.
  - apply Permutation_AddLem in X0.
    replace (a :: [y] ++ [x] ++ l) with ([a] ++ (y::x::l)) by reflexivity.
    eapply perm_comp. eapply perm_plus. apply perm_id.
    eapply perm_swap. assumption.
  - apply IHX2 in X0.
    eapply perm_comp. eapply PermutationSymmetric.
    replace (a :: l1) with ([a] ++ l1) by reflexivity.
    apply perm_plus. apply perm_id.
    apply PermutationSymmetric. apply X1.
    apply X0.
  - apply Permutation_AddLem in X0.
    eapply perm_comp.
    2: { apply X0. }
    replace (a :: l11 ++ l12) with ([a] ++ (l11 ++ l12)) by reflexivity.
    replace (a :: l21 ++ l22) with ([a] ++ (l21 ++ l22)) by reflexivity.
    apply perm_plus. apply perm_id.
    apply perm_plus; assumption.
Qed.

Lemma Perm_Permutation : forall aS bs,
    Perm aS bs -> Permutation aS bs.
Proof.
  intros.
  induction X.
  - apply perm_id.
  - eapply Permutation_Add; eauto.
Qed.

End PERM.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** Properties of arbitrary binary relations (not necessarily decidable) *)
(** A functional or deterministic relation *)
Definition functional {X : Type} (R : X -> X -> Prop) : Prop :=
  forall (s s1 s2 : X), R s s1 -> R s s2 -> s1 = s2.

Lemma func1 :
  functional (fun x y => x.*2 == y).
Admitted.

Lemma func2 :
  ~ functional (fun x y => (x.*2 == y) || ((x, y) == (0,1))).
Admitted.

(** Define a notation such that {In C, functional R} restricts the domain of the relation like so:

  forall (s s1 s2 : X), C s -> R s s1 -> R s s2 -> s1 = s2

And prove the following lemma:
*)
(* Notation "{ 'In' C , P }" := *)
(*   (...) (at level 0). *)

Lemma func3 :
  {In (fun n => 0 < n), functional (fun x y => (x.*2 == y) || ((x, y) == (0,1)))}.
Admitted.

(* prove without using [case] or [elim] tactics *)
Lemma Peirce p q : ((p ==> q) ==> p) ==> p.
Admitted.

(* prove without using [case] or [elim] tactics *)
Lemma addb_neq12 p q :  ~~ p = q -> p (+) q.
Admitted.

Lemma div_fact_plus1 m p : 1 < p -> p %| m `! + 1 -> m < p.
Admitted.

(* Prove [8x = 6y + 1] has no solutions in [nat] *)
Lemma no_solution x y :
  8*x != 6*y + 1.
Admitted.

Lemma iota_add m n1 n2 :
  iota m (n1 + n2) = iota m n1 ++ iota (m + n1) n2.
Admitted.

Definition mysum m n F := (foldr (fun i a => F i + a) 0 (iota m (n - m))).

(* "big" operator *)
Notation "\mysum_ ( m <= i < n ) F" := (mysum m n (fun i => F))
  (at level 41, F at level 41, i, m, n at level 50,
           format "'[' \mysum_ ( m  <=  i  <  n ) '/  '  F ']'").

Lemma mysum_recl m n F :
  m <= n ->
  \mysum_(m <= i < n.+1) F i = \mysum_(m <= i < n) F i + F n.
Admitted.

Lemma sum_odds n :
  \mysum_(0 <= i < n) (2 * i + 1) = n ^ 2.
Admitted.


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_s_perp_at :
	forall P Q A B C X,
	Col P Q C ->
	Col A B C ->
	Col A B X ->
	RightTriangle X C P ->
	Perp_at P Q A B C.
Proof.
	intros P Q A B C X.
	intros Col_P_Q_C.
	intros Col_A_B_C.
	intros Col_A_B_X.
	intros RightTriangle_XCP.

	unfold Perp_at.
	exists X.
	repeat split.
	exact Col_P_Q_C.
	exact Col_A_B_C.
	exact Col_A_B_X.
	exact RightTriangle_XCP.
Qed.

End Euclid.


(*************************************************************)
(*   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.TRAKHTENBROT
  Require Import notations utils decidable.

Set Default Proof Using "Type".

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.


Open Scope type_scope.

Definition pair_type   := (fun (x y :Type) => (x * y)).
Definition triple_type := (fun (x y z :Type) => (x * y * z)).
Definition quad_type   := (fun (x y z w:Type) => (x * y * z * w)).
Definition quint_type  := (fun (x y z w v:Type) => (x * y * z * w * v)).
Definition sext_type   := (fun (x y z w v u :Type) => (x * y * z * w * v * u)).
Definition sept_type   := (fun (x y z w v u t :Type) => (x * y * z * w * v * u * t)).

Definition pair2 := (fun {a} {b} (x:a) (y:b) => (x, y)).
Definition pair3 := (fun {a} {b} {c} (x:a) (y:b) (z:c) => (x, y, z)).
Definition pair4 := (fun {a} {b} {c} {d} (x:a) (y:b) (z:c) (w:d) => (x, y, z, w)).
Definition pair5 := (fun {a} {b} {c} {d} {e}
                          (x:a) (y:b) (z:c) (w:d) (v:e) => (x, y, z, w,v)).
Definition pair6 := (fun {a} {b} {c} {d} {e} {f}
                          (x:a) (y:b) (z:c) (w:d) (v:e) (u:f) => (x, y, z, w, v,u)).
Definition pair7 := (fun {a} {b} {c} {d} {e} {f} {g}
                          (x:a) (y:b) (z:c) (w:d) (v:e) (u:f) (t:g) =>
                          (x, y, z, w, v, u, t)).


(* Software Foundations *)
(* Exercice 3 stars, ev_ev__ev *)

Inductive ev: nat -> Prop :=
|ev_0: ev 0
|ev_ss: forall n: nat, ev n -> ev (S (S n)).

Theorem ev_ev__ev : forall n m, ev (n + m) -> ev n -> ev m.
Proof.
    intros.
    induction H0.
    apply H.
    inversion H. apply IHev in H2. apply H2.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


Require Export Gen.

Definition even (n:nat) : Prop :=
  evenb n = true.

Definition even_n__even_SSn (n:nat) : Prop :=
  (even n) -> (even (S (S n))).

Definition true_for_zero (P:nat -> Prop) : Prop :=
  P 0.

Definition preserved_by_S (P:nat -> Prop) : Prop :=
  forall n', P n' -> P (S n').

Definition true_for_all_numbers (P:nat->Prop) : Prop :=
  forall n, P n.

Definition our_nat_induction (P:nat->Prop) : Prop :=
     (true_for_zero P) ->
     (preserved_by_S P) ->
     (true_for_all_numbers P).

Inductive day : Type :=
  | monday : day
  | tuesday : day
  | wednesday : day
  | thursday : day
  | friday : day
  | saturday : day
  | sunday : day.

Inductive good_day : day -> Prop :=
  | gd_sat : good_day saturday
  | gd_sun : good_day sunday.

Theorem gds : good_day sunday.
Proof. apply gd_sun. Qed.

Inductive day_before : day -> day -> Prop :=
  | db_tue : day_before tuesday monday
  | db_wed : day_before wednesday tuesday
  | db_thu : day_before thursday wednesday
  | db_fri : day_before friday thursday
  | db_sat : day_before saturday friday
  | db_sun : day_before sunday saturday
  | db_mon : day_before monday sunday.

Inductive ok_day : day -> Prop :=
  | okd_gd : forall d,
      good_day d ->
      ok_day d
  | okd_before : forall d1 d2,
      ok_day d2 ->
      day_before d2 d1 ->
      ok_day d1.

Theorem okdw' : ok_day wednesday.
Proof.
  apply okd_before with (d2:=thursday).
  apply okd_before with (d2:=friday).
  apply okd_before with (d2:=saturday).
  apply okd_gd with (d:=saturday).
  apply gd_sat.
  apply db_sat.
  apply db_fri.
  apply db_thu.
Qed.

Definition okd_before2 := forall d1 d2 d3,
  ok_day d3 ->
  day_before d2 d1 ->
  day_before d3 d2 ->
  ok_day d1.

Theorem okd_before2_valid : okd_before2.
Proof.
  unfold okd_before2.
  intros.
  apply okd_before with (d2:=d2).
  apply okd_before with (d2:=d3).
  apply H.
  apply H1.
  apply H0.
Qed.

Print okd_before2_valid.

Definition okd_before2_valid' : okd_before2 :=
  fun (d1 d2 d3 : day) =>
  fun (H : ok_day d3) =>
  fun (H0 : day_before d2 d1) =>
  fun (H1 : day_before d3 d2) =>
  okd_before d1 d2 (okd_before d2 d3 H H1) H0.

Print okd_before2_valid'.

Check nat_ind.

Theorem plus_one_r' : forall n:nat,
  n + 1 = S n.
Proof.
  apply nat_ind.
  reflexivity.
  intros.
  apply eq_remove_S.
  apply H.
Qed.

Inductive yesno : Type :=
  | yes : yesno
  | no : yesno.

Check yesno_ind.

Inductive natlist : Type :=
  | nnil : natlist
  | ncons : nat -> natlist -> natlist.

Check natlist_ind.

Inductive ExSet : Type :=
  | con1 : bool -> ExSet
  | con2 : nat -> bool -> ExSet.

Check ExSet_ind.

Inductive tree (X:Type) : Type :=
  | leaf : X -> tree X
  | node : tree X -> tree X -> tree X.
Check tree_ind.

Inductive ev : nat -> Prop :=
  | ev_0 : ev 0
  | ev_SS : forall n : nat, ev n -> ev (S (S n)).

Theorem double_even : forall n,
  ev (double n).
Proof.
  intros.
  induction n.
  simpl.
  apply ev_0.
  simpl.
  apply ev_SS.
  apply IHn.
Qed.

Theorem ev_minus2: forall n,
  ev n -> ev (pred (pred n)).
Proof.
  intros n E.
  destruct E as [| n' E'].
  Case "E = ev_0".
  simpl. apply ev_0.
  Case "E = ev_SS n' E'".
  simpl.
  apply E'.
Qed.

Theorem ev_sum : forall n m,
   ev n -> ev m -> ev (n+m).
Proof.
  intros n m E.
  induction E.
  simpl.
  trivial.
  simpl.
  intros.
  apply ev_SS.
  apply IHE.
  apply H.
Qed.

Theorem SSev_even : forall n,
  ev (S (S n)) -> ev n.
Proof.
  intros n E. inversion E as [| n' E']. apply E'. Qed.

Theorem SSSSev_even : forall n,
  ev (S (S (S (S n)))) -> ev n.
Proof.
  intros.
  inversion H.
  inversion H1.
  apply H3.
Qed.

Theorem ev_ev_even : forall n m,
  ev (n+m) -> ev n -> ev m.
Proof.
  intros n m eq1 eq2.
  induction eq2.
  simpl in eq1.
  apply eq1.

  simpl in eq1.
  inversion eq1.
  apply IHeq2.
  apply H0.
Qed.
(* reference: https://github.com/flavioc/coq/blob/master/Ind.v *)

Inductive MyProp : nat -> Prop :=
  | MyProp1 : MyProp 4
  | MyProp2 : forall n:nat, MyProp n -> MyProp (4 + n)
  | MyProp3 : forall n:nat, MyProp (2 + n) -> MyProp n.

Theorem MyProp_0 : MyProp 0.
Proof.
  apply MyProp3.
  apply MyProp3.
  simpl.
  apply MyProp1.
Qed.

Theorem MyProp_plustwo : forall n:nat, MyProp n -> MyProp (S (S n)).
Proof.
  intros.
  apply MyProp3.
  simpl.
  apply MyProp2.
  apply H.
Qed.

Theorem MyProp_ev : forall n:nat,
  ev n -> MyProp n.
Proof.
  intros n E.
  induction E as [| n' E'].
  Case "E = ev_0".
    apply MyProp_0.
  Case "E = ev_SS n' E'".
    apply MyProp_plustwo. apply IHE'. Qed.

Theorem ev_MyProp : forall n:nat,
  MyProp n -> ev n.
Proof.
  intros.
  induction H.
  apply ev_SS. apply ev_SS. apply ev_0.
  apply ev_SS. apply ev_SS. apply IHMyProp.
  simpl in IHMyProp.
  apply ev_minus2 in IHMyProp.
  simpl in IHMyProp.
  apply IHMyProp.
Qed.


(* ====================== *)
(* ===== CH01_ccw.v ===== *)
(* ====================== *)

Require Export Jordan5.

Open Scope R_scope.

(* ========================== *)
(* ======= ########## ======= *)
(* ========================== *)

Definition det (p q r : point) : R :=
  (fst p * snd q) - (fst q * snd p) - (fst p * snd r) + (fst r * snd p) +
  (fst q * snd r) - (fst r * snd q).

Lemma eq_det : forall (p q r : point),
  det p q r = det q r p.
Proof.
intros p q r.
unfold det; ring.
Qed.

Lemma neq_det : forall (p q r : point),
  det p q r = - det p r q.
Proof.
intros p q r.
unfold det; ring.
Qed.

(* ========================== *)
(* ======= ########## ======= *)
(* ========================== *)

Definition ccw (p q r : point) : Prop :=
  (det p q r > 0).

Lemma ccw_dec : forall (p q r : point),
  {ccw p q r} + {~ ccw p q r}.
Proof.
intros p q r.
unfold ccw; apply Rgt_dec.
Qed.

(* ======= ####### ======= *)

Definition align (p q r : point) : Prop :=
  (det p q r = 0).

Lemma align_dec : forall (p q r : point),
  {align p q r} + {~align p q r}.
Proof.
intros p q r.
unfold align.
generalize (total_order_T (det p q r) 0).
generalize (Rlt_dichotomy_converse (det p q r) 0).
tauto.
Qed.

(* ========================== *)
(* ======= ########## ======= *)
(* ========================== *)

Lemma Rle_neq_lt : forall (r1 r2 : R),
  r1 <= r2 -> r1 <> r2 -> r1 < r2.
Proof.
intros r1 r2 H1 H2.
elim (Rdichotomy r1 r2).
trivial.
generalize (Rle_not_lt r2 r1).
tauto.
assumption.
Qed.

Lemma R_gt_0_plus : forall (r1 r2 : R),
  r1 > 0 -> r2 > 0 -> r1 + r2 > 0.
Proof.
intros r1 r2 H1 H2.
apply Rgt_trans with r1.
 pattern r1 at 2; rewrite <- (Rplus_0_r r1).
 apply Rplus_gt_compat_l; assumption.
assumption.
Qed.

Lemma R_gt_0_mult : forall (r1 r2 : R),
  r1 > 0 -> r2 > 0 -> r1 * r2 > 0.
Proof.
apply Rmult_gt_0_compat.
Qed.

Lemma R_gt_0_div : forall (r1 r2 : R),
  r1 > 0 -> r2 > 0 -> r1 * / r2 > 0.
Proof.
intros r1 r2 H1 H2.
apply R_gt_0_mult.
 assumption.
 unfold Rgt in *; auto with real.
Qed.

Lemma R_mult_div : forall (r1 r2 r3 : R),
  r1 = r2 * r3 -> r2 > 0 -> r1 * / r2 = r3.
Proof.
intros r1 r2 r3 H1 H2.
subst r1; auto with real.
Qed.

(* ========================== *)
(* ======= ########## ======= *)
(* ========================== *)

Lemma axiom_orientation_1 :
  forall (A:point)(B:point)(C:point),
  ccw A B C -> ccw B C A.
Proof.
intros A B C.
unfold ccw; rewrite eq_det; trivial.
Qed.

Lemma axiom_orientation_2 :
  forall (A:point)(B:point)(C:point),
  align A B C -> align B C A.
Proof.
intros A B C.
unfold align; rewrite eq_det; trivial.
Qed.

Lemma axiom_orientation_3 :
  forall (A:point)(B:point)(C:point),
  align A B C -> align A C B.
Proof.
intros A B C.
unfold align; rewrite neq_det.
generalize (Rplus_opp_r (det A C B)).
generalize (Rplus_0_l (det A C B)).
intros H1 H2 H3.
rewrite H3 in H2; clear H3.
rewrite Rplus_comm in H1.
rewrite H1 in H2; clear H1.
assumption.
Qed.

Hint Resolve axiom_orientation_1 axiom_orientation_2 axiom_orientation_3 : myorientation.

(* ======================= *)

Lemma axiom_orientation_4 :
  forall (A:point)(B:point)(C:point),
  ccw A B C -> ~ ccw A C B.
Proof.
intros A B C.
unfold ccw; rewrite neq_det.
generalize (Ropp_gt_lt_contravar (- det A C B) 0).
rewrite Ropp_involutive; rewrite Ropp_0.
intro H1; generalize (Rlt_le (det A C B) 0).
intro H2; generalize (Rle_not_lt 0 (det A C B)).
intro H3; tauto.
Qed.

Lemma axiom_orientation_5 :
  forall (A:point)(B:point)(C:point),
  ccw A B C -> ~ align A B C.
Proof.
intros A B C.
unfold ccw, align in *.
apply Rgt_not_eq; assumption.
Qed.

Lemma axiom_orientation_6 :
  forall (A:point)(B:point)(C:point),
  align A B C -> ~ ccw A B C.
Proof.
intros A B C.
unfold ccw, align in *.
intro H1; rewrite H1.
unfold not; intro H2.
apply Rgt_not_eq in H2; tauto.
Qed.

Hint Resolve axiom_orientation_4 axiom_orientation_5 axiom_orientation_6 : myorientation.

(* ======================= *)

Lemma axiom_orientation_7 :
  forall (A:point)(B:point)(C:point),
  ~ ccw A B C -> ccw A C B \/ align A B C.
Proof.
intros A B C H.
elim (ccw_dec A C B).
 intro H1; left; assumption.
 intro H1; right.
 unfold ccw, align in *.
 rewrite neq_det in H1.
 apply Rle_antisym.
  apply Rnot_gt_le; assumption.
  apply Rnot_gt_le; auto with real.
Qed.

Lemma axiom_orientation_8 :
  forall (A:point)(B:point)(C:point),
  ~ align A B C -> ccw A B C \/ ccw A C B.
Proof.
intros A B C H.
elim (ccw_dec A B C).
 intro H0; left; assumption.
 intro H0; right.
 apply axiom_orientation_7 in H0.
 elim H0; [trivial|contradiction].
Qed.

Hint Resolve axiom_orientation_7 axiom_orientation_8 : myorientation.

(* ========================== *)
(* ======= ########## ======= *)
(* ========================== *)

Lemma ccw_axiom_1 : forall (p q r : point),
  ccw p q r -> ccw q r p.
Proof.
auto with myorientation.
Qed.

Lemma ccw_axiom_2 : forall (p q r : point),
  ccw p q r -> ~ ccw p r q.
Proof.
auto with myorientation.
Qed.

Lemma ccw_axiom_3 : forall (p q r : point),
  ~ align p q r -> (ccw p q r) \/ (ccw p r q).
Proof.
auto with myorientation.
Qed.

Lemma ccw_axiom_4 : forall (p q r t : point),
  (ccw t q r) -> (ccw p t r) -> (ccw p q t) -> (ccw p q r).
Proof.
intros p q r t H1 H2 H3.
unfold ccw in *.
assert (det t q r + det p t r + det p q t = det p q r).
unfold det; ring.
rewrite <- H.
apply R_gt_0_plus; [apply R_gt_0_plus; assumption | assumption].
Qed.

Lemma ccw_axiom_5 : forall (p q r s t : point),
  (ccw t s p) -> (ccw t s q) -> (ccw t s r) -> (ccw t p q) -> (ccw t q r) ->
  (ccw t p r).
Proof.
intros p q r s t H1 H2 H3 H4 H5.
unfold ccw in *.
replace (det t p r) with ((det t p q * det t s r + det t q r * det t s p) * / (det t s q)).
apply R_gt_0_div.
 apply R_gt_0_plus.
  apply R_gt_0_mult; assumption.
  apply R_gt_0_mult; assumption.
 assumption.
apply R_mult_div.
 unfold det; ring.
 assumption.
Qed.

Lemma ccw_axiom_5_bis : forall (p q r s t : point),
  (ccw s t p) -> (ccw s t q) -> (ccw s t r) -> (ccw t p q) -> (ccw t q r) ->
  (ccw t p r).
Proof.
intros p q r s t H1 H2 H3 H4 H5.
unfold ccw in *.
replace (det t p r) with ((det t p q * det s t r + det t q r * det s t p) * / (det s t q)).
apply R_gt_0_div.
 apply R_gt_0_plus.
  apply R_gt_0_mult; assumption.
  apply R_gt_0_mult; assumption.
 assumption.
apply R_mult_div.
 unfold det; ring.
 assumption.
Qed.