(* (c) Copyright Christian Doczkal, Saarland University                   *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From CompDecModal.libs
 Require Import edone bcase fset base modular_hilbert sltype.
From CompDecModal.CTL
 Require Import CTL_def.

Set Default Proof Using "Type".

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

(** * Hilbert System for CTL *)

Module IC.
Section Hilbert.
  Local Notation "s ---> t" := (fImp s t).

  Inductive prv : form -> Prop :=
  | rMP s t : prv (s ---> t) -> prv s -> prv t
  | axK s t : prv (s ---> t ---> s)
  | axS s t u : prv ((u ---> s ---> t) ---> (u ---> s) ---> u ---> t)
  | axDN s : prv (((s ---> fF) ---> fF)  ---> s)
  | rNec s : prv s -> prv (fAX s)
  | axN s t : prv (fAX (s ---> t) ---> fAX s ---> fAX t)

  | AU_ind s t u : prv (t ---> u) -> prv (s ---> fAX u ---> u) -> prv ((fAU s t) ---> u)
  | axAUI s t     : prv (t ---> fAU s t)
  | axAUf s t     : prv (s ---> fAX (fAU s t) ---> fAU s t)

  | rAR_ind s t u :
      prv (u ---> t) -> prv (u ---> (s ---> fF) ---> fAX u) -> prv (u ---> fAR s t)
  | axARE s t    : prv (fAR s t ---> t)
  | axARu s t    : prv (fAR s t ---> (s ---> fF) ---> fAX (fAR s t))

  | ax_serial : prv (fAX fF ---> fF).

  (** The hilbert system for CTL can be seen as the composition of
  Hilbert systems for minimal logic (M), classical propositional logic
  (P), basic modal logic (K) and the rules and axioms specific to CTL *)

  Canonical Structure prv_mSystem := MSystem rMP axK axS.
  Canonical Structure prv_pSystem := PSystem axDN.
  Canonical Structure prv_kSystem := KSystem rNec axN.
  Canonical Structure prv_ctlSystem := CTLSystem AU_ind axAUI axAUf rAR_ind axARE axARu.

  Canonical Structure form_slpType := @SLPType prv_pSystem form_slClass.

  (** ** Soundness *)

  Lemma soundness s : prv s -> forall (M:cmodel) (w:M), eval s w.
  Proof.
    elim => {s}; try by [move => /= *; firstorder].
    - move => /= s M w H. by case: (modelP s w); firstorder.
    - move => s t u _ /= IH1 _ IH2 M w. elim => {w} - w; first exact: IH1.
      move => ws H1 H2. exact: IH2.
    - move => s t M w /=. exact: AU0.
    - move => s t M w /=. exact: AUs.
    - move => s t u _ IH1 _ IH2.
      cofix soundness => /= M w H. case (modelP s w) => Hs.
      - apply: AR0 Hs _. exact: IH1 H.
      - apply: ARs. exact: IH1 H. move => v wv. apply: soundness.
        exact: IH2 wv.
    - move => s t M w /=. by case.
    - move => s t M w /=. by case.
    - move => M w /=. case: (serial w) => v wv. by move/(_ _ wv).
  Qed.

  Lemma box_request (C : clause) : prv ([af C] ---> AX [af R C]).
  Proof.
    rewrite <- bigABBA. apply: bigAI. case => [s [|]]; last by rewrite (negbTE (Rpos _ _)).
    rewrite RE. exact: bigAE.
  Qed.

End Hilbert.
End IC.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Require Import Arith.
From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
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 append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma rev_append : forall (x y : lst), rev (append x y) = append (rev y) (rev x).
Proof.
   intros.
   induction x.
   - simpl. rewrite append_nil. reflexivity.
   - simpl. rewrite IHx. rewrite append_assoc. reflexivity.
Qed.

Lemma rev_rev : forall (x : lst), rev (rev x) = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. lfind.  simpl.  rewrite IHx.  reflexivity.
Admitted.

Lemma qreva_rev : forall (x y : lst), qreva x y = append (rev x) y.
Proof.
   induction x.
   - reflexivity.
   - intros. simpl. rewrite IHx. rewrite append_assoc. simpl. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (qreva (qreva x (rev y)) Nil) (append y x).
Proof.
   induction x.
   - intros. simpl. rewrite qreva_rev. rewrite rev_rev. reflexivity.
   - intros. simpl.
   rewrite (eq_refl : Cons n (rev y) = append (rev (Cons n Nil)) (rev y)).
   rewrite <- rev_append.
   rewrite IHx.
   rewrite append_assoc.
   simpl. reflexivity.
Qed.


From mathcomp Require Import all_ssreflect.

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

----------------------------------------------------------
#
#
** The Coq proof assistant and the Mathematical Components library

Objective: learn the Coq system in the MC library

*** Roadmap

- #lesson 1#: Functions and computations
  - #exercise #

- #lesson 2#: First steps in formal proofs
  - #exercise #

- #lesson 3#: A few more steps in formal proofs
  - #exercise #

- #lesson 4#: Type theory
  - #exercise #

- #lesson 5#: Boolean reflection
  - #exercise #

- #lesson 6#: Real proofs, finally!
  - #exercise #

- #lesson 7#: Generic theories
  - #exercise #

- #lesson 8#: Subtypes
  - #exercise #

*** Teaching material

- Slides and exercises
  #https://www-sop.inria.fr/teams/marelle/coq-18/#
- Coq (#software#
  and #user manual#, in particular the chapter about #SSReflect#)
- Mathematical Components
  (#software# and
  #book#)

#

#

#
(notes)
#
You don't need to install Coq in order to follow this
class, you just need a recent browser thanks to
#jsCoq#.
#

#

#
#

----------------------------------------------------------
#
#
** Lesson 1: summary

- functions
- simple data
- containers
- symbolic computations
- higher order functions and mathematical notations

#
#

----------------------------------------------------------
#
#
** Functions

Functions are built using the [fun .. => ..] syntax.
The command [Check] verifies that a term is well typed.

#
#
*)
Check (fun n => 1 + n + 1).
(**
#
#

Notice that the type of [n] was inferred and that
the whole term has type [nat -> nat], where [->]
is the function space.

Function application is written by writing the function
on the left of the argument (eg, not as in the mathematical
practice).

#
#
*)
Check 2.
Check (fun n => 1 + n + 1) 2.
(**
#
#

Notice how [2] has a type that fits, and hence
the type of the function applied to [2] is [nat].

Terms (hence functions) can be given a name using
the [Definition] command. The command offers some
syntactic sugar for binding the function arguments.

#
#
*)
Definition f := (fun n => 1 + n + 1).
(* Definition f n := 1 + n + 1. *)
(* Definition f (n : nat) := 1 + n + 1. *)
(**
#
#

Named terms can be printed.

#
#
*)
Print f.
(**
#
#

Coq is able to compute with terms, in particular
one can obtain the normal form via the [Eval lazy in]
command.

#
#
*)
Eval lazy in f 2.
(**
#
#

Notice that "computation" is made of many steps.
In particular [f] has to be unfolded (delta step)
and then the variable substituted for the argument
(beta).

#
#
*)
Eval lazy delta [f] in f 2.
Eval lazy delta [f] beta in f 2.
(**
#
#

Nothing but functions (and their types) are built-in in Coq.
All the rest is defined, even [1], [2] and [+] are not primitive.

#

#

#
(notes)
#

This slide corresponds to
section 1.1 of
#the Mathematical Components book#
#

#

#
#

----------------------------------------------------------
#
#
** Data types

Data types can be declared using the [Inductive] command.

Many of them are already available in the Coq library called
[Prelude] that is automatically loaded. We hence just print
them.

[Inductive bool := true | false.]

#
#
*)
Print bool.
(**
#
#

This command declares a new type [bool] and declares
how the terms (in normal form) of this type are built.
Only [true] and [false] are canonical inhabitants of
[bool].

To use a boolean value Coq provides the [if..then..else..]
syntax.

#
#
*)
Definition twoVtree (b : bool) := if b then 2 else 3.
Eval lazy in twoVtree true.
Eval lazy delta in twoVtree true.
Eval lazy delta beta in twoVtree true.
Eval lazy delta beta iota in twoVtree true.
(**
#
#

We define a few boolean operators that will come in handy
later on.

#
#
*)
Definition andb (b1 b2 : bool) := if b1 then b2 else false.
Definition orb (b1 b2 : bool) := if b1 then true else b2.

Infix "&&" := andb.
Infix "||" := orb.

Check true && false || false.
(**
#
#

The [Infix] command lets one declare infix notations.
Precedence and associativity is already declared in the
prelude of Coq, here we just associate the constants
[andb] and [orb] to these notataions.

Natural numbers are defined similarly to booleans:

[Inductive nat := O | S (n : nat).]

#
#
*)
Print nat.
(**
#
#

Coq provides a special notation for literals, eg [3],
that is just sugar for [S (S (S O))].

The Mathematical Components library adds on top of that
the postfix [.+1], [.+2], .. for iterated applications
of [S] to terms other than [O].

#
#
*)
Check 3.
Check (fun x => (x + x).+2).
Eval lazy in (fun x => (x + x).+2) 1.
(**
#
#

In order to use natural numbers Coq provides two
tools. An extended [if..then..else..] syntax to
extract the argument of [S] and the [Fixpoint]
command to define recusrsive functions.

#
#
*)
Definition pred (n : nat) :=
  if n is p.+1 then p else 0.

Eval lazy in pred 7.
(**
#
#

Notice that [p] is a binder. When the [if..then..else..]
is evaluated, and [n] put in normal form, then if it
is [S t] the variable [p] takes [t] and the then-branch
is taken.

Now lets define addition using recursion

#
#
*)
Fixpoint addn n m :=
  if n is p.+1 then (addn p m).+1 else m.
Infix "+" := addn.
Eval lazy in 3 + 2.
(**
#
#

The [if..then..else..] syntax is just sugar for
[match..with..end].

#
#
*)
Print addn.
(**
#
#

Let's now write the equality test for natural numbers

#
#
*)
Fixpoint eqn n m :=
  match n, m with
  | 0, 0 => true
  | p.+1, q.+1 => eqn p q
  | _, _ => false
  end.
Infix "==" := eqn.
Eval lazy in 3 == 4.
(**
#
#

Other examples are subtraction and order

#
#
*)
Fixpoint subn m n : nat :=
  match m, n with
  | p.+1, q.+1 => subn p q
  | _ , _ => m
  end.

Infix "-" := subn.

Eval lazy in 3 - 2.
Eval lazy in 2 - 3. (* truncated *)

Definition leq m n := m - n == 0.

Infix "<=" := leq.

Eval lazy in 4 <= 5.
(**
#
#

#

#

#
(notes)
#

All the constants defined in this slide are already
defined in Coq's prelude or in Mathematical Components.
The main difference is that [==] is not specific to
[nat] but overloaded (it works for most data types).
This topic is to be developed in lesson 4.

This slide corresponds to
section 1.2 of
#the Mathematical Components book#
#

#

#
#

#
#

----------------------------------------------------------
#
#
** Containers

Containers let one aggregate data, for example to form a
pair or a list.  The interesting characteristic of containers
is that they are polymorphic: the same container can be used
to hold terms of many types.

[Inductive seq (A : Type) := nil | cons (hd : A) (tl : seq A).]

#
#
*)
Check nil.
Check cons 3 [::].
(**
#
#

We learn that [[::]] is a notation for the empty sequence
and that the type parameter [?A] is implicit.

#
#
*)
Check 1 :: nil.
Check [:: 3; 4; 5 ].
(**
#
#

The infix [::] notation stands for [cons]. This one is mostly
used to pattern match a sequence.

The notation [[:: .. ; .. ]] can be used to form sequences
by separating the elements with [;]. When there are no elements
what is left is [[::]] that is the empty seqeunce.

And of course we can use sequences with other data types

#
#
*)
Check [:: 3; 4; 5 ].
Check [:: true; false; true ].
(**
#
#

Let's now define the [size] function.

#
#
*)
Fixpoint size A (s : seq A) :=
  if s is _ :: tl then (size tl).+1 else 0.

Eval lazy in size [:: 1; 8; 34].
(**
#
#

Given that the contents of containers are of an
arbitrary type many common operations are parametrized
by functions that are specific to the type of the
contents.

[[
Fixpoint map A B (f : A -> B) s :=
if s is e :: tl then f e :: map f tl else nil.
]]

#
#
*)
Definition l := [:: 1; 2; 3].
Eval lazy in [seq x.+1 | x <- l].
(**
#
#

The #seq#
library of Mathematical Components contains many combinators. Their syntax
is documented in the header of the file.

#

#

#
(notes)
#

This slide corresponds to
section 1.3 of
#the Mathematical Components book#
#

#

#
#

----------------------------------------------------------
#
#
** Symbols

The section mecanism is used to describe a context under
which definitions are made. Coq lets us not only define
terms, but also compute with them in that context.

We use this mecanism to talk about symbolic computation.

#
#
*)
Section symbols.
Variables v : nat.

Eval lazy in pred v.+1 .
Eval lazy in pred v .
(**
#
#

Computation can take place in presence of variables
as long as constructors can be consumed. When no
more constructors are available computation is
stuck.

Let's not look at a very common higher order
function.

#
#
*)

Fixpoint foldr A T f (a : A) (s : seq T) :=
  if s is x :: xs then f x (foldr f a xs) else a.
(**
#
#

The best way to understand what [foldr] does
is to postulate a variable [f] and compute.

#
#
*)

Variable f : nat -> nat -> nat.

Eval lazy in foldr f    3 [:: 1; 2 ].

(**
#
#

If we plug [addn] in place of [f] we
obtain a term that evaluates to a number.

#
#
*)

Eval lazy in foldr addn 3 [:: 1; 2 ].

End symbols.

(**
#
#

#
(notes)
#

This slide corresponds to
sections 1.4 and 1.5 of
#the Mathematical Components book#
#

#

#
#

----------------------------------------------------------
#
#
** Higher order functions and mathematical notations

Let's try to write this formula in Coq

#$$ \sum_{i=1}^n (i * 2 - 1) = n ^ 2 $$#

We need a bit of infrastruture

#
#
*)
Fixpoint iota m n := if n is u.+1 then m :: iota m.+1 u else [::].

Eval lazy in iota 0 5.

(**
#
#

Combining [iota] and [foldr] we can get pretty
close to the LaTeX source for the formula above.

#
#
*)

Notation "\sum_ ( m <= i < n ) F" :=
  (foldr (fun i a => F + a) 0 (iota m (n-m))).

Check \sum_(1 <= x < 5) (x * 2 - 1).
Eval lazy in \sum_(1 <= x < 5) (x * 2 - 1).
(**
#
#

#

#

#
(notes)
#

This slide corresponds to
section 1.6 of
#the Mathematical Components book#
#

#

#
#

----------------------------------------------------------
#
#
** Lesson 1: sum up

- [fun .. => ..]
- [Check]
- [Definition]
- [Print]
- [Eval lazy]
- [Inductive] declarations [bool], [nat], [seq].
- [match .. with .. end] and [if .. is .. then .. else ..]
- [Fixpoint]
- [andb] [orb] [eqn] [leq] [addn] [subn] [size] [foldr]

#
#

*)


From mathcomp Require Import all_ssreflect ssralg matrix ssrnum vector reals normedtype order boolp classical_sets.
Require Import counterclockwise.

(******************************************************************************)
(*       a <| t |> b := t *: a + (1 - t) *: b where a,b : lmodType R          *)
(*                      for instance, a <| 0 |> b = b, etc.                   *)
(*     between x y z := x \in [y,z]                                           *)
(******************************************************************************)

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

Import GRing Num.Theory Order.POrderTheory Order.TotalTheory.

Local Open Scope order_scope.
Local Open Scope ring_scope.

Section In01.
Variable R : realType.

Definition in01 (t : R) := 0 <= t <= 1.

Lemma in010 : in01 0.
Proof. by rewrite/in01 lexx ler01. Qed.

Lemma in011 : in01 1.
Proof. by rewrite/in01 lexx ler01. Qed.

Lemma in01_ge0 t : in01 t -> 0 <= t.
Proof. by move=>/andP[]. Qed.

Lemma in01M_ge0 (t : R) : in01 t = (0 <= t * (1-t)).
Proof.
apply/idP/idP.
   by move=>/andP[t0 t1]; apply mulr_ge0=>//; rewrite subr_ge0.
move=>ge0; apply/andP; split; rewrite leNgt; apply/negP=>ti; move:ge0.
   by rewrite nmulr_rge0// subr_le0=>t1; move:(lt_trans ltr01 (le_lt_trans t1 ti)); rewrite ltxx.
by move:(ti); rewrite -subr_lt0=>t1'; rewrite nmulr_lge0// =>t0; move:(lt_trans (le_lt_trans t0 ltr01) ti); rewrite ltxx.
Qed.

Lemma in01_onem t : in01 t = in01 (1 - t).
Proof. by rewrite 2!in01M_ge0 opprB addrCA subrr addr0 mulrC. Qed.

Lemma in01M t u : in01 t -> in01 u -> in01 (t * u).
Proof.
move=>/andP[t0 t1]/andP[u0 u1]; apply/andP; split; first by apply mulr_ge0.
by apply mulr_ile1.
Qed.

Lemma in01M1 t u : in01 t -> in01 u -> (t * u == 1) = (t == 1) && (u == 1).
Proof.
move=>/andP[t0 t1]/andP[u0 u1].
apply/idP/idP; last by move=>/andP[/eqP-> /eqP->]; rewrite mulr1.
case tn1: (t == 1); first by move:tn1=>/eqP->; rewrite mul1r.
case un1: (u == 1); first by move:un1=>/eqP->; rewrite mulr1 tn1.
move=>/eqP tu1/=.
suff: t * u < 1 by rewrite tu1 ltxx.
by apply mulr_ilt1=>//; rewrite -subr_gt0 lt0r subr_eq0 subr_ge0 eq_sym ?t1 ?u1 ?tn1 ?un1.
Qed.

Lemma in01_convA t u : in01 t -> in01 u -> in01 (t / (1-(1-t)*(1-u))).
Proof.
move=> t01 u01.
have c0 : 0 <= 1 - (1 - t) * (1 - u).
  by move:t01 u01; rewrite in01_onem=>t01; rewrite in01_onem=>/(in01M t01); rewrite in01_onem=>/andP[].
apply/andP; split.
   by apply divr_ge0=>//; move:t01=>/andP[].
have [->|e0] := eqVneq (1 - (1 - t) * (1 - u)) 0; first by rewrite invr0 mulr0; exact ler01.
rewrite -{4}(divff e0).
rewrite ler_wpmul2r ?invr_ge0//.
rewrite mulrBr mulr1 mulrBl -addrA opprD addrA subrr add0r opprB opprK -mulrBl -subr_ge0 -addrA subrr addr0; apply mulr_ge0; last by move:u01=>/andP[].
by move:t01; rewrite in01_onem=>/andP[].
Qed.

End In01.

Section Conv.
Variable R : realType.
Variable E : lmodType R.

Definition conv (t : R) (a b : E) := t *: a + (1 - t) *: b.

End Conv.

(* NB(rei): same notation as infotheo *)
Reserved Notation "x <| p |> y" (format "x  <| p |>  y", at level 49).
Notation "a <| p |> b" := (conv p a b). (* TODO(rei): needs scope *)

Section Conv.
Variable R : realType.
Variable E : lmodType R.
Implicit Types (t u v : R) (a b c d : E).

Lemma conv0 a b : a <| 0 |> b = b.
Proof. by rewrite/conv scale0r add0r subr0 scale1r. Qed.

Lemma conv1 a b : a <| 1 |> b = a.
Proof. by rewrite/conv scale1r subrr scale0r addr0. Qed.

Lemma convmm t a : a <| t |> a = a.
Proof. by rewrite/conv -scalerDl addrCA subrr addr0 scale1r. Qed.

Lemma convC t a b : a <| t |> b = b <| 1 - t |> a.
Proof. by rewrite/conv opprB addrCA subrr addr0 addrC. Qed.

Lemma convlr t a b : a <| t |> b = a + (1 - t) *: (b-a).
Proof. by rewrite scalerDr scalerN addrCA -{2}[a]scale1r -scalerBl opprB addrCA subrr addr0 addrC. Qed.

Lemma convrl t a b : a <| t |> b = b + t *: (a - b).
Proof. by rewrite convC convlr opprB addrCA subrr addr0. Qed.

End Conv.

Section Conv.
Variable R : realType.
Variable E : lmodType R.
Implicit Types (t u v : R) (a b c d : E).

Lemma convA t u a b c : in01 t -> in01 u ->
  a <| t |> (b <| u |> c) =
  (a <| t / ((1 : R^o) <| t |> u) |> b) <| (1 : R^o) <| t |> u |> c.
Proof.
move=> t01 u01.
have -> : (1 : R^o) <| t |> u = 1 - (1 - t) * (1 - u).
  by rewrite (convlr _ (1 : R^o)) -[u-1]opprB scalerN.
rewrite/conv scalerDr addrA 2!scalerA opprB addrCA subrr addr0; congr add.
have [/eqP|tu1] := eqVneq (1 - (1 - t) * (1 - u)) 0.
  rewrite {1}subr_eq0 eq_sym in01M1 -?in01_onem// -2![_-_ == 1]subr_eq0.
  rewrite 2![1-_-1]addrAC subrr 2!add0r 2!oppr_eq0=>/andP[/eqP-> /eqP->].
  by rewrite mulr0 subr0 mulr1 subrr 3!scale0r addr0.
rewrite scalerDr 2!scalerA [(1-_*_)*(1-_)]mulrBr mulrCA divff// 2!mulr1 mulrBr.
by rewrite mulr1 addrAC opprB addrCA subrr addr0.
Qed.

Lemma convA' t u a b c : in01 t -> in01 u ->
  (a <| u |> b) <| t |> c =
  a <| t * u |> (b <| t * (1 - u) / ((1 - u : R^o) <| t |> 1) |> c).
Proof.
move=>t01 u01.
rewrite convC (convC u) convA.
   2, 3: by rewrite -in01_onem.
rewrite -convC convC (convC _ c).
have -> : (1 - u : R^o) <| t |> 1 = 1 - t * u.
  by rewrite (convrl _ _ 1) addrAC subrr add0r scalerN.
rewrite opprB addrCA subrr addr0.
have [/eqP|tu1] := eqVneq (1 - t * u) 0.
    by rewrite subr_eq0 eq_sym in01M1// =>/andP[/eqP-> /eqP->]; rewrite 2!mul1r 2!conv1.
congr (_ <| _ |> (_ <| _ |> _)).
by apply (mulfI tu1); rewrite mulrBr mulr1 2![(1-t*u)*(_/_)]mulrCA divff// 2!mulr1 opprB addrCA addrAC subrr add0r mulrBr mulr1.
Qed.

Lemma in01_conv (t u v : R) : in01 t -> in01 u -> in01 v ->
  in01 ((u : R^o) <| t |> v).
Proof.
move=>/andP[t0 t1] /andP[u0 u1] /andP[v0 v1]; apply/andP; split.
   apply addr_ge0; apply mulr_ge0=>//.
   by rewrite subr_ge0.
have<-: t + (1-t) = 1 by rewrite addrCA subrr addr0.
apply ler_add; rewrite -subr_ge0.
   rewrite -{1}[t]mulr1 -mulrBr; apply mulr_ge0=>//.
   by rewrite subr_ge0.
by rewrite -{1}[1-t]mulr1 -mulrBr; apply mulr_ge0; rewrite subr_ge0.
Qed.

Lemma in01_convl (t u : R) : 0 <= t*u -> in01 (t / (t+u)).
Proof.
have H: forall a b : R, 0 <= a*b -> 0 <= a/(a+b) by move=>a b ab0; rewrite -sgr_ge0 sgrM sgrV -sgrM sgr_ge0 mulrDr -expr2; apply addr_ge0=>//; apply sqr_ge0.
move=>tu0.
have [->|tun0] := eqVneq (t + u) 0.
   by rewrite invr0 mulr0; apply in010.
apply/andP; split; first by apply H.
rewrite -{1}[t](addr0) -(subrr u) addrA mulrBl divff// -subr_ge0 opprB addrCA subrr addr0 addrC; apply H.
by rewrite mulrC.
Qed.

Lemma conv_onem (t u v : R) :
  (1-u : R^o) <| t |> (1-v) =
  1 - (u : R^o) <| t |> v.
Proof.
rewrite/conv 2!scalerBr addrACA opprD; congr add.
have sm: forall u, u *: (1 : R^o) = u*1 by [].
by rewrite 2!sm 2!mulr1 addrCA subrr addr0.
Qed.

Lemma convACA (t u v : R) (a b c d : E) : in01 t -> in01 u -> in01 v ->
  (a <| u |> b) <| t |> (c <| v |> d) =
  (a <| t * u / ((u : R^o) <| t |> v) |> c)
    <| (u : R^o) <| t |> v |>
  (b <| t * (1 - u) / ((1 - u : R^o) <| t |> (1 - v)) |> d).
Proof.
move=>/andP[t0 t1]/andP[u0 u1]/andP[v0 v1].
move:t0; rewrite le0r => /orP[|].
   by move=>/eqP->; rewrite !mul0r !conv0.
move=>t0; move:t1; rewrite -subr_ge0 le0r => /orP[|].
   rewrite subr_eq0=>/eqP<-; rewrite !mul1r !conv1.
   move:u0; rewrite le0r => /orP[|].
      by move=>/eqP->; rewrite subr0 !conv0 divff ?oner_neq0// conv1.
   rewrite lt0r=>/andP[u0 _]; rewrite divff// conv1.
   move:u1; rewrite -subr_ge0 le0r => /orP[|].
      by rewrite subr_eq0=>/eqP<-; rewrite 2!conv1.
   by rewrite lt0r=>/andP[t1 _]; rewrite divff// conv1.
move=>t1.
have c0: forall x y : R, 0 <= x -> 0 <= y -> (x : R^o) <| t |> y = 0 -> x = 0 /\ y = 0.
   move=>x y; rewrite le0r => /orP[|].
      move=>/eqP-> _ /eqP.
      rewrite/conv scaler0 add0r mulf_eq0 => /orP[|].
         by move=>t1'; move:t1; rewrite lt0r=>/andP[/negPf]; rewrite t1'.
      by move=>/eqP->.
   move=>x0 y0 c0.
   suff: 0 < (x : R^o) <| t |> y by rewrite c0 ltxx.
   rewrite /conv -(addr0 0) ; apply ltr_le_add.
      by apply mulr_gt0.
   by apply mulr_ge0=>//; apply ltW.
have [|uv0] := eqVneq ((u : R^o) <| t |> v) 0.
   by move=>/(c0 _ _ u0 v0) [-> ->]; rewrite convmm !conv0 subr0 convmm -mulrA divff ?oner_neq0// mulr1.
move:u1 v1; rewrite -2![_ <= 1]subr_ge0=>u1 v1.
have [|uv0'] := eqVneq ((1 - u : R^o) <| t |> (1 -v)) 0.
    by move=> /(c0 _ _ u1 v1)[/eqP]; rewrite subr_eq0=>/eqP<- /eqP; rewrite subr_eq0=>/eqP<-; rewrite convmm !conv1 -mulrA divff ?oner_neq0// mulr1.
rewrite{1 2 3 4 6 8}/conv 4!scalerDr 2!addrA !scalerA -conv_onem.
rewrite 2![((_ : R^o) <| _ |> _) * (1 - _)]mulrBr 2![_ * (_ * _ / _)]mulrC -!mulrA 2![_^-1 * _]mulrC divff// divff// !mulr1 /conv [t *: _ + _ + _]addrAC subrr add0r [t *: _ + _ + _]addrAC subrr add0r; congr add.
by rewrite -2!addrA; congr add; rewrite addrC.
Qed.
End Conv.

Section between.
Variable R : realType.
Let Plane := pair_vectType (regular_vectType R) (regular_vectType R).

Lemma det_conv (p p' q r : Plane) (t : R) :
  det (p <| t |> p') q r = (det p q r : R^o) <| t |> det p' q r.
Proof.
have sm t' u : t' *: (u : R^o) = t' * u by [].
rewrite/conv !sm -det_cyclique -[det p q r]det_cyclique -[det p' q r]det_cyclique 3!det_scalar_productE -2!scalar_productZL -scalar_productDl; congr scalar_product.
rewrite 2!scalerBr -!addrA; congr GRing.add.
rewrite !addrA [-_ + _]addrC -addrA; congr GRing.add.
by rewrite -[-(t*:r)]scaleNr -scalerBl -opprB opprK -addrA [-t+t]addrC subrr addr0 scaleN1r.
Qed.

Lemma det0_aligned (p q r: Plane) : det p q r = 0%R <->
  (p = q \/ exists t, p <| t |> q = r).
Proof.
rewrite det_scalar_productE.
symmetry; split.
   case.
      by move=>->; rewrite subrr -(scaler0 _ 0) scalar_productZL mul0r.
      by move=> [t <-]; rewrite convlr addrAC subrr add0r rotateZ scalar_productZR scalar_product_rotatexx mulr0.
wlog: p q r / p == 0%R.
   move=> h; rewrite -[q-p]subr0 -[r-p]subr0.
   move=>/(h 0%R (q-p) (r-p) (eqxx 0%R)); case=>[ /eqP | [t] ].
      by rewrite eq_sym subr_eq0 eq_sym=>/eqP=>pq; left.
    by rewrite{1}/conv scaler0 add0r=>/(f_equal (fun x=> p+x)); rewrite [r-p]addrC addrA subrr add0r=><-; right; exists t=>//; apply convlr.
move=>/eqP p0; subst p; rewrite !subr0/scalar_product/= mulrN=>/eqP; rewrite subr_eq0=>/eqP e.
have [q0|q0] := eqVneq q 0%R; first by left.
right.
move:q0; rewrite -pair_eqE /= negb_and => /orP[|] q0.
   exists (1 - xcoord r / xcoord q)=>//.
   rewrite -convC convrl add0r subr0; apply /eqP; rewrite -pair_eqE; apply /andP; split=>/=; have ->: forall (a: R) (b: (regular_vectType (Real.ringType R))), a *: b = a*b by lazy.
   - by rewrite -mulrA [_^-1*_]mulrC divff // mulr1.
   - by rewrite mulrC mulrA -e mulrC mulrA [_^-1*_]mulrC divff // mul1r.
exists (1 - ycoord r / ycoord q)=>//.
   rewrite -convC convrl add0r subr0; apply /eqP; rewrite -pair_eqE; apply /andP; split=>/=; have ->: forall (a: R) (b: regular_vectType (Real.ringType R)), a *: b = a*b by lazy.
- by rewrite mulrC mulrA e mulrC mulrA [_^-1*_]mulrC divff // mul1r.
- by rewrite -mulrA [_^-1*_]mulrC divff // mulr1.
Qed.

Definition between (x y z : Plane) := [&& (det x y z == 0)%R,
  (0%R <= scalar_product (x - y) (z - y)) ,
  (0%R <= scalar_product (x - z) (y - z)) &
  ((y == z) ==> (x == z))].

Lemma between_conv x y z : between x y z <->
  exists t, in01 t && (x == y <| t |> z).
Proof.
case yz: (y == z).
   rewrite/between yz; move:yz=>/eqP yz; rewrite yz subrr -(scale0r 0) scalar_productZR mul0r det_cyclique det_alternate eqxx lexx/=.
   split; first by move=>/eqP->; exists 0; rewrite in010 convmm/=.
   by move=>[t /andP[_]]; rewrite convmm.
rewrite /between yz/= andbT.
move:yz=>/negbT yz.
have zye: forall t (y z: Plane), t *: y + (1-t) *: z - y = (1-t) *: (z-y).
   by move=>t y' z'; rewrite {1}[_*:_+_]addrC -addrA scalerBr; congr +%R; rewrite -scaleNr opprB scalerBl scale1r.
have yze: forall t (y z: Plane), t *: y + (1-t) *: z - z = t *: (y-z).
   by move=>t y' z'; rewrite -addrA scalerBr; congr +%R; rewrite scalerBl scale1r [_-_*:_]addrC -addrA subrr addr0.
split.
   rewrite det_cyclique =>/and3P[/eqP/det0_aligned]; case; first by move=> yz'; move:yz' yz=>->; rewrite eqxx.
   move=>[t <-].
   rewrite yze zye 2!scalar_productZL=> yp zp; exists t; apply/andP; split=>//.
   apply/andP; split.
      by move:zp; rewrite pmulr_lge0//; apply scalar_productrr_gt0; rewrite subr_eq0.
    by move:yp; rewrite pmulr_lge0 ?subr_ge0//; apply scalar_productrr_gt0; rewrite subr_eq0 eq_sym.
move=>[t] /andP [/andP [t0 t1]] /eqP->.
rewrite yze zye 2!scalar_productZL; apply/and3P; split.
- by rewrite det_cyclique; apply/eqP; apply det0_aligned; right; exists t.
- by rewrite mulr_ge0// ?subr_ge0// scalar_productrr_ge0.
- by rewrite mulr_ge0// scalar_productrr_ge0.
Qed.

Lemma betweenC (a b c : Plane) : between a b c = between a c b.
Proof.
rewrite /between det_inverse -det_cyclique oppr_eq0; congr andb; rewrite !andbA; congr andb.
   by apply andbC.
by rewrite eq_sym; apply implyb_id2l=>/eqP->.
Qed.

Lemma betweenl (a b : Plane) : between a a b.
Proof. rewrite/between det_alternate eqxx/= subrr -(scale0r 0) scalar_productZL mul0r lexx/= Bool.implb_same andbT; apply scalar_productrr_ge0. Qed.

Lemma betweenr (a b : Plane) : between a b a.
Proof. rewrite betweenC; apply betweenl. Qed.

Lemma between_depl (a b c : Plane) : between a b c <->
  exists (d : Plane) (t u : R),
    (t*u <= 0) && (b == a + t *: d) && (c == a + u *: d).
Proof.
split.
   move=>/between_conv[t] /andP[t01].
   have aconv: a = t *: a + (1-t) *: a by rewrite -scalerDl addrCA subrr addr0 scale1r.
   rewrite {1}aconv -subr_eq0 opprD addrACA -2!scalerBr.
   case t1: (t == 1).
      move:t1=>/eqP->; rewrite subrr scale1r scale0r addr0 subr_eq0=>/eqP->.
      exists (c-b), 0, 1.
      by rewrite mul0r lexx scale0r addr0 eqxx scale1r addrCA subrr addr0 eqxx.
   rewrite addr_eq0 -scalerN opprB=>/eqP e.
   exists (b-a), 1, (-t / (1-t)).
   move:t1=>/negbT; rewrite eq_sym -subr_eq0=>tn1.
   move:t01=>/andP[t0 t1]; rewrite mul1r mulNr oppr_le0 scale1r addrCA subrr addr0 eqxx mulrC scaleNr -scalerN opprB -scalerA e scalerA [_*(1-t)]mulrC divff// scale1r addrCA subrr addr0 eqxx 2!andbT; apply mulr_ge0=>//.
      by rewrite invr_ge0 subr_ge0.
move=>[d][t][u]/andP[/andP[tu0]].
wlog: d t u tu0 / 0 < t.
   move=>h.
   have [t0|t0] := ltP 0 t; first by apply h.
   move:t0; rewrite le_eqVlt => /orP[|].
      by move=>/eqP->; rewrite scale0r addr0=>/eqP-> _; apply betweenl.
   by rewrite -oppr_gt0 -(opprK d) 2![_ *: - - _]scalerN -2!scaleNr; apply h=>//; rewrite mulrN -mulNr opprK.
move=>t0 /eqP be /eqP ce.
move:tu0; rewrite pmulr_rle0// =>u0.
have tugt0: 0 < t-u by rewrite subr_gt0; exact (le_lt_trans u0 t0).
have tun0: t-u != 0 by apply/negP=>/eqP tu0; move:tugt0; rewrite tu0 ltxx.
apply/between_conv; exists (-u/(t-u)); apply/andP; split.
   apply/andP; split.
      by rewrite mulr_ge0 ?oppr_ge0// invr_ge0 ltW.
   by rewrite -subr_ge0 -(pmulr_rge0 _ tugt0) mulrBr mulrCA divff// 2!mulr1 -addrA subrr addr0; apply ltW.
by rewrite/conv be ce 2!scalerDr addrACA -scalerDl [_ + (1-_)]addrCA subrr addr0 scale1r -subr_eq0 opprD addrA subrr add0r oppr_eq0 2!scalerA -scalerDl mulrBl mul1r addrCA -mulrBr mulrAC -mulrA divff// mulr1 subrr scale0r.
Qed.

Lemma between_trans (a b c d e : Plane) :
  between c a b -> between d a b -> between e c d -> between e a b.
Proof.
move=>/between_conv[t]/andP[t01 /eqP->] /between_conv[u]/andP[u01 /eqP->] /between_conv[v]/andP[v01 /eqP->].
rewrite convACA// 2!convmm.
apply between_conv; exists ((t : R^o) <| v |> u); apply/andP; split=>//.
by apply in01_conv.
Qed.

End between.


Require Export Bvector ZArith Zdigits.
Require Import Program.Equality Znumtheory.
Require Export BDef.
Require Import Program.
Require Import Coq.micromega.Lia.

Set Implicit Arguments.
Set Strict Implicit.

(* useful for b2z lemmas in Zbits *)
Lemma bit_value_b2z :
  forall b, bit_value b = Z.b2z b.
Proof.
  destruct b; auto.
Qed.

Lemma bit_value_eq :
  forall b1 b2, bit_value b1 = bit_value b2 -> b1 = b2.
Proof.
  intros.
  apply Z.b2z_inj.
  generalize (bit_value_b2z b1) (bit_value_b2z b2).
  tauto.
Qed.

Lemma binary_value_eq :
  forall n (v1 v2 : Bvector n), binary_value v1 = binary_value v2 -> v1 = v2.
Proof.
  refine (@Vector.rect2 _ _ _ _ _); auto.
  intros ? ? ? H b1 b2 IH.
  repeat rewrite binary_value_Sn in *.
  assert (v1 = v2).
  destruct b1, b2; unfold bit_value in *; firstorder.
  subst v2.
  rewrite Z.add_cancel_r in *.
  f_equal.
  now apply bit_value_eq.
Qed.

Lemma binary_value_bound :
  forall n (v : Bvector n), binary_value v < two_power_nat n.
Proof.
  induction v as [| b n v' IHv].
  - firstorder.
  - rewrite two_power_nat_S.
    rewrite binary_value_Sn.
    destruct b; unfold bit_value; lia.
Qed.

Lemma binary_value_pos_bound :
  forall n (v : Bvector n), 0 <= binary_value v < two_power_nat n.
Proof.
  split.
  generalize (binary_value_pos n v); firstorder.
  apply binary_value_bound.
Qed.

Lemma two_power_nat_le_mono : forall (a b : nat),
  (a <= b)%nat -> two_power_nat a <= two_power_nat b.
Proof.
  intros.
  repeat rewrite two_power_nat_equiv.
  apply Z.pow_le_mono_r; lia.
Qed.

Lemma binary_value_mod_lt : forall m n (v : Bvector n),
  (n <= m)% nat ->
  binary_value v = (binary_value v) mod (two_power_nat m).
Proof.
  intros.
  apply eq_sym.
  apply Zmod_small.
  pose proof (binary_value_pos_bound v).
  firstorder.
  apply Z.lt_le_trans with (m:=two_power_nat n); auto.
  apply two_power_nat_le_mono.
  lia.
Qed.

Lemma binary_value_mod : forall n (v : Bvector n),
  binary_value v = (binary_value v) mod (two_power_nat n).
Proof.
  intros.
  now apply binary_value_mod_lt.
Qed.

(* signed representation *)

Lemma msb_Sn : forall n (v : Bvector (S n)) h,
  msb (h :: v) = msb v.
Proof.
  intros.
  unfold msb, testbit.
  rewrite binary_value_Sn.
  rewrite <- (Z.testbit_succ_r (binary_value v) h _); try lia.
  rewrite bit_value_b2z.
  f_equal; zify; lia.
Qed.

Lemma binary_value_range_msb_0 : forall n (v : Bvector (S n)),
  msb v = false -> binary_value v < two_power_nat n.
Proof.
  dependent destruction v.
  revert h.
  induction v as [| a n v' IHv]; intros.
  destruct h; firstorder; inversion H.
  rewrite msb_Sn, binary_value_Sn, two_power_nat_S in *.
  generalize (IHv h).
  destruct h; unfold bit_value; firstorder.
Qed.

Lemma binary_value_range_msb_1 : forall n (v : Bvector (S n)),
  msb v = true -> two_power_nat n <= binary_value v.
Proof.
  dependent destruction v.
  revert h.
  induction v as [| a n v' IHv]; intros.
  destruct h; firstorder.
  rewrite msb_Sn, binary_value_Sn, two_power_nat_S in *.
  destruct h; unfold bit_value; firstorder.
Qed.

Lemma two_compl_value_binary_value_msb_0 : forall n (v : Bvector (S n)),
  msb v = false -> two_compl_value v = binary_value v.
Proof.
  dependent destruction v.
  revert h.
  induction v as [| a n v' IHv]; intros.
  destruct h; firstorder; inversion H.
  repeat rewrite two_compl_value_Sn, binary_value_Sn.
  rewrite msb_Sn in *.
  generalize (IHv a).
  destruct h; unfold bit_value; firstorder.
Qed.

Lemma two_compl_value_binary_value_msb_1 : forall n (v : Bvector (S n)),
  msb v = true -> two_compl_value v = binary_value v - two_power_nat (S n).
Proof.
  dependent destruction v.
  revert h.
  induction v as [| a n v' IHv]; intros.
  destruct h; firstorder; inversion H.
  rewrite msb_Sn in *.
  generalize (IHv a).
  repeat rewrite binary_value_Sn.
  repeat rewrite two_power_nat_S.
  rewrite two_compl_value_Sn.
  destruct h; unfold bit_value; firstorder.
Qed.

Lemma two_compl_value_range_msb_0 : forall n (v : Bvector (S n)),
  msb v = false -> 0 <= two_compl_value v < two_power_nat n.
Proof.
  intros.
  generalize (two_compl_value_binary_value_msb_0 v).
  generalize (binary_value_range_msb_0 v).
  generalize (binary_value_pos_bound v).
  rewrite two_power_nat_S.
  firstorder.
Qed.

Lemma two_compl_value_range_msb_1 : forall n (v : Bvector (S n)),
  msb v = true -> - (two_power_nat n) <= two_compl_value v < 0.
Proof.
  intros.
  generalize (two_compl_value_binary_value_msb_1 v).
  generalize (binary_value_range_msb_1 v).
  generalize (binary_value_pos_bound v).
  rewrite two_power_nat_S.
  firstorder.
Qed.

Lemma two_compl_value_range : forall n (v : Bvector (S n)),
  - (two_power_nat n) <= two_compl_value v < two_power_nat n.
Proof.
  intros.
  destruct (sumbool_of_bool (msb v));
  generalize (two_compl_value_range_msb_0 v);
  generalize (two_compl_value_range_msb_1 v);
  firstorder.
Qed.

Lemma Zmod_add :
  forall a b c : Z, (a + b * c) mod c = a mod c.
Proof.
  intros.
  destruct (Z.eq_dec c 0).
  - f_equal.
    subst.
    lia.
  - now apply Z.mod_add.
Qed.

Lemma two_compl_value_mod : forall n (v : Bvector (S n)),
  binary_value v = (two_compl_value v) mod (two_power_nat (S n)).
Proof.
  intros.
  destruct (sumbool_of_bool (msb v)).
  - rewrite two_compl_value_binary_value_msb_1; auto.
    rewrite <- Z.add_opp_r.
    rewrite (Zmod_add _ (-1) _).
    apply binary_value_mod.
  - rewrite two_compl_value_binary_value_msb_0; auto.
    apply binary_value_mod.
Qed.

Lemma two_compl_value_binary_value_eqm : forall n (v : Bvector (S n)),
  eqm (two_power_nat (S n)) (two_compl_value v) (binary_value v).
Proof.
  intros.
  unfold eqm.
  rewrite <- two_compl_value_mod.
  apply binary_value_mod.
Qed.

Lemma Z_to_binary_mod :
  forall (n:nat) (z:Z),
  Z_to_binary n z = Z_to_binary n (z mod two_power_nat n).
Proof.
  induction n as [| n IHn]; simpl; auto.
  intros.
  (* normalize *)
  rewrite two_power_nat_equiv in *.
  repeat rewrite Z.div2_div.
  f_equal.
  - repeat rewrite <- Z.bit0_odd.
    rewrite Z.mod_pow2_bits_low; firstorder.
  - rewrite IHn.
    f_equal.
    apply Z.bits_inj'.
    unfold Z.eqf; intros i Hi.
    rewrite Z.div2_bits; auto.
    (* high bits are all 0s *)
    destruct (Z.lt_ge_cases i (Z.of_nat n)).
    + repeat rewrite Z.mod_pow2_bits_low; zify; firstorder.
      apply Z.div2_bits; auto.
    + repeat rewrite Z.mod_pow2_bits_high; zify; firstorder.
Qed.

Lemma Z_to_binary_to_Z_mod :
  forall n z, binary_value (Z_to_binary n z) = z mod two_power_nat n.
Proof.
  intros.
  rewrite Z_to_binary_mod.
  apply Z_to_binary_to_Z; generalize (Z_mod_lt z (two_power_nat n)); firstorder.
Qed.

Lemma Z_to_binary_eqm :
  forall n x y, eqm (two_power_nat n) x y <-> Z_to_binary n x =  Z_to_binary n y.
Proof.
  split; intros H.
  - rewrite Z_to_binary_mod.
    rewrite H.
    rewrite <- Z_to_binary_mod.
    trivial.
  - assert (binary_value (Z_to_binary n x) = binary_value (Z_to_binary n y)).
    congruence.
    now repeat rewrite Z_to_binary_to_Z_mod in *.
Qed.

(* another redundant function *)
Lemma Zmod2_div2 : forall z,
  Zmod2 z = Z.div2 z.
Proof.
  intros.
  destruct z; try (destruct p); auto.
  destruct p; auto.
Qed.

(* the two Z->Bvector conversions are equivalent *)
Lemma Z_to_two_compl_Z_to_binary : forall n z,
  Z_to_two_compl n z = Z_to_binary (S n) z.
Proof.
  induction n; intros.
  destruct z; auto.
  rewrite Z_to_two_compl_Sn_z.
  rewrite Z_to_binary_Sn_z.
  rewrite Zmod2_div2.
  rewrite IHn.
  auto.
Qed.

(* easier to use than two_compl_to_Z_to_two_compl *)
Lemma two_compl_to_Z_to_binary : forall n (v : Bvector (S n)),
  Z_to_binary (S n) (two_compl_value v) = v.
Proof.
  dependent destruction v.
  rewrite <- Z_to_two_compl_Z_to_binary.
  apply two_compl_to_Z_to_two_compl.
Qed.

(* Lemma two_compl_to_Z_to_binary_gt : forall m n (v : Bvector (S n)), *)
(*   (n <= m)%nat ->  *)
(*   Z_to_binary (S m) (two_compl_value v) = zero_cast (S m) v. *)
(* Proof. *)
(*   intros. *)
(*   dependent destruction v. *)
(*   rewrite <- Z_to_two_compl_Z_to_binary. *)
(*   pose proof two_compl_to_Z_to_two_compl. *)
(*   unfold zero_cast. *)
(*   rewrite binary_to_Z_to_binary. *)

Lemma bv_distr_sub:
  forall {n : nat} (i1 i2: Bvector n),
    binary_value i1 >= binary_value i2 ->
    binary_value (sub i1 i2) =
    binary_value i1 - binary_value i2.
Proof.
  unfold sub; intros.
  pose proof (binary_value_pos_bound i1).
  pose proof (binary_value_pos_bound i2).
  rewrite Z_to_binary_to_Z; lia.
Qed.

Lemma bv_distr_add:
  forall {n : nat} (i1 i2: Bvector n),
    binary_value i1 + binary_value i2 < two_power_nat n ->
    binary_value (add i1 i2) = binary_value i1 + binary_value i2.
Proof.
  unfold add; intros.
  pose proof (binary_value_pos_bound i1).
  pose proof (binary_value_pos_bound i2).
  rewrite Z_to_binary_to_Z; lia.
Qed.

Lemma bv_distr_mul :
  forall {n : nat} (i1 i2 : Bvector n),
    0 <= binary_value i1 * binary_value i2 < two_power_nat n ->
    binary_value (mul i1 i2) = binary_value i1 * binary_value i2.
Proof.
  unfold mul; intros.
  pose proof (binary_value_pos_bound i1).
  pose proof (binary_value_pos_bound i2).
  rewrite Z_to_binary_to_Z; auto.
  lia.
  lia.
Qed.


Require Import Coq.Strings.String.
Require Import Coq.Program.Basics.

(**************)
(* Categories *)
(**************)

Module Type Category.
  Parameter object : Set.
  Parameter morphism : object -> object -> Set.

  (**
   * Composition takes two morphisms f : b -> c and g : a -> b. It
   * returns a morphism from a -> c.
   * f o g can also be thought of as f after g, following the g morphism
   * and then the f morphism.
   *)
  Parameter compose :
    forall { a b c },
    morphism b c ->
    morphism a b ->
    morphism a c.

  (**
   * Composition must be associative.
   *)
  Axiom assoc :
    forall a b c d
    (f : morphism c d)
    (g : morphism b c)
    (h : morphism a b),
    compose f (compose g h) =
    compose (compose f g) h.

  (**
   * Every object must have an identity morphism.
   *)
  Axiom ident :
    forall a,
    exists (f : morphism a a),
    forall b (g : morphism a b) (h : morphism b a),
    compose g f = g /\
    compose f h = h.
End Category.

(************)
(* Functors *)
(************)

Module Type Functor (C D : Category).
  Parameter obj : C.object -> D.object.
  Parameter morph :
    forall { a b },
    C.morphism a b -> D.morphism (obj a) (obj b).

  (**
   * Functors preserve identity morphisms.
   *)
  Axiom ident :
    forall a,
    exists (f : (C.morphism a a)) (g : D.morphism (obj a) (obj a)),
    morph f = g.

  (**
   * Functors preserve composition.
   *)
  Axiom composition :
    forall a b c
      (f : C.morphism b a)
      (g : C.morphism c b),
    morph (C.compose f g) = D.compose (morph f) (morph g).
End Functor.

(* The identity functor is a functor. *)
Module IdentityFunctor (C : Category) : Functor C C.
  Definition obj (a : C.object) := a.
  Definition morph { a b } (f : C.morphism a b) := f.

  Lemma ident :
    forall a,
    exists (f : (C.morphism a a)) (g : C.morphism (obj a) (obj a)),
    morph f = g.
  Proof.
    intros.
    set (H := C.ident a).
    elim H. intros.
    exists x.
    eauto.
  Qed.

  Lemma composition :
    forall a b c
      (f : C.morphism b a)
      (g : C.morphism c b),
    morph (C.compose f g) = C.compose (morph f) (morph g).
  Proof.
    auto.
  Qed.
End IdentityFunctor.

(* The composition of two functors is a functor. *)
Module ComposedFunctors
  (B C D : Category)
  (F : Functor C D)
  (G : Functor B C) : Functor B D.
  Definition obj := compose F.obj G.obj.
  Definition morph {a : B.object} {b : B.object}
    := compose F.morph (@G.morph a b).

  Lemma ident :
    forall a,
    exists (f : (B.morphism a a)) (g : D.morphism (obj a) (obj a)),
    morph f = g.
  Proof.
    intros.
    set (H := G.ident a).
    elim H. intros.
    exists x.
    eauto.
  Qed.

  Lemma composition :
    forall a b c
      (f : B.morphism b a)
      (g : B.morphism c b),
    morph (B.compose f g) = D.compose (morph f) (morph g).
  Proof.
    intros.
    unfold morph, compose.
    replace (G.morph (B.compose f g)) with
      (C.compose (G.morph f) (G.morph g)).
    - refine (F.composition _ _ _ _ _).
    - symmetry.
      refine (G.composition _ _ _ _ _).
  Qed.
End ComposedFunctors.

(***************************)
(* Natural Transformations *)
(***************************)

Module Type NaturalTransformation (C D : Category) (F G : Functor C D).
  Parameter fn : forall { a b }, C.object -> D.morphism a b.

  Axiom commute :
    forall a b (f : C.morphism a b),
    D.compose (fn b) (F.morph f) =
    D.compose (G.morph f) (fn a).
End NaturalTransformation.

(*********)
(* Monad *)
(*********)

Module Type MonadWrapper (C : Category) (F : Functor C C).
  (* This structure is necessary because a module cannot be applied to *)
  (* another module application. *)
  Module IdFunctor := IdentityFunctor C.
  Module FSquared := ComposedFunctors C C C F F.
  Module Type Monad
    (Eta : NaturalTransformation C C IdFunctor F)
    (Mu : NaturalTransformation C C FSquared F).
    Axiom associative :
      forall x : C.object,
      @C.compose
        (F.obj (F.obj (F.obj x)))
        (F.obj (F.obj x))
        (F.obj x)
        (Mu.fn x)
        (F.morph (Mu.fn x)) =
      @C.compose
        (F.obj (F.obj (F.obj x)))
        (F.obj (F.obj x))
        (F.obj x)
        (Mu.fn x)
        (Mu.fn (F.obj x)).

    Axiom identity :
      forall (x : C.object),
      @C.compose
        (F.obj x)
        (F.obj (F.obj x))
        (F.obj x)
        (Mu.fn x)
        (Eta.fn (F.obj x)) =
      @C.compose
        (F.obj x)
        (F.obj (F.obj x))
        (F.obj x)
        (Mu.fn x)
        (F.morph (Eta.fn x)).
  End Monad.
End MonadWrapper.


From Coq Require Import ZArith Reals Psatz.
From Flocq Require Import Binary Bits Core.
From compcert.lib Require Import IEEE754_extra
 (* Coqlib Floats Zbits Integers*).

Require Import vcfloat.FPCore vcfloat.Reify vcfloat.Float_notations.
Set Bullet Behavior "Strict Subproofs".

Local Open Scope float32_scope.

Section WITHNANS.
Context {NANS: Nans}.

(** A single step of integration can modeled as either
(1) a transition matrix update to the vector (p,q) of momentum "p" and position "q", as
  given in "leapfrog_stepF"
-or-
(2) the "typical" velocity verlet scheme, as given in "leapfrog_stepF_ver" **)

(** Compute one time-step: given "ic" which is a pair of momentum "q" and position "p" ,
  calculate the new position and mometum after time "h" has elapsed. **)

Definition h : ftype Tsingle := 1 / 32.   (* Time-step: 1/32 of a second *)
Definition ω : ftype Tsingle := 1.

(* Linear force function *)
Definition F_alt (x : ftype Tsingle) : ftype Tsingle := -((ω*ω)*x).
Definition F (x : ftype Tsingle) : ftype Tsingle := -x.
(* We will use F rather than F_alt in the floating-point functional model,
  because the C program omits the multiplication by 1.0*1.0.
  You might think that (1.0*1.0)*x is the same as x, but we do
  not wish to use the identity (1.0*x=x)  _in the floats_;  we want
  to match exactly the computation that the C program does. *)

Definition state : Type := ftype Tsingle * ftype Tsingle.  (* momenum,position*)

(* Single step of Verlet integration *)
Definition leapfrog_stepF (h: ftype Tsingle) (ic : state) : state :=
  let p  := fst ic in let q := snd ic in
  let q' := (q + h * p) + (0.5 * (h * h)) * F q in
  let p' :=  p +  (0.5 * h) * (F q + F q') in
  (p', q').

(** Iterations **)

(* Main *)
Fixpoint iternF (h: ftype Tsingle) (ic: state) (n : nat): state:=
  match n with
  | 0%nat => ic
  | S n' => iternF  h (leapfrog_stepF h ic) n'
end.

(** Lemmas **)

Lemma lfstep_lfn:
  forall n ic ,
  leapfrog_stepF h (iternF h ic n) = iternF h (leapfrog_stepF h ic) n.
Proof.
induction n.
- auto.
- simpl. auto.
Qed.

Lemma step_iternF:
  forall n ic ,
  iternF h ic (S n) = leapfrog_stepF h (iternF h ic n).
Proof.
induction n.
- auto.
- intros. rewrite -> IHn. simpl.
replace (leapfrog_stepF h (iternF _ _ _ )) with (iternF h (leapfrog_stepF h ic) n).
  destruct (leapfrog_stepF h ic).
all: symmetry; apply lfstep_lfn.
Qed.

(* The initial conditions of the momentum "p" and position "q" specified for the integration scheme*)
Definition p_init: ftype Tsingle :=  0%F32.
Definition q_init: ftype Tsingle :=  1%F32.
Definition pq_init := (p_init, q_init).
Definition N : nat := 1000.

End WITHNANS.


Theorem iff_trans : forall P Q R : Prop,
  (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
  intros.
  destruct H as [Hpq Hqp].
  destruct H0 as [Hqr Hrq].
  split.
  - intros.
    apply Hqr.
    apply Hpq.
    apply H.
  - intros.
    apply Hqp.
    apply Hrq.
    apply H.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.PropExtensionality.

(* power set *)
Definition Pow T := T -> Prop.

Definition Subset {T} (s1 s2: Pow T) : Prop := forall t, s1 t -> s2 t.
Notation "s1 <: s2" := (Subset s1 s2)
                         (at level 30, no associativity).

Hint Unfold Subset.

Theorem subset_refl : forall T (s: Pow T), s <: s.
Proof.
  intros. unfold Subset. auto.
Qed.

Hint Resolve subset_refl.

Theorem subset_trans : forall T (a b c: Pow T), a <: b -> b <: c -> a <: c.
Proof.
  eauto.
Qed.

Hint Resolve subset_trans.

Definition Gen T := Pow T -> Pow T.
Hint Unfold Gen.

Definition monotone {T} (f: Gen T) : Prop := forall t1 t2, t1 <: t2 -> f t1 <: f t2.
Hint Unfold monotone.

Definition f_closed {T} (f: Gen T) (x: Pow T) := f x <: x.
Definition f_consistent {T} (f: Gen T) (x: Pow T) := x <: f x.
(* or [forall t, x t = f x t] because of prop_ext axiom. *)
Definition f_fixpoint {T} (f: Gen T) (x: Pow T) := forall t, x t <-> f x t.
Definition f_fixpoint' {T} (f: Gen T) (x: Pow T) := x = f x.

Hint Unfold f_closed.
Hint Unfold f_consistent.
Hint Unfold f_fixpoint.

Lemma fixpoint_ext : forall T (f: Gen T) x, f_fixpoint' f x  <-> f_fixpoint f x.
Proof.
  unfold f_fixpoint, f_fixpoint'.
  intros. split.
  - intros. split; intro. rewrite <- H. auto. rewrite H. auto.
  - intros.
    apply functional_extensionality. intro t.
    apply propositional_extensionality. specialize H with t. destruct H.
    split; intro; auto.
Qed.

(* let's give it a try *)
Theorem closed_consistent_implies_fixpoint : forall T (f: Gen T) (x: Pow T),
    f_closed f x /\ f_consistent f x -> f_fixpoint f x.
Proof.
  intros.
  destruct H. unfold f_closed in *. unfold f_consistent in *. unfold f_fixpoint.
  unfold Subset in *.
  intros.
  pose proof H t.
  pose proof H0 t.
  split; auto.
Qed.

Hint Resolve closed_consistent_implies_fixpoint.

Theorem fixpoint_implies_closed_consistent : forall T (f: Gen T) (x: Pow T),
    f_fixpoint f x -> f_closed f x /\ f_consistent f x.
Proof.
  intros.
  unfold f_closed in *. unfold f_consistent in *. unfold f_fixpoint in *.
  split; unfold Subset.
  - intros. apply H. auto.
  - intros. apply H. auto.
Qed.

Hint Resolve fixpoint_implies_closed_consistent.

Lemma f_consistent_recursive : forall T (f: Gen T) (x: Pow T),
    monotone f -> f_consistent f x -> f_consistent f (f x).
Proof.
  unfold f_consistent.
  intros.
  intro.
  intro.
  eapply H with x.
  apply H0. apply H1.
Qed.

Definition Intersect {T} (p: Pow T -> Prop) : Pow T :=
  (fun t => forall x, p x -> x t).

Definition Union {T} (p: Pow T -> Prop) : Pow T :=
  (fun t => exists x, p x /\ x t).

Hint Unfold Intersect. Hint Unfold Union.

Lemma Intersect_Subset : forall T {p: Pow T -> Prop} x, p x -> Intersect p <: x.
Proof.
  intros.
  unfold Intersect, Subset.
  intros.
  apply H0.
  apply H.
Qed.

Lemma Union_Subset : forall T {p: Pow T -> Prop} x, p x -> x <: Union p.
Proof. eauto. Qed.

Lemma Intersect_f_closed : forall T (f: Gen T),
    monotone f -> f_closed f (Intersect (f_closed f)).
Proof.
  intros.
  repeat intro.
  apply H1. eapply H.
  apply Intersect_Subset.
  apply H1. apply H0. Qed.

Lemma Union_f_consistent : forall T (f: Gen T),
    monotone f -> f_consistent f (Union (f_consistent f)).
Proof.
  intros.
  intro. intro.
  unfold Union in *. destruct H0. destruct H0.
  apply H with x. apply Union_Subset.
  apply H0. unfold f_consistent in H0. unfold Subset in H0.
  auto.
Qed.

Lemma knaster_tarski_1_fixpoint : forall T (f: Gen T),
    monotone f -> f_consistent f (Intersect (f_closed f)).
Proof.
  intros T f Hmono.
  unfold f_consistent.
  repeat intro.
  apply H.
  apply Hmono.
  clear H.
  repeat intro.
  apply H0.
  eapply Hmono.
  apply Intersect_Subset.
  apply H0. apply H.
Qed.

Lemma knaster_tarski_2_fixpoint : forall T (f: Gen T),
    monotone f -> f_closed f (Union (f_consistent f)).
Proof.
  intros T f Hmono.
  unfold f_closed.
  repeat intro.
  exists (f (Union (f_consistent f))).
  split.
  - repeat intro.
    apply f_consistent_recursive; auto.
    apply Union_f_consistent. auto.
  - apply H.
Qed.

Definition IsMin {T} (p: Pow T -> Prop) (x: Pow T) : Prop :=
  p x /\ forall x', p x' -> x <: x'.
Definition IsMax {T} (p: Pow T -> Prop) (x: Pow T) : Prop :=
  p x /\ forall x', p x' -> x' <: x.

Lemma knaster_tarski_1 : forall T (f: Gen T),
    monotone f -> IsMin (f_fixpoint f) (Intersect (f_closed f)).
Proof.
  intros.
  unfold IsMin.
  split.
  - apply closed_consistent_implies_fixpoint. split.
    + apply Intersect_f_closed; easy.
    + apply knaster_tarski_1_fixpoint; easy.
  - intros.
    apply Intersect_Subset.
    apply fixpoint_implies_closed_consistent in H0. easy.
Qed.

Lemma knaster_tarski_2 : forall T (f: Gen T),
    monotone f -> IsMax (f_fixpoint f) (Union (f_consistent f)).
Proof.
  intros.
  unfold IsMax.
  split.
  - apply closed_consistent_implies_fixpoint. split.
    + apply knaster_tarski_2_fixpoint; easy.
    + apply Union_f_consistent; easy.
  - intros.
    apply Union_Subset.
    apply fixpoint_implies_closed_consistent in H0. easy.
Qed.

Theorem knaster_tarski: forall T (f: Gen T),
    monotone f ->
    IsMin (f_fixpoint f) (Intersect (f_closed f)) /\
    IsMax (f_fixpoint f) (Union (f_consistent f)).
Proof.
  auto using knaster_tarski_1, knaster_tarski_2.
Qed.

Lemma min_unique : forall T (p: Pow T -> Prop) (x1 x2: Pow T),
    IsMin p x1 -> IsMin p x2 -> forall t, x1 t <-> x2 t.
Proof.
  unfold IsMin.
  unfold Subset.
  intros. destruct H; destruct H0.
  split; intro.
  - apply H1; eauto.
  - apply H2; eauto.
Qed.

Lemma max_unique : forall T (p: Pow T -> Prop) (x1 x2: Pow T),
    IsMax p x1 -> IsMax p x2 -> forall t, x1 t <-> x2 t.
Proof.
  unfold IsMax.
  unfold Subset.
  intros. destruct H; destruct H0.
  split; intro.
  - apply H2 with x1; eauto.
  - apply H1 with x2; eauto.
Qed.

Definition MinFix {T} (f: Gen T) : Pow T := Intersect (f_closed f).
Definition MaxFix {T} (f: Gen T) : Pow T := Union (f_consistent f).

Corollary principle_of_induction : forall T (f: Gen T) (x : Pow T),
    monotone f -> f_closed f x -> MinFix f <: x.
Proof.
  intros.
  apply Intersect_Subset.
  auto.
Qed.

Corollary principle_of_coinduction : forall T (f: Gen T) (x : Pow T),
    monotone f -> f_consistent f x -> x <: MaxFix f.
Proof.
  intros.
  apply Union_Subset.
  auto.
Qed.

Inductive TypeTreeNode := TNTop | TNArrow | TNPair.

(* a tree is a partial function from a list of branches to a node
   branch mapping: false => left, true => right
 *)
Definition Tree : Type := list bool -> option TypeTreeNode.

Definition is_some {T} (v: option T) : Prop := match v with
                                            | Some _ => True
                                            | _ => False
                                            end.

Import ListNotations.

(* Assert whether or not t is defined for input pi *)
Inductive tree_defined : Tree -> list bool -> Prop :=
| TD_nil : forall t, tree_defined t nil
(* i simplified the rule from the book to an equivalent form *)
| TD_split : forall t p1 s, tree_defined t (p1 ++ [s]) -> tree_defined t p1
| TD_arrow : forall t p1 s, t p1 = Some(TNArrow) -> tree_defined t (p1 ++ cons s nil)
| TD_pair  : forall t p1 s, t p1 = Some(TNPair) -> tree_defined t (p1 ++ cons s nil)
.

Definition tree_valid (t: Tree) : Prop :=
  forall path, tree_defined t path <-> is_some (t path).

(* I used an alternative definition for a tree to be finite:

  if a tree is undefined after a given path length, then this tree is finite.
 *)
Definition tree_finite (t: Tree): Prop :=
  exists n, forall p, n <= length p -> t p = None.

Definition tree_infinite (t: Tree): Prop := ~(tree_finite t).

(* The tree: (Top -> Top, Top) *)
Example tree1 : Tree :=
  fun p => match p with
        | [] => Some TNPair
        | [false] => Some TNArrow
        | [false; _] => Some TNTop
        | [true] => Some TNTop
        | _ => None
        end.

Inductive TypeTree : Type :=
| TTop : TypeTree
| TArrow (l r: TypeTree) : TypeTree
| TPair (l r: TypeTree) : TypeTree.

Fixpoint depth(t: TypeTree) : nat :=
  match t with
  | TTop => 1
  | TArrow a b => max (depth a) (depth b)
  | TPair a b => max (depth a) (depth b)
  end.

Definition FiniteTree (t: TypeTree) : Prop := exists d, depth t <= d.
Definition InfiniteTree (t: TypeTree) : Prop := ~(FiniteTree t).

Definition relation (T: Type) := Pow (T * T).

Definition TR {U} (R: relation U) : relation U :=
  fun pair => match pair with
           | (x, y) => exists z, R (x, z) /\ R (z, y)
           end.

Definition Transitive {U} (R: relation U) := TR R <: R.

Lemma fixpoint_transitive :
  forall U (F : relation U -> relation U),
    monotone F ->
    (forall R, TR(F(R)) <: F(TR(R))) ->
    Transitive (MaxFix F).
Proof.
  intros.
  intro. intro.
  assert (f_fixpoint' F (MaxFix F)).
  { apply fixpoint_ext.
    apply knaster_tarski_2.
    apply H.
  }
  assert (f_consistent F (TR (MaxFix F))).
  { intro. intro.
    apply H0.
    rewrite <- H2. apply H3.
  }
  apply principle_of_coinduction in H3; auto.
Qed.


(* Least-significant bit encoding and decoding of numbers. *)

Require Import Bool BinNat BinPos Nnat.
From larith Require Import A_setup B1_utils.

Open Scope N.

Fixpoint pbits (p : positive) : list bool :=
  match p with
  | xI q => true :: pbits q
  | xO q => false :: pbits q
  | xH   => [true]
  end.

Definition bits (n : N) :=
  match n with
  | 0%N     => []
  | N.pos p => pbits p
  end.

Fixpoint bnum (bits : list bool) : N :=
  match bits with
  | []      => 0
  | b :: bs =>
    match (bnum bs) with
    | 0       => if b then 1 else 0
    | N.pos p => N.pos (if b then p~1 else p~0)
    end
  end.

Theorem bnum_bits_id n :
  bnum (bits n) = n.
Proof.
destruct n; simpl. easy.
induction p; simpl.
1,2: rewrite IHp. all: easy.
Qed.

Theorem bnum_padding b :
  bnum (b ++ [false]) = bnum b.
Proof.
induction b; simpl.
easy. now rewrite IHb.
Qed.

Theorem bnum_cons x xs :
  bnum (x :: xs) = bnum [x] + 2 * (bnum xs).
Proof.
simpl; now destruct x, (bnum xs).
Qed.

Corollary bnum_cons_eq_one xs :
  bnum (true :: xs) = 1 <-> bnum xs = 0.
Proof.
rewrite bnum_cons; simpl bnum.
destruct (bnum xs); easy.
Qed.

Theorem bnum_cons_compare x xs y ys :
  bnum (x :: xs) ?= bnum (y :: ys) =
  Pos.switch_Eq (Bool.compare x y) (bnum xs ?= bnum ys).
Proof.
simpl; destruct x, y, (bnum xs), (bnum ys); simpl; try easy.
1: rewrite Pos.compare_xI_xI. 4: rewrite Pos.compare_xO_xO.
3: apply Pos.compare_xO_xI. 2: apply Pos.compare_xI_xO.
all: now destruct (p ?= p0)%positive.
Qed.

Corollary bnum_cons_eq x xs y ys :
  bnum (x :: xs) = bnum (y :: ys) <-> x = y /\ bnum xs = bnum ys.
Proof.
rewrite <-?N.compare_eq_iff, bnum_cons_compare.
now destruct x, y, (bnum xs ?= bnum ys).
Qed.

Corollary bnum_cons_le x xs y ys :
  bnum (x :: xs) <= bnum (y :: ys) <->
  bnum xs < bnum ys \/ (bnum xs = bnum ys /\ Bool.le x y).
Proof.
rewrite <-?N.compare_le_iff, <-N.compare_lt_iff;
rewrite <-N.compare_eq_iff, bnum_cons_compare.
destruct x, y, (bnum xs ?= bnum ys) eqn:H; simpl.
all: try (rewrite and_remove_r; [|easy]).
all: try (rewrite or_remove_r; [|easy]).
all: try (rewrite or_comm, or_remove_r; [|easy]).
all: try easy.
Qed.

Corollary bnum_cons_lt x xs y ys :
  bnum (x :: xs) < bnum (y :: ys) <->
  bnum xs < bnum ys \/ (bnum xs = bnum ys /\ Bool.lt x y).
Proof.
rewrite <-?N.compare_lt_iff, <-N.compare_eq_iff, bnum_cons_compare.
destruct x, y, (bnum xs ?= bnum ys) eqn:H; simpl.
all: try (rewrite and_remove_r; [|easy]).
all: try (rewrite or_remove_r; [|easy]).
all: try (rewrite or_comm, or_remove_r; [|easy]).
all: try easy.
Qed.

Close Scope N.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor.
Require Import Functor.Functor_Ops.

Local Open Scope functor_scope.

Section Functor_Properties.
  Context {C C' : Category} (F : C –≻ C').

  Local Open Scope object_scope.
  Local Open Scope isomorphism_scope.
  Local Open Scope morphism_scope.

  (** A functor is said to be injective if its object map is. *)
  Definition Injective_Func := ∀ (c c' : Obj), F _o c = F _o c' → c = c'.

  (** A functor is said to be essentially injective if its object map maps
equal objects to isomorphic objects in the codomain category. *)
  Definition Essentially_Injective_Func := ∀ (c c' : Obj), F _o c = F _o c' → c ≃ c'.

  (** A functor is said to be surjective if its object map is. *)
  Definition Surjective_Func := ∀ (c : Obj), {c' : Obj | F _o c' = c}.

  (** A functor is said to be essentially surjective if for each object in the
codomain category there is an aobject in the domain category that is mapped
to an aobject isomorphic to it. *)
  Definition Essentially_Surjective_Func := ∀ (c : Obj), {c' : Obj & F _o c' ≃ c}.

  (** A functor is said to be faithful if its arrow map is injective. *)
  Definition Faithful_Func := ∀ (c c' : Obj) (h h' : (c –≻ c')%morphism),
      F _a h = F _a h' → h = h'.

  (** A functor is said to be full if its arrow map is surjective. *)
  Definition Full_Func := ∀ (c1 c2 : Obj) (h' : ((F _o c1) –≻ (F _o c2))%morphism),
      {h : (c1 –≻ c2)%morphism | F _a h = h'}
  .

  Local Ltac Inv_FTH :=
    match goal with
      [fl : Full_Func |- _] =>
      progress (
          repeat
            match goal with
              [|- context [(F _a (proj1_sig (fl _ _ ?x)))]] =>
              rewrite (proj2_sig (fl _ _ x))
            end
        )
    end
  .

  Local Hint Extern 1 => Inv_FTH.

  Local Hint Extern 1 => rewrite F_compose.

  Local Hint Extern 1 =>
  match goal with
    [fth : Faithful_Func |- _ = _ ] => apply fth
  end
  .

  Local Obligation Tactic := basic_simpl; auto 6.

  (** Any fully-faithful functor is essentially surjective. *)
  Program Definition Fully_Faithful_Essentially_Injective (fth : Faithful_Func) (fl : Full_Func)
    : Essentially_Injective_Func
    :=
      fun c c' eq =>
        {|
          iso_morphism :=
            proj1_sig (
                fl
                  _
                  _
                  match eq in _ = y return
                        (_ –≻ y)%morphism
                  with
                    idpath => id (F _o c)
                  end
              );
          inverse_morphism :=
            proj1_sig (
                fl
                  _
                  _
                  match eq in _ = y return
                        (y –≻ _)%morphism
                  with
                    idpath => id (F _o c)
                  end
              )
        |}
  .

  (** Any fully-faithful functor is conservative.

A conservative functor is one for which we have to objects of the domain category are isomorphic if their images are ismorphic. *)
  Program Definition Fully_Faithful_Conservative (fth : Faithful_Func) (fl : Full_Func)
    : ∀ (c c' : Obj), F _o c ≃ F _o c' → c ≃ c' :=
    fun c c' I =>
      {|
        iso_morphism := proj1_sig (fl _ _ I);
        inverse_morphism := proj1_sig (fl _ _ (I⁻¹))
      |}
  .

End Functor_Properties.

(** Functors Preserve Isomorphisms. *)
Section Functors_Preserve_Isos.
  Context {C C' : Category} (F : C –≻ C') {a b : C} (I : (a ≃≃ b ::> C)%isomorphism).

  Program Definition Functors_Preserve_Isos : (F _o a ≃ F _o b)%isomorphism :=
    {|
      iso_morphism := (F _a I)%morphism;
      inverse_morphism := (F _a (I⁻¹))%morphism
    |}.

End Functors_Preserve_Isos.

Section Embedding.
  Context (C C' : Category).

  (**
    An embedding is a functor that is faully-faithful. Such a functor is necessarily essentially injective and conservative, i.e., if F _O c ≃ F _O c' then c ≃ c'.
   *)

  Record Embedding : Type :=
    {
      Emb_Func : C –≻ C';

      Emb_Faithful : Faithful_Func Emb_Func;

      Emb_Full : Full_Func Emb_Func
    }.

  Coercion Emb_Func : Embedding >-> Functor.

  Definition Emb_Essent_Inj (E : Embedding) := Fully_Faithful_Essentially_Injective (Emb_Func E) (Emb_Faithful E) (Emb_Full E).

  Definition Emb_Conservative (E : Embedding) := Fully_Faithful_Conservative (Emb_Func E) (Emb_Faithful E) (Emb_Full E).

End Embedding.

Arguments Emb_Func {_ _} _.
Arguments Emb_Faithful {_ _} _ {_ _} _ _ _.
Arguments Emb_Full {_ _} _ {_ _} _.


Set Implicit Arguments.
Unset Strict Implicit.
Require Export Setoid Morphisms.
Require Export Coq.Program.Basics.
From Undecidability.FOL Require Import FullSyntax.
From Equations Require Import Equations.
From Coq Require Import Arith Lia List Program.Equality.

Class HeytingAlgebra : Type :=
  {
    H : Type ;

    R : H -> H -> Prop ;
    Rref : Reflexive R ;
    Rtra : Transitive R ;

    Bot : H ;
    Meet : H -> H -> H ;
    Join : H -> H -> H ;
    Impl : H -> H -> H ;

    Bot1 : forall u, R Bot u ;
    (*Bot2 : ~ R (Imp Bot Bot) Bot ;*)
    Meet1 : forall u v w, R w u /\ R w v <-> R w (Meet u v) ;
    Join1 : forall u v w, R u w /\ R v w <-> R (Join u v) w ;
    Impl1 : forall u v w, R (Meet w u) v <-> R w (Impl u v) ;
  }.

Coercion H : HeytingAlgebra >-> Sortclass.
Notation "s '<=' t" := (R s t) (at level 70).

(* Registering the relation R of Heyting algebras as preorder for rewriting *)
#[global]
Instance preorder_HA (HA : HeytingAlgebra) :
  PreOrder (@R HA).
Proof.
  split. apply Rref. apply Rtra.
Qed.

(* Simple properties of Heyting algebras *)

Section HAProperty.

  Context { HA : HeytingAlgebra }.
  Implicit Type u v w : HA.

  Definition eqH u v := u <= v /\ v <= u.

  Lemma Meet2 u v :
    Meet u v <= u.
  Proof.
    now apply (Meet1 u v).
  Qed.

  Lemma Meet3 u v :
    Meet u v <= v.
  Proof.
    now apply (Meet1 u v).
  Qed.

  Lemma Meet_com u v :
    Meet u v <= Meet v u.
  Proof.
    apply Meet1; split; auto using Meet2, Meet3.
  Qed.

  Lemma Meet_left x y z :
    x <= y -> Meet z x <= Meet z y.
  Proof.
    intros H. apply Meet1. split.
    - apply Meet2.
    - rewrite <- H. apply Meet3.
  Qed.

  Definition Top := Impl Bot Bot.

  Lemma Top1 u :
    u <= Top.
  Proof.
    apply Impl1, Meet3.
  Qed.

  Lemma Join2 u v :
    u <= Join u v.
  Proof.
    now apply (Join1 u v).
  Qed.

  Lemma Join3 u v :
    v <= Join u v.
  Proof.
    now apply (Join1 u v).
  Qed.

  Lemma Join_com u v :
    eqH (Join u v) (Join v u).
  Proof.
    split; apply Join1; split; auto using Join2, Join3.
  Qed.

  Lemma Imp2 u v :
    Meet (Impl u v) u <= v.
  Proof.
    apply Impl1, Rref.
  Qed.

  Lemma Meet_assoc u v w :
    Meet u (Meet v w) <= Meet (Meet u v) w.
  Proof.
    simpl. apply Meet1. split.
    - apply Meet1. split.
      + apply Meet2.
      + now rewrite Meet3, Meet2.
    - now rewrite Meet3, Meet3.
  Qed.

  Lemma Meet_extend x y :
    x <= y -> x <= Meet x y.
  Proof.
    intros H. apply Meet1. now split.
  Qed.

  Lemma Imp_bot x y :
    y <= Impl Bot x.
  Proof.
    apply Impl1. rewrite Meet3. apply Bot1.
  Qed.

  Lemma meet_join_distr x y z :
    Meet x (Join y z) <= Join (Meet x y) (Meet x z).
  Proof.
    rewrite Meet_com, Impl1, <- Join1. split.
    - rewrite <- Impl1, Meet_com. apply Join2.
    - rewrite <- Impl1, Meet_com. apply Join3.
  Qed.

  Lemma meet_join_expansion x y z :
    x <= Join y z -> x <= Join (Meet x y) (Meet x z).
  Proof.
    intros H. rewrite <- meet_join_distr.
    apply Meet1. split; trivial. reflexivity.
  Qed.

  Definition equiv_HA x y := x <= y /\ y <= x.
  Notation "x ≡ y" := (equiv_HA x y) (at level 40).

  Global Instance subrelation_HA : subrelation equiv_HA R.
  Proof.
    firstorder.
  Qed.

  Global Instance subrelation_HA_flip : subrelation equiv_HA (flip R).
  Proof.
    firstorder.
  Qed.

  Global Instance equiv_HA_refl : Equivalence equiv_HA.
  Proof.
    split.
    - split; reflexivity.
    - split; eapply H0.
    - split. now rewrite H0, H1. now rewrite <- H1, <- H0.
  Qed.

  Hint Resolve Meet2 Meet3 Join2 Join3 Impl1 Imp2 : core.

  Global Instance proper_HA_Meet : Proper (equiv_HA ==> equiv_HA ==> equiv_HA) Meet.
  Proof.
    intros ? ? ? ? ? ?.
    split.
    - rewrite <- Meet1, <- H0, <- H1; eauto.
    - rewrite <- Meet1, H0, H1; eauto.
  Qed.

  Global Instance proper_HA_Join : Proper (equiv_HA ==> equiv_HA ==> equiv_HA) Join.
  Proof.
    intros ? ? ? ? ? ?.
    split.
    - rewrite <- Join1, H0, H1; eauto.
    - rewrite <- Join1, <- H0, <- H1; eauto.
  Qed.

  Global Instance proper_HA_Impl : Proper (equiv_HA ==> equiv_HA ==> equiv_HA) Impl.
  Proof.
    intros ? ? ? ? ? ?.
    split.
    - rewrite <- Impl1. rewrite <- H1, <- H0. eauto.
    - rewrite <- Impl1. rewrite H1, H0. eauto.
  Qed.

End HAProperty.

Notation is_inf P inf :=
  (forall u, (forall v, P v -> u <= v) <-> u <= inf).

Notation is_sup P sup :=
  (forall u, (forall v, P v -> v <= u) <-> sup <= u).
#[global]
Hint Resolve Meet2 Meet3 : core.

(* ** Complete Heyting Algebras *)

Class CompleteHeytingAlgebra : Type :=
  {
    HA : HeytingAlgebra ;
    Inf : (HA -> Prop) -> HA ;
    Inf1 : forall (P : HA -> Prop), is_inf P (Inf P) ;
  }.

Coercion HA : CompleteHeytingAlgebra >-> HeytingAlgebra.

Section CHAProperty.

  Context { HA : CompleteHeytingAlgebra }.
  Implicit Type u v w : HA.
  Implicit Type P : HA -> Prop.

  Lemma Inf2 P u :
    P u -> Inf P <= u.
  Proof.
    now apply Inf1.
  Qed.

  Definition Inf_indexed I (F : I -> HA) :=
    Inf (fun u => exists i, equiv_HA u (F i)).

  Lemma Inf_indexed1 I (F : I -> HA) u :
    (forall i, u <= F i) <-> u <= Inf_indexed F.
  Proof.
    unfold Inf_indexed. rewrite <- Inf1. split; intros H.
    - intros v [i ->]. now apply H.
    - intros i. apply H. now exists i.
  Qed.

  Definition Sup P :=
    Inf (fun u => forall v, P v -> v <= u).

  Lemma Sup2 P u :
    P u -> u <= Sup P.
  Proof.
    intros H. apply Inf1. firstorder.
  Qed.

  Lemma Sup1 P :
    is_sup P (Sup P).
  Proof.
    split; intros H.
    - now apply Inf2.
    - intros v H' % Sup2. now rewrite H'.
  Qed.

  Definition Sup_indexed I (F : I -> HA) :=
    Sup (fun u => exists i, equiv_HA u (F i)).

  Lemma Sup_indexed1 I (F : I -> HA) u :
    (forall i, F i <= u) <-> Sup_indexed F <= u.
  Proof.
    unfold Sup_indexed. rewrite <- (Sup1 _ u). split; intros H.
    - intros v [i ->]. now apply H.
    - intros i. apply H. now exists i.
  Qed.

  Lemma meet_sup_distr x I (F : I -> HA) :
    Meet x (Sup_indexed F) <= Sup_indexed (fun i => Meet x (F i)).
  Proof.
    rewrite Meet_com, Impl1, <- Sup_indexed1.
    intros i. rewrite <- Impl1, Meet_com.
    apply Sup2. now exists i.
  Qed.

  Lemma meet_sup_expansion x I (F : I -> HA) :
    x <= Sup_indexed F -> x <= Sup_indexed (fun i => Meet x (F i)).
  Proof.
    intros H. rewrite <- meet_sup_distr.
    apply Meet1. split; trivial. reflexivity.
  Qed.

  Instance proper_HA_Inf : Proper (pointwise_relation _ iff ==> equiv_HA) Inf.
  Proof.
    intros ? ? ?.
    split.
    - rewrite <- Inf1. intros. eapply H0 in H1.
      now eapply Inf2.
    - rewrite <- Inf1. intros. eapply H0 in H1.
      now eapply Inf2.
  Qed.

  Instance proper_HA_Sup : Proper (pointwise_relation _ iff ==> equiv_HA) Sup.
  Proof.
    intros ? ? ?. unfold Sup. eapply proper_HA_Inf.
    intros ?.
    split; firstorder.
  Qed.

  Instance proper_HA_Sup_indexed I : Proper (pointwise_relation _ equiv_HA ==> equiv_HA) (@Sup_indexed I).
  Proof.
    intros ? ? ?. unfold Sup_indexed. eapply proper_HA_Sup.
    split.
    - firstorder subst. exists x0. split. rewrite H1. eapply H0. rewrite <- H2. eapply H0.
    - firstorder subst. exists x0. split. rewrite H1. eapply H0. rewrite <- H2. eapply H0.
  Qed.

  Instance proper_HA_Inf_indexed I : Proper (pointwise_relation _ equiv_HA ==> equiv_HA) (@Inf_indexed I).
  Proof.
    intros ? ? ?. unfold Inf_indexed. eapply proper_HA_Inf.
    split.
    - firstorder subst. exists x0. split. rewrite H1. eapply H0. rewrite <- H2. eapply H0.
    - firstorder subst. exists x0. split. rewrite H1. eapply H0. rewrite <- H2. eapply H0.
  Qed.

  Notation "A <~> B" := ((A -> B) * (B -> A))%type (at level 85) : type_scope.

End CHAProperty.

Section CHAEval.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Context { HA : CompleteHeytingAlgebra }.

  Variable hinter_Pr : forall (P : Σ_preds), Vector.t term (ar_preds P) -> HA.

  Obligation Tactic := intros; subst; cbn; try lia.

  Derive NoConfusion for falsity_flag.

  Equations hsat (phi : form) : HA by wf (size phi) lt :=
    hsat (atom P v) := hinter_Pr v ;
    hsat ⊥ := Bot ;
    hsat (phi → psi) := Impl (hsat phi) (hsat psi) ;
    hsat (phi ∧ psi) := Meet (hsat phi) (hsat psi) ;
    hsat (phi ∨ psi) := Join (hsat phi) (hsat psi) ;
    hsat (∀ phi) := Inf_indexed (fun t => hsat (phi [t..])) ;
    hsat (∃ phi) := Sup_indexed (fun t => hsat (phi [t..])).
  Next Obligation.
    rewrite subst_size. econstructor.
  Qed.
  Next Obligation.
    rewrite subst_size. econstructor.
  Qed.

  Definition hsat_L A : HA :=
    Inf (fun x => exists phi, In phi A /\ x = hsat phi).

  Lemma top_hsat_L :
    Top <= hsat_L nil.
  Proof.
    apply Inf1. intros v [phi [[] _]].
  Qed.

End CHAEval.

(* ** Boolean Semantics *)

Definition boolean (HA : HeytingAlgebra) :=
  forall x y : HA, Impl (Impl x y) x <= x.


(* ================================================================== *)
(* ==================== Programming and proving ===================== *)
(* ================================================================== *)

Require Import ZArith.

Require Import List.

Require Import Lia.

Set Implicit Arguments.

Fixpoint elem (a:Z) (l:list Z) {struct l} : bool :=   (* !!!!!!!!!!! *)
    match l with
      | nil => false
      | cons x xs => if Z.eq_dec x a then true else (elem a xs)
    end.

Proposition elem_corr : forall (a:Z) (l1 l2:list Z),
                  elem a (app l1 l2) = orb (elem a l1) (elem a l2).
Proof.
  induction l1.
  - intros. simpl. reflexivity.
  - intros. simpl.
    elim (Z.eq_dec a0 a).
    + intros. simpl.  reflexivity.
    + auto.
Qed.

(* Exercise: *)
(* Sugestion: use de previous proposition *)
Lemma ex : forall (a:Z) (l1 l2:list Z), elem a (app l1 (cons a l2)) = true.
Proof.
  intros. (*Este resultado encaixa na prop elem_corr*)
  rewrite(elem_corr a l1 (a::l2)).
  simpl. elim(Z.eq_dec).
  - Search "||". intros. apply Bool.orb_true_r.
  - intros. contradiction.
Qed.
(* ================================================================== *)
(* ======================== Partiality ============================== *)

(* defining the function head *)

Definition head (A:Type) (l:list A) : l<>nil -> A.
(* "refine term" tactic applies to any goal. It behaves like exact with
a big difference: the user can leave some holes (denoted by _ or (_:type))
in the term.
refine will generate as many subgoals as there are holes in the term. *)
  refine (
  match l as l' return l'<>nil -> A with
  | nil => fun H => _
  | cons x xs => fun H => x
  end ).
  contradiction.
Defined.

Print head. Print False_rect.
Print Implicit head.

(* head precondition *)
Definition headPre (A:Type) (l:list A) : Prop := l<>nil.

(* the specification of head *)
Inductive headRel (A:Type) (x:A) : list A -> Prop :=
  headIntro : forall l, headRel x (cons x l).

Print Implicit headRel.

(* we can prove the correctness of head w.r.t. its specification *)
(* note that (head p) is the same as (@head A l p) since A and l are implicit arguments *)
Lemma head_correct : forall (A:Type) (l:list A) (p:headPre l), headRel (head  p) l.
Proof.
  destruct l.
  - intro H. elim H. reflexivity.
  - intros.  destruct l.
    + simpl. apply headIntro.
    + simpl. constructor. (*apply headIntro tb pode ser usado*)
    (* change de proof script so that you can see effect each tactic *)
Qed.

(* ================================================================== *)
(* ==================== Program Extraction ========================== *)

Require Extraction.  (* the extraction framework must be loaded explicitly *)

(* we can convert to Haskell the function head defined *)
Extraction Language Haskell.

Extraction head.

Extraction False_rect.
Extraction Inline False_rect.  (* will make the code more readable *)
Extraction head.

Recursive Extraction head.
Extraction "exemplo1" head.

Extract Inductive list => "[]" [ "[]" "(:)" ].

Recursive Extraction head.
Extraction "exemplo2" head.

(* We have just followed the "weak specification" approach:
   we defined the function and add, as a companion lemma, that the function
   satisfies its specification.
*)

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

(* Instead of this approach, we can give a "strong specification" of a
   function  (using specification types), and extract the function from
   its proof (the prove that the specification is inhabited).
*)

(* An inductive relation "x is the last element of list l" *)
Inductive Last (A:Type) (x:A) : list A -> Prop :=
| last_base : Last x (cons x nil)
| last_step : forall l y, Last x l -> Last x (cons y l).

Theorem last_correct : forall (A:Type) (l:list A), l<>nil -> { x:A | Last x l }.
Proof.
  induction l.
  - intro H. elim H. reflexivity.
  - intros. destruct l.
    + exists a. constructor.
    + elim IHl.
      * intros. exists x. constructor. assumption.
      * discriminate.
Qed.

Recursive Extraction last_correct.

Extraction Inline False_rect sig_rect list_rect.

Recursive Extraction last_correct.

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

(* Following this alternative approach we can give a "strong specification" of
   function head (using specification types), and extract the function from
   its proof (the prove that the specification is inhabited).
*)

(* Exercise: built an alternative definition of function head called “head corr”
   based on the strong specification mechanism *)

(* ================================================================== *)
(* ======================= Sorting a list =========================== *)

Open Scope Z_scope.

Inductive Sorted : list Z -> Prop :=
  | sorted0 : Sorted nil
  | sorted1 : forall z:Z, Sorted (z :: nil)
  | sorted2 : forall (z1 z2:Z) (l:list Z),
        z1 <= z2 -> Sorted (z2 :: l) -> Sorted (z1 :: z2 :: l).

Fixpoint count (z:Z) (l:list Z) {struct l} : nat :=
  match l with
  | nil => 0%nat     (* %nat to force the interpretation in nat, since have we open Z_scope *)
  | (z' :: l') => if Z.eq_dec z z'
                  then S (count z l')
                  else count z l'
  end.

Definition Perm (l1 l2:list Z) : Prop :=
                                 forall z, count z l1 = count z l2.

(* Perm is an equivalence relation (i.e. is reflexive, symmetric and transitive) *)

Lemma Perm_reflex : forall l:list Z, Perm l l.
Proof.
  intros. red. reflexivity.
Qed.

Lemma Perm_sym : forall l1 l2, Perm l1 l2 -> Perm l2 l1.
Proof.
  unfold Perm.
  intros l1 l2 H z.
  symmetry.
  (* apply H. *)
  generalize z.
  assumption.
Qed.

Lemma Perm_trans : forall l1 l2 l3, Perm l1 l2 -> Perm l2 l3 -> Perm l1 l3.
Proof.
  unfold Perm.
  intros.
  transitivity (count z l2); [ apply H | apply H0 ].
Qed.

(*  Exercise: prove the following lemmas: *)

Lemma Perm_cons : forall a l1 l2, Perm l1 l2 -> Perm (a::l1) (a::l2).
Proof.
  intros.
  unfold Perm in *. simpl.
  intro.
  elim (Z.eq_dec). auto. auto.
Qed.

Lemma Perm_cons_cons : forall x y l, Perm (x::y::l) (y::x::l).
Proof.
  unfold Perm.
  intros.
  simpl. elim(Z.eq_dec z x).
  - elim (Z.eq_dec z y); auto. (*auto auto*)
  - reflexivity.
Qed.

Fixpoint insert (x:Z) (l:list Z) {struct l} : list Z :=
  match l with
    nil => cons x (@nil Z)
  | cons h t => if Z_lt_ge_dec x h
                then cons x (cons h t)
                else cons h (insert x t)
  end.

Fixpoint isort (l:list Z) : list Z :=
  match l with
    nil => nil
  | cons h t => insert h (isort t)
  end.

Print isort.

(* some  usefull lemmas about count *)

Lemma count_insert_eq : forall x l,
                       count x (insert x l) = S (count x l).
Proof.
  induction l.
  - simpl. destruct (Z.eq_dec x x).
    + reflexivity.
    + destruct n. reflexivity.
  - simpl insert. destruct (Z_lt_ge_dec x a).
    + simpl. destruct (Z.eq_dec x x).
      * reflexivity.
      * easy.
    + simpl. destruct (Z.eq_dec x a).
      * rewrite IHl. reflexivity.
      * assumption.
Qed.

Lemma count_cons_diff : forall z x l, z <> x -> count z l = count z  (x :: l).
Proof.
  intros. induction l.
  - simpl. destruct (Z.eq_dec z x); easy.
  - simpl. destruct (Z.eq_dec z a).
    + destruct (Z.eq_dec z x); easy.
    + destruct (Z.eq_dec z x); easy.
Qed.

Lemma count_insert_diff : forall z x l, z <> x -> count z l = count z (insert x l).
Proof.
  intros. induction l.
  - simpl. destruct (Z.eq_dec z x); easy.
  - simpl insert. destruct (Z_lt_ge_dec x a).
    + simpl. destruct (Z.eq_dec z x); try easy. (*O try aplica tecnicas automaticas mas se nao resolver nao avança na prova*)
    + simpl. destruct (Z.eq_dec z a); try easy.
      apply f_equal. apply IHl.
Qed.

(* the two auxiliary lemmas *)

Lemma insert_Perm : forall x l, Perm (x::l) (insert x l).
Proof.
  unfold Perm; induction l.
 - simpl. reflexivity.
 - simpl insert. destruct (Z_lt_ge_dec x a).
   + reflexivity.
   + intros.
     destruct (Z.eq_dec z a).
     * simpl. destruct (Z.eq_dec z a).
       -- destruct (Z.eq_dec z x).
          ++ apply f_equal. rewrite e1. rewrite count_insert_eq. reflexivity.
          ++ apply f_equal. apply count_insert_diff. assumption.
       -- destruct (Z.eq_dec z x).
          ++ destruct n. assumption.
          ++ destruct n. assumption.
     * simpl. destruct (Z.eq_dec z a).
       -- destruct (Z.eq_dec z x); easy.
       -- destruct (Z.eq_dec z x).
          ++ rewrite e. rewrite count_insert_eq. reflexivity.
          ++ rewrite <- count_insert_diff; [reflexivity|assumption].
Qed.

Lemma insert_Sorted : forall x l, Sorted l -> Sorted (insert x l).
Proof.
  - intros x l H; elim H; simpl.
    + constructor.
    + intro z; elim (Z_lt_ge_dec x z); intros.
      * constructor.
        auto with zarith. constructor.
      * constructor.
        -- auto with zarith.
        -- constructor.
    + intros z1 z2 l0 H0 H1.
      elim (Z_lt_ge_dec x z2); elim (Z_lt_ge_dec x z1).
      * intros. constructor.
        -- lia. (* auto with zarith.*)
        -- constructor.
           ++ lia.
           ++ assumption.
      * intros. constructor.
        -- lia.
        -- assumption.
      * intros. constructor.
        -- lia.
        -- constructor; [lia|assumption].
      * intros. constructor; [lia|assumption].
Qed.

(* the proof that isort is correct *)
Theorem isort_correct : forall (l l':list Z), l'=isort l -> Perm l l' /\ Sorted l'.
Proof.
  induction l; intros.
  - unfold Perm; rewrite H; split; auto. simpl. constructor.
  - simpl in H.
    rewrite H. (* ??????????? *)
    elim (IHl (isort l)); intros; split.
    + apply Perm_trans with (a::isort l).
      * unfold Perm. intro z. simpl. elim (Z.eq_dec z a).
        -- intros. elim H0; reflexivity.   (* auto with zarith. *)
        -- auto with zarith.   (* intros. elim H0. reflexivity. *)
      * apply insert_Perm.
    + apply insert_Sorted. assumption.
Qed.

(* EXTRACTION *)
(* using specification types *)
Definition inssort : forall (l:list Z), { l' | Perm l l' & Sorted l' }.
Proof.
  induction l.
  - exists nil. constructor. constructor.
  - elim IHl. intros l1 H H1. exists (insert a l1).
    + apply Perm_trans with (a::l1).
      * apply Perm_cons. assumption.
      * apply insert_Perm.
    + apply insert_Sorted. assumption.
Defined.

Extraction Language Haskell.
Recursive Extraction inssort.

Extraction Inline list_rec list_rect sig2_rec sig2_rect.

Extraction inssort.
Recursive Extraction inssort.

(* ================================================================== *)
(* =================== Non-structural recursion ===================== *)

Close Scope Z_scope.

Require Import Recdef. (* because of Function *)

Function div (p:nat*nat) {measure fst} : nat*nat :=
  match p with
  | (_,0) => (0,0)
  | (a,b) => if le_lt_dec b a
             then let (x,y):=div (a-b,b) in (1+x,y)
             else (0,a)
  end.
Proof.
 intros. simpl. lia.
Qed.

(* Exercise: *)
Function merge (p:list Z*list Z)
{measure (fun p=>(length (fst p))+(length (snd p)))} : list Z :=
  match p with
  | (nil,l) => l
  | (l,nil) => l
  | (x::xs,y::ys) => if Z_lt_ge_dec x y
                     then x::(merge (xs,y::ys))
                     else y::(merge (x::xs,ys))
  end.
Admitted.
(* FILL IN HERE *)

(* ========== Introducing a new induction principle =========== *)

Fixpoint split (A:Type) (l:list A) : (list A * list A) :=
  match l with
  | [] => ([],[])     (* Import ListNotations. *)
  | [x] => ([x],[])
  | x1::x2::l' => let (l1,l2) := split l' in (x1::l1,x2::l2)
  end.

(*
    While this function is straightforward to define, it can be a bit challenging
    to work with.  Let's try to prove the following lemma, which is obviously true:
*)

Lemma split_len_first_try: forall (A:Type) (l:list A) (l1 l2: list A),
             split l = (l1,l2) ->  length l1 <= length l /\ length l2 <= length l.
Proof.
  induction l; intros.
  - inversion H. simpl. lia.
  - destruct l as [| x l'].
    + inversion_clear H. split; simpl; auto.
    + inversion H. destruct (split l') as [l1' l2']. inversion H1.
      (* We're stuck! The IH talks about split (x::l') but we
         only know aobut split (a::x::l'). *)
Abort.

(*  The problem here is that the standard induction principle for lists
    requires us to show that the property being proved follows for
    any non-empty list if it holds for the tail of that list.
    What we want here is a "two-step" induction principle, that instead requires
    us to show that the property being proved follows for a list of
    length at least two, if it holds for the tail of the tail of that list.
    Formally:
*)

Definition list_ind2_principle:=
    forall (A : Type) (P : list A -> Prop),
      P nil ->
      (forall (a:A), P (a::nil)) ->
      (forall (a b : A) (l : list A), P l -> P (a :: b :: l)) ->
      forall l : list A, P l.

(* If we assume the correctness of this "non-standard" induction principle,
    our split_len proof is easy, using a form of the induction tactic
    that lets us specify the induction principle to use:
 *)

Lemma split_len': list_ind2_principle ->
    forall (A:Type) (l:list A) (l1 l2: list A),
    split l = (l1,l2) ->
    length l1 <= length l /\
    length l2 <= length l.
Proof.
  unfold list_ind2_principle; intro IP.
  induction l using IP; intros.
  - inversion H. lia.
  - inversion H. simpl; lia.
  - inversion H. destruct (split l) as [l1' l2']. inversion H1.
    simpl.
    destruct (IHl l1' l2') as [P1 P2]; auto; lia.
Qed.

(*  We still need to prove list_ind2_principle.  There are several
    ways to do this, but one direct way is to write an explicit proof
    term, thus: *)

Definition list_ind2 :
  forall (A : Type) (P : list A -> Prop),
      P nil ->
      (forall (a:A), P (a::nil)) ->
      (forall (a b : A) (l : list A), P l -> P (a :: b :: l)) ->
      forall l : list A, P l :=
  fun (A : Type)
      (P : list A -> Prop)
      (H : P nil)
      (H0 : forall a : A, P (a::nil))
      (H1 : forall (a b : A) (l : list A), P l -> P (a :: b :: l))  =>
    fix IH (l : list A) :  P l :=
    match l with
    | nil => H
    | (x::nil) => H0 x
    | x::y::l' => H1 x y l' (IH l')
    end.

(*  Here, the fix keyword defines a local recursive function IH
    of type forall l:list A, P l, which is returned as the overall value of
    list_ind2. As usual, this function must be obviously terminating
    to Coq (which it is because the recursive call is on a sublist l'
    of the original argument l) and the match must be exhaustive over
    all possible lists (which it evidently is).
*)

(*  With our induction principle in hand, we can finally prove
    split_len free and clear:
*)

Lemma split_len: forall (A:Type) (l:list A) (l1 l2: list A),
    split l = (l1,l2) ->
    length l1 <= length l /\
    length l2 <= length l.
Proof.
 apply (split_len' list_ind2).
Qed.

(* ========== Euclidean division correction =========== *)

Definition divRel (args:nat*nat) (res:nat*nat) : Prop :=
          let (n,d):=args in let (q,r):=res in q*d+r=n /\ r<d.

Definition divPre (args:nat*nat) : Prop := (snd args)<>0.

Theorem div_correct : forall (p:nat*nat),  divPre p -> divRel p (div p).
Proof.
  unfold divPre, divRel.
  intro p.
  (* we make use of the specialised induction principle to conduct the proof... *)
  functional induction (div p); simpl.
  - intro H; elim H; reflexivity.
  - (* a first trick: we expand (div (a-b,b)) in order to get rid of the let (q,r)=... *)
    replace (div (a-b,b)) with (fst (div (a-b,b)),snd (div (a-b,b))) in IHp0.
    + simpl in *. intro H; elim (IHp0 H); intros. split.
      * (* again a similar trick: we expand "x" and "y0" in order to use an hypothesis *)
        change (b + (fst (x,y0)) * b + (snd (x,y0)) = a).
        rewrite <- e1. lia.
      * (* and again... *)
        change (snd (x,y0)<b); rewrite <- e1; assumption.
    + symmetry.  apply surjective_pairing.
  - auto.
Qed.


Fixpoint plus (n m : nat) : nat :=
	match n with
		| O => m
		| S n' => S (plus n' m)
	end.

Fixpoint mul (n m : nat) : nat :=
	match n with
		| O => O
		| S O => m
		| S n' => (plus m (mul n' m))
	end.

Fixpoint factoria (n : nat) : nat :=
	match n with
		| O => (S O)
		| S n' => (mul n (factoria n'))
	end.

(*Notation "x + y" := (plus x y) : nat_scope.*)

Eval compute in (mul 3 8).
Eval compute in (factoria 3).
Eval compute in (22 + 11).
Eval compute in (eq 22 22).