Require Import Morphisms.
Import ProperNotations.
Require Import SetoidClass.
Require notation categories prods_pullbacks.

Module Make(Import M: notation.T).
 Module Export functors_exp := categories.Make(M).

Class Functor `(catC: Category) `(catD: Category) (F: obj catC -> obj catD)
                (fmap: forall {a b: obj catC} (f: arrow catC b a), (arrow catD (F b) (F a))): Type :=
  mk_Functor
  {
    preserve_id     : forall {a: obj catC}, fmap (@identity catC a) = (@identity catD (F a));
    preserve_comp   : forall {a b c: obj catC} (f: arrow catC b a) (g : arrow catC c b), fmap (g o f) = (fmap g) o (fmap f)
  }.
Check Functor.

Program Instance Opposite_Functor `(catC: Category) `(catD: Category)
                            (F: obj catC -> obj catD)
                            (fmapF: forall (a b: obj catC) (f: arrow catC b a), (arrow catD (F b) (F a)))
                            `(FunctF: Functor catC catD F fmapF):
                                `(Functor (Dual_Category catC) (Dual_Category catD) F (fun a b => fmapF b a)).
Obligation 1. specialize (@mk_Functor
                (Dual_Category catC)
                (Dual_Category catD)
                F
                (fun a b => fmapF b a)
                (fun a => (@preserve_id catC catD F fmapF FunctF a))
                (fun a b c f g => (@preserve_comp catC catD F fmapF FunctF c b a g f))
              ). intros. destruct H as [H1 H2]. apply H1. Qed.
Next Obligation. specialize (@mk_Functor
                (Dual_Category catC)
                (Dual_Category catD)
                F
                (fun a b => fmapF b a)
                (fun a => (@preserve_id catC catD F fmapF FunctF a))
                (fun a b c f g => (@preserve_comp catC catD F fmapF FunctF c b a g f))
              ). intros. destruct H as [H1 H2]. apply H2. Qed.
Check Opposite_Functor.

(* another way of showing the same instance above:
Definition Opposite_Functor_v2 `(catC: Category) `(catD: Category)
                            (F: catC -> catD)
                            (fmapF: forall (a b: catC) (f: arrow catC b a), (arrow catD (F b) (F a)))
                            `(FunctF: Functor catC catD F fmapF):
                                `(Functor (Dual_Category catC) (Dual_Category catD) F (fun a b => fmapF b a)).
Proof. refine (@mk_Functor
                (Dual_Category catC)
                (Dual_Category catD)
                F
                (fun a b => fmapF b a)
                (fun a => (@preserve_id catC catD F fmapF FunctF a))
                (fun a b c f g => (@preserve_comp catC catD F fmapF FunctF c b a g f))
              ).
Defined.
*)

Definition Opposite_Opposite_Functor `(catC: Category) `(catD: Category)
                                     (F: obj (Dual_Category catC) -> obj (Dual_Category catD))
                                     (fmapF: forall (a b: obj (Dual_Category catC)) (f: arrow (Dual_Category catC) b a),
                                        (arrow (Dual_Category catD) (F b) (F a)))
                                     `(FunctF: Functor (Dual_Category catC) (Dual_Category catD) F fmapF):
                                        (Functor catC catD F (fun a b => fmapF b a)).
Proof. refine (@mk_Functor
                catC
                catD
                F
                (fun a b => fmapF b a)
                (fun a => (@preserve_id (Dual_Category catC) (Dual_Category catD) F fmapF FunctF a))
                (fun a b c f g => (@preserve_comp (Dual_Category catC) (Dual_Category catD) F fmapF FunctF c b a g f))
              ).
Defined.
Check Opposite_Opposite_Functor.

(** TODO:= prove the theorem here: oppositing is involutive **)

(*define how the identity functor behaves on objects and morphisms*)
Definition id {catC: Category} (a: obj catC) := a.
Definition idf {catC: Category} {a b: obj catC} (f: arrow catC b a) := f.

(** the identity functor **)
Program Instance IdentityFunctor (catC: Category): (@Functor catC catC id (fun a b f => (@idf catC a b f))).
Check IdentityFunctor.

(*define how the functor composition behaves on objects and morphisms*)
Definition comp_obj_FG  {catC catD catE: Category} {F: obj catC -> obj catD} {G: obj catD -> obj catE} (a: obj catC) := G (F a).
Definition comp_morp_FG {catC catD catE: Category} {F: obj catC -> obj catD} {G: obj catD -> obj catE}
                                {fmapF  : forall (a b: obj catC) (f: arrow catC b a), (arrow catD (F b) (F a))}
                                {fmapG  : forall (a b: obj catD) (f: arrow catD b a), (arrow catE (G b) (G a))}
                                (a b: obj catC) (f: (arrow catC b a)) := fmapG _ _ (fmapF _ _ f).

(**functors compose**)
Program Instance Compose_Functors (catC catD catE: Category) (F: obj catC -> obj catD) (G: obj catD -> obj catE)
                                  (fmapF  : forall (a b: obj catC) (f: arrow catC b a), (arrow catD (F b) (F a)))
                                  (FunctF: @Functor catC catD F fmapF)
                                  (fmapG  : forall (a b: obj catD) (f: arrow catD b a), (arrow catE (G b) (G a)))
                                  (FunctG: @Functor catD catE G fmapG):
                                  (@Functor catC catE (@comp_obj_FG catC catD catE F G) (@comp_morp_FG catC catD catE F G fmapF fmapG)).
Obligation 1. unfold comp_obj_FG, comp_morp_FG. remember (@preserve_id catC catD F fmapF FunctF a).
  remember (@preserve_id catD catE G fmapG FunctG (F a)). rewrite <- e0. rewrite e. reflexivity. Qed.
Next Obligation. unfold comp_obj_FG, comp_morp_FG. remember (@preserve_comp catC catD F fmapF FunctF a b c f g).
  remember (@preserve_comp catD catE G fmapG FunctG (F a) (F b) (F c) (fmapF _ _ f) (fmapF _ _ g)).
  rewrite <- e0. rewrite e. reflexivity. Qed.
Check Compose_Functors.

(** constant functor **)
Definition Constant_Functor `(catC: Category) `(catD: Category) (const: obj catD):
                                              `(Functor catC catD (fun _ => const) (fun _ _ _ => (@identity catD const))).
Proof. refine(@mk_Functor
               catC
               catD _ _ _ _
             ).
       intros. reflexivity.
       intros. simpl. rewrite identity_f; reflexivity.
Defined.
Check Constant_Functor.

(* obligated fmap *)

Class Functor2 `(catC: Category) `(catD: Category) (F: obj catC -> obj catD): Type :=
  mk_Functor2
  {
    fmap2            : forall {a b: obj catC} (f: arrow catC b a), (arrow catD (F b) (F a));
    preserve_id2     : forall {a: obj catC}, fmap2 (@identity catC a) = (@identity catD (F a));
    preserve_comp2   : forall {a b c: obj catC} (f: arrow catC b a) (g : arrow catC c b), fmap2 (g o f) = (fmap2 g) o (fmap2 f)
  }.
Check Functor2.

(*
Program Instance IdentityFunctor2 (catC: Category):
   (@Functor2 catC catC (fun a => id a)).
Check IdentityFunctor2.
*)

Definition Opposite_Functor2 (catC: Category) `(catD: Category)
                             (F: obj catC -> obj catD)
                             (FunctF: Functor2 catC catD F ): (Functor2 (Dual_Category catC) (Dual_Category catD) F).
Proof. refine (@mk_Functor2
                (Dual_Category catC)
                (Dual_Category catD)
                F
                (fun a b => (@fmap2 catC catD F FunctF b a))
                (fun a => (@preserve_id2 catC catD F FunctF a))
                (fun a b c f g => (@preserve_comp2 catC catD F FunctF c b a g f))).
Qed.
Check Opposite_Functor2.

Definition Opposite_Opposite_Functor2 (catC: Category) (catD: Category)
                                     (F: obj (Dual_Category catC) -> obj (Dual_Category catD))
                                     (FunctF: Functor2 (Dual_Category catC) (Dual_Category catD) F): (Functor2 catC catD F).
Proof. refine (@mk_Functor2
                catC
                catD
                F
                (fun a b => (@fmap2 (Dual_Category catC) (Dual_Category catD) F FunctF b a))
                (fun a => (@preserve_id2 (Dual_Category catC) (Dual_Category catD) F FunctF a))
                (fun a b c f g => (@preserve_comp2 (Dual_Category catC) (Dual_Category catD) F FunctF c b a g f))
              ).
Defined.
Check Opposite_Opposite_Functor2.

(**functors compose**)
Definition Compose_Functors2 (catC catD catE: Category) (F: obj catC -> obj catD) (G: obj catD -> obj catE)
                             (FunctF : @Functor2 catC catD F)
                             (FunctG : @Functor2 catD catE G): (@Functor2 catC catE (@comp_obj_FG catC catD catE F G)).
Proof. refine (@mk_Functor2
                catC
                catE
                (fun a => G (F a))
                (fun a b f => ((@fmap2 catD catE G FunctG _ _ (@fmap2 catC catD F FunctF a b f))))
                _ _ ).
      - intros. destruct catC, catD, catE, FunctF, FunctG. simpl in *.
        specialize (preserve_id4 (F a)). rewrite <- preserve_id4. rewrite preserve_id3. reflexivity.
      - intros. destruct catC, catD, catE, FunctF, FunctG. simpl in *.
        rewrite <- preserve_comp4. rewrite preserve_comp3. reflexivity.
Defined.
Check Compose_Functors2.

Definition IdentityFunctor2 (catC: Category): (@Functor2 catC catC id).
Proof. refine (@mk_Functor2
                catC
                catC
                id
                (fun a b f => (@idf catC a b f))
                _ _ ).
        - intros. unfold idf. simpl; reflexivity.
        - intros. unfold idf; reflexivity.
Defined.
Check IdentityFunctor2.

(** constant functor **)
Definition Constant_Functor2 (catC: Category) (catD: Category) (const: obj catD):
                            (Functor2 catC catD (fun _ => const)).
Proof. refine(@mk_Functor2
               catC
               catD
               (fun _     => const)
               (fun _ _ _ => (@identity catD const))
               _ _
             ).
       - intros. reflexivity.
       - intros. simpl. rewrite identity_f; reflexivity.
Defined.
Check Constant_Functor2.

End Make.


Require Import Bool.
Require Import List.
Require Import Omega.
Require Import Classical.

From mathcomp
Require Import ssreflect.

Require Import Utility.
Require Import Cell.

Import ListNotations.

Section Concentric.
  Open Scope Z_scope.
  Open Scope list_scope.

  Inductive CellType: Set :=
    | White
    | Temp
    | Safe.

  Definition c_type (s: CellState): CellType :=
    match s with
    | W => White
    | s true _ | si true _ _ => Temp
    | S | s false _ | si false _ _ => Safe
    end.

  (***** Safety *****)
  Definition init_safe (st : State) : Prop := st 0 0 = S.

  Definition t_safe (st : State) : Prop :=
    forall (x y : Z), c_type (st x y) = Temp ->
    ((x > 0 /\ c_type (st (x - 1) y) = Safe) \/
    (x < 0 /\ c_type (st (x + 1) y) = Safe) \/
    (y > 0 /\ c_type (st x (y - 1)) = Safe) \/
    (y < 0 /\ c_type (st x (y + 1)) = Safe)
    ).

  Definition s_safe (st : State) : Prop :=
    forall (x y : Z), c_type (st x y) = Safe ->
    ((x > 0 -> c_type (st (x - 1) y) = Safe) /\
    (x < 0 -> c_type (st (x + 1) y) = Safe) /\
    (y > 0 -> c_type (st x (y - 1)) = Safe) /\
    (y < 0 -> c_type (st x (y + 1)) = Safe)).

  Definition i_safe (st : State) : Prop :=
    forall (x y i : Z) (tmp alt : bool),
    (st x y = S -> x = 0 /\ y = 0) /\
    (st x y = s tmp alt ->
    (x = 1 /\ y = 0) \/ (x = -1 /\ y = 0) \/
    (x = 0 /\ y = 1) \/ (x = 0 /\ y = -1)) /\
    (st x y = si tmp alt i -> i = (Z.abs x + Z.abs y - 2) mod 5).

  Definition safe (st : State) : Prop :=
    init_safe st /\ t_safe st /\ s_safe st /\ i_safe st.
  (***** Safety *****)

  (***** Reachability *****)
  CoInductive Run : Type :=
    | RCons : State -> Run -> Run.

  Definition hd (r : Run) : State := let (a, b) := r in a.
  Definition tl (r : Run) : Run := let (a, b) := r in b.

  Definition Coord := prod Z Z.

  Definition map_coord
    (st : State) (cl : list Coord) : list CellState :=
    map (fun c : Coord => st (fst c) (snd c)) cl.

  CoInductive ValidRun : Run -> Prop :=
    | VCons : forall (st : State) (r : Run),
        ValidRun r -> trans st (hd r) -> ValidRun (RCons st r).

  Inductive InRun (st : State) (r : Run) : Prop :=
    | Here : st = hd r -> InRun st r
    | Further : InRun st (tl r) -> InRun st r.

  Definition trans_ss
    (cl : list Coord)
    (ul vl : list CellState)
    (P : State -> Prop) (* e.g. safe *)
    : Prop :=
    forall (st : State),
    P st /\ ul = map_coord st cl ->
    exists (st' : State),
    vl = map_coord st' cl /\ trans st st' /\ P st' /\
    (forall (x y : Z), ~In (x, y) cl -> st x y = st' x y).

  Inductive trans_subset
    (cl : list Coord)
    (ul vl : list CellState)
    (P : State -> Prop) (* e.g. safe *)
    : Prop :=
    | I : ul = vl -> trans_subset cl ul vl P
    | V : forall (wl : list CellState),
        trans_ss cl ul wl P ->
        trans_subset cl wl vl P ->
        trans_subset cl ul vl P.

  Definition fair
    (r : Run)
    (cl : list Coord) (* i.e. list (prod Z Z) *)
    (P : State -> Prop) (* e.g. safe *)
    (Q : list CellState -> Prop)
    : Prop :=
    ValidRun r ->
    (forall (st : State), InRun st r /\ P st ->
    (exists (vl : list CellState),
    trans_subset cl (map_coord st cl) vl P /\ Q vl)) ->
    (exists (st' : State), InRun st' r /\ Q (map_coord st' cl)).

  Definition side_coords (n y : Z) : list Coord :=
    [ (n, y); (n + 1, y) ].

  Definition axis_coords (n : Z) : list Coord :=
    [ (n, 1); (n, 0); (n, -1) ].

  (* P *)
  Definition SideSSCnd (ul : list Coord) (st : State) : Prop :=
    let l := map c_type (map_coord st ul) in
    let a := nth 0 l White in
    a = Safe.

  Inductive subset_cnd (ul : list Coord) (st : State) : Prop :=
    | I0 : ul = [] -> subset_cnd ul st
    | I1 : forall (x y : Z) (res : list Coord),
        ul = (x, y) :: res ->
        c_type (st x y) = Safe \/ c_type (st x y) = Temp ->
        subset_cnd res st ->
        subset_cnd ul st.

  Definition pre_cnd (ul : list Coord) (st : State) : Prop :=
    safe st /\ subset_cnd ul st.

  (* Q *)
  Definition side_safe (vl : list CellState) : Prop :=
    let l := map c_type vl in
    let a := nth 1 l White in
    a = Safe \/ a = Temp.

  Definition axis_safe (vl : list CellState) : Prop :=
    let l := map c_type vl in
    nth 1 l White = Safe.

  Lemma temp_imply : forall (c : CellState),
    c_type c = Temp -> exists (alt : bool) (i : Z),
    c = s true alt \/ c = si true alt i.
  Proof.
    move=> c s0.
    destruct c.
    -by [].
    -by [].
    -exists alt.
      destruct tmp.
      exists 0.
      by left.
      by discriminate.
    -exists alt.
      destruct tmp.
      exists i.
      by right.
      by discriminate.
  Qed.

  Definition si_temp_st
    (st : State) (tmp alt: bool) (n m i : Z) (x y : Z) : CellState :=
    if ((x =? n) && (y =? m)) then si tmp alt i else st x y.

  Definition s_temp_st
    (st : State) (tmp alt: bool) (n m : Z) (x y : Z) : CellState :=
    if ((x =? n) && (y =? m)) then s tmp alt else st x y.
  (***** Reachability *****)

  Close Scope list_scope.
  Close Scope Z_scope.

End Concentric.


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

(** ** Elementary diophantine constraints *)

Require Import List Arith Nat Omega.
Require Import utils_list gcd prime dio_logic.

Set Implicit Arguments.

Section interval.

  (** A small interval & valuation library *)

  Definition interval := (nat * nat)%type. (* (a,b) <~~~> [a,b[ *)

  Implicit Types (i j : interval).

  Definition in_interval i x := let (a,b) := i in a <= x < b.
  Definition out_interval i x := let (a,b) := i in x < a \/ b <= x.
  Definition interval_disjoint i j := forall x, in_interval i x -> in_interval j x -> False.

  Definition interval_union (i j : interval) :=
    match i, j with (a1,b1),(a2,b2) => (min a1 a2, max b1 b2) end.

  Fact in_out_interval i x : in_interval i x -> out_interval i x -> False.
  Proof. destruct i; simpl; omega. Qed.

  Fact in_out_interval_dec i x : { in_interval i x } + { out_interval i x }.
  Proof.
    destruct i as (a,b); simpl.
    destruct (le_lt_dec a x); destruct (le_lt_dec b x); try (left; omega);right; omega.
  Qed.

  Fact interval_union_left i j x : in_interval i x -> in_interval (interval_union i j) x.
  Proof.
    revert i j; intros (a,b) (u,v); simpl.
    generalize (Nat.le_min_l a u) (Nat.le_max_l b v); omega.
  Qed.

  Fact interval_union_right i j x : in_interval j x -> in_interval (interval_union i j) x.
  Proof.
    revert i j; intros (a,b) (u,v); simpl.
    generalize (Nat.le_min_r a u) (Nat.le_max_r b v); omega.
  Qed.

  Definition valuation_union i1 (g1 : nat -> nat) i2 g2 :
               interval_disjoint i1 i2
            -> { g | (forall x, in_interval i1 x -> g x = g1 x)
                  /\ (forall x, in_interval i2 x -> g x = g2 x) }.
  Proof.
    intros H2.
    exists (fun x => if in_out_interval_dec i1 x then g1 x else g2 x).
    split; intros x Hx.
    + destruct (in_out_interval_dec i1 x) as [ | H3 ]; auto.
      exfalso; revert Hx H3; apply in_out_interval.
    + destruct (in_out_interval_dec i1 x) as [ H3 | ]; auto.
      exfalso; revert H3 Hx; apply H2.
  Qed.

  Definition valuation_one_union k v i1 (g1 : nat -> nat) i2 g2 :
               ~ in_interval (interval_union i1 i2) k
            -> interval_disjoint i1 i2
            -> { g | g k = v /\ (forall x, in_interval i1 x -> g x = g1 x)
                             /\ (forall x, in_interval i2 x -> g x = g2 x) }.
  Proof.
    intros H1 H2.
    exists (fun x => if eq_nat_dec x k then v
                     else if in_out_interval_dec i1 x then g1 x
                     else g2 x).
    split; [ | split ].
    + destruct (eq_nat_dec k k) as [ | [] ]; auto.
    + intros x Hx.
      destruct (eq_nat_dec x k) as [ | ].
      * subst; destruct H1; apply interval_union_left; auto.
      * destruct (in_out_interval_dec i1 x) as [ | H3 ]; auto.
        exfalso; revert Hx H3; apply in_out_interval.
    + intros x Hx.
      destruct (eq_nat_dec x k) as [ | ].
      * subst; destruct H1; apply interval_union_right; auto.
      * destruct (in_out_interval_dec i1 x) as [ H3 | ]; auto.
        exfalso; revert H3 Hx; apply H2.
  Qed.

End interval.

Section diophantine_system.

  (* v : cst = nat      constant (natural number)
     p q : par = nat    parameter
     x y z : var = nat  existentially quantified variable

     equations are of 4 types
       1) x = v
       2) x = p
       3) x = y + z
       4) x = y * z

     We represent a relation between parameters R by a list of equations l and one
     variable x : var such that
       a) for any value f : nat -> nat of the params, l[f] has a solution
       b) for any value f : nat -> nat of the params,

                R f <-> ((x=0)::l)[f] has a solution

     How do we simulate poly1 = poly2 linearly ?

         poly1 = (eqn1,x) where x is output
         poly2 = (eqn2,y) where y is output

         example poly1 = p*(q+r)
         gives eqn1:= (0=1*2, 1=p, 2=3+4, 3=q, 4=r) and x:=0

         then we simulate poly1 = poly2 with

               poly1 = poly2 <-> (eqn1 U eqn2 U { w=y+u, w=x+v, z=u+v }, z)

         where u v z w are fresh

     We implement conjunction (cap), disjunction (cup) and exists so that we get a linear encoding

      cap) R by (lR,xR) and S by (lS,xS)
           we assume (lR,xR) and (lS,xS) do not share existential variables
           (always possible by renaming those of S)

           R cap S = (lR U lS U { z = x+y },z) where z is fresh

      cup) R cup S = (lR U lS U { z = x*y },z)

      exists) ∃n.R f{p<-n} = (lR[p<-0], ...)

   *)

  Inductive dio_elem_expr : Set :=
    | dee_nat  : nat -> dio_elem_expr   (* c : constant *)
    | dee_var  : nat -> dio_elem_expr   (* v : existentially quant. var *)
    | dee_par  : nat -> dio_elem_expr   (* p : parameter *)
    | dee_comp : dio_op -> nat -> nat -> dio_elem_expr. (* v1 op v2 *)

  Notation dee_add := (dee_comp do_add).
  Notation dee_mul := (dee_comp do_mul).

  (* ρ σ ν φ *)

  Definition dee_eval φ ν e :=
    match e with
      | dee_nat n => n
      | dee_var v => φ v
      | dee_par i => ν i
      | dee_comp o v w => do_eval o (φ v) (φ w)
    end.

  Definition dee_vars e x  :=
    match e with
      | dee_nat _ => False
      | dee_var v => x = v
      | dee_par _ => False
      | dee_comp _ v w => x = v \/ x = w
    end.

  Fact dee_eval_ext e φ1 ν1 φ2 ν2  :
        (forall x, dee_vars e x -> φ1 x = φ2 x)
     -> (forall x, ν1 x = ν2 x)
     -> dee_eval φ1 ν1 e = dee_eval φ2 ν2 e.
  Proof. destruct e as [ | | | [] ]; simpl; auto. Qed.

  (* ρ σ ν *)

  Definition dee_move k p :=
    match p with
      | dee_nat n      => dee_nat n
      | dee_var v      => dee_var (k+v)
      | dee_par i      => dee_par i
      | dee_comp o v w => dee_comp o (k+v) (k+w)
    end.

  Fact dee_eval_move k φ ν e : dee_eval φ ν (dee_move k e) = dee_eval (fun x => φ (k+x)) ν e.
  Proof. destruct e as [ | | | [] ]; simpl; auto. Qed.

  Fact dee_vars_move k e x : dee_vars (dee_move k e) x <-> exists y, dee_vars e y /\ x = k+y.
  Proof. destruct e as [ | | | [] ]; simpl; firstorder. Qed.

  Definition dee_dec k e :=
    match e with
      | dee_nat n      => dee_nat n
      | dee_var v      => dee_var v
      | dee_par 0      => dee_var k
      | dee_par (S i)  => dee_par i
      | dee_comp o v w => dee_comp o v w
    end.

  Fact dee_eval_dec φ ν k e : dee_eval φ ν (dee_dec k e) = dee_eval φ (fun x => match x with 0 => φ k | S x => ν x end) e.
  Proof. destruct e as [ | | [] | [] ]; simpl; auto. Qed.

  Fact dee_vars_dec k e x : dee_vars (dee_dec k e) x -> x = k \/ dee_vars e x.
  Proof. destruct e as [ | | [] | [] ]; simpl; firstorder. Qed.

  Definition dio_constraint := (nat * dio_elem_expr)%type.

  Implicit Type (c : dio_constraint).

  Definition dc_eval φ ν c := φ (fst c) = dee_eval φ ν (snd c).

  Arguments dc_eval φ ν c /.

  Definition dc_vars c x := x = fst c \/ dee_vars (snd c) x.

  Arguments dc_vars c x /.

  Fact dc_eval_ext c φ1 ν1 φ2 ν2  :
        (forall x, dc_vars c x -> φ1 x = φ2 x)
     -> (forall x, ν1 x = ν2 x)
     -> dc_eval φ1 ν1 c <-> dc_eval φ2 ν2 c.
  Proof.
    intros H1 H2.
    destruct c as (v,e); unfold dc_eval; simpl.
    rewrite H1; simpl; auto.
    rewrite dee_eval_ext with e φ1 ν1 φ2 ν2; try tauto.
    intros; apply H1; simpl; auto.
  Qed.

  Definition dc_move k c := (k+fst c, dee_move k (snd c)).

  Fact dc_eval_move k φ ν c : dc_eval φ ν (dc_move k c) <-> dc_eval (fun x => φ (k+x)) ν c.
  Proof.
    destruct c as (v,e); simpl.
    rewrite dee_eval_move; tauto.
  Qed.

  Fact dc_vars_move k c x : dc_vars (dc_move k c) x <-> exists y, x = k + y /\ dc_vars c y.
  Proof.
    destruct c as (v,e); simpl.
    rewrite dee_vars_move.
    split.
    + intros [ ? | (y & Hy & ?) ]; subst x; firstorder; exists v; auto.
    + intros (y & ? & [ | ]); subst; firstorder.
  Qed.

  Definition dc_dec k c := (fst c, dee_dec k (snd c)).

  Fact dc_eval_dec φ ν k c : dc_eval φ ν (dc_dec k c) <-> dc_eval φ  (fun x => match x with 0 => φ k | S x => ν x end) c.
  Proof. destruct c; simpl; rewrite dee_eval_dec; tauto. Qed.

  Fact dc_vars_dec k c x : dc_vars (dc_dec k c) x -> x = k \/ dc_vars c x.
  Proof. destruct c; simpl; intros [ | H ]; auto; apply dee_vars_dec in H; tauto. Qed.

  Implicit Type (R : (nat -> nat) -> Prop).

  (* A diophantine system for R is an interval i, a list l of constraints, a reference variable x
     such that
       1) the variables in l U {x} and belong to i
       2) for any valuation, the equations of l are satisfiable
       3) for any valuation ν, R ν holds iff the equations of { x=0 } U l are satisfiable
   *)

  Record dio_repr_at R a n l := {
    ds_eqns : list dio_constraint;
    ds_ref  : nat;
    ds_H0   : length ds_eqns = l;
    ds_H1   : forall x c, In c ds_eqns -> dc_vars c x -> a <= x < a+n;
    ds_H2   : a <= ds_ref < a+n;
    ds_H3   : forall ν, exists φ, Forall (dc_eval φ ν) ds_eqns;
    ds_H4   : forall ν, R ν <-> exists φ, Forall (dc_eval φ ν) ds_eqns /\ φ ds_ref = 0;
  }.

  Section diophantine_sys_expr.

    (* A compiler from expressions to lists of small expressions *)

    Fixpoint de_eqns e x :=
      match e with
        | de_cst n      => (x,dee_nat n)::nil
        | de_var p      => (x,dee_par p)::nil
        | de_comp o p q => (x,dee_comp o (x+1) (x+1+de_size p)) :: de_eqns p (x+1) ++ de_eqns q (x+1+de_size p)
      end.

    Fact de_eqns_length e x : length (de_eqns e x) = de_size e.
    Proof.
      revert x; induction e as [ | | o p Hp q Hq ]; intros x; simpl; auto.
      rewrite app_length, Hp, Hq; auto.
    Qed.

    Fact de_size_ge_1 e : 1 <= de_size e.
    Proof. destruct e; simpl; omega. Qed.

    Fact de_eqns_vars e x : forall c, In c (de_eqns e x) -> forall y, dc_vars c y -> x <= y < x+de_size e.
    Proof.
      revert x; induction e as [ | | o p Hp q Hq ]; intros x; simpl; auto.
      + intros ? [ [] | [] ]; simpl; intros; omega.
      + intros ? [ [] | [] ]; simpl; intros; omega.
      + intros c [ Hc | Hc ]; [ | apply in_app_or in Hc; destruct Hc as [ Hc | Hc ] ]; subst; simpl.
        * intros; generalize (de_size_ge_1 q); intros; omega.
        * intros y Hy; apply Hp with (y := y) in Hc; simpl in *; auto; omega.
        * intros y Hy; apply Hq with (y := y) in Hc; simpl in *; auto; omega.
    Qed.

    (* If equations in de_eqns e x are satisfied in φ, then φ x must be equal to de_eval ν e *)

    Fact dc_Forall_eval φ ν e x : Forall (dc_eval φ ν) (de_eqns e x) -> de_eval ν e = φ x.
    Proof.
      rewrite Forall_forall.
      revert x; induction e as [ | v| [] p Hp q Hq ]; simpl; intros x Hx; simpl; auto.
      * specialize (Hx (x,dee_nat n)); simpl in Hx; rewrite Hx; auto.
      * specialize (Hx (x,dee_par v)); simpl in Hx; rewrite Hx; auto.
      * rewrite Hp with (x+1), Hq with (x+1+de_size p).
        - symmetry; apply (Hx (_, dee_add _ _)); auto.
        - intros; apply Hx; right; apply in_or_app; auto.
        - intros; apply Hx; right; apply in_or_app; auto.
      * rewrite Hp with (x+1), Hq with (x+1+de_size p).
        - symmetry; apply (Hx (_, dee_mul _ _)); auto.
        - intros; apply Hx; right; apply in_or_app; auto.
        - intros; apply Hx; right; apply in_or_app; auto.
    Qed.

    (* Converselly, equations in de_eqns e x are satisfiable *)

    Fact dc_eval_exists_Forall ν e x : { φ | Forall (dc_eval φ ν) (de_eqns e x) }.
    Proof.
      revert x; induction e as [ | v | o p Hp q Hq ]; simpl; intros x.
      + exists (fun  _ => n); constructor; simpl; auto.
      + exists (fun  _ => ν v); constructor; simpl; auto.
      + destruct (Hp (x+1)) as (g1 & H2).
        destruct (Hq (x+1+de_size p)) as (g2 & H4).
        generalize (dc_Forall_eval _ _ H2) (dc_Forall_eval _ _ H4); intros H1 H3.
        destruct (@valuation_one_union x (do_eval o (de_eval ν p) (de_eval ν q)) (x+1,x+1+de_size p) g1 (x+1+de_size p, x+1+de_size p+de_size q) g2)
           as (g & H5 & H6 & H7).
        * simpl; rewrite Min.min_l; omega.
        * intros y; simpl; omega.
        * exists g; constructor.
          - red; unfold fst, snd; rewrite H5, H1, H3; simpl; f_equal; symmetry.
            ++ apply H6; simpl; generalize (de_size_ge_1 p); intros; omega.
            ++ apply H7; simpl; generalize (de_size_ge_1 q); intros; omega.
          - apply Forall_app; split.
            ++ revert H2; do 2 rewrite Forall_forall.
               intros H c Hc.
               generalize (H _ Hc); apply dc_eval_ext; auto.
               intros y Hy; apply H6.
               apply de_eqns_vars with (1 := Hc); auto.
            ++ revert H4; do 2 rewrite Forall_forall.
               intros H c Hc.
               generalize (H _ Hc); apply dc_eval_ext; auto.
               intros y Hy; apply H7.
               apply de_eqns_vars with (1 := Hc); auto.
    Qed.

    Let compare_lemma x y : { u : nat & { v | u+x = v+y } }.
    Proof.
      destruct (le_lt_dec x y).
      + exists (y-x), 0; omega.
      + exists 0, (x-y); omega.
    Qed.

    (* poly1 = poly2 <-> (eqn1 U eqn2 U { w=x+u, w=y+v, z=u+v }, z) *)

    Let g0 (n x0 x1 x2 x3 m : nat) := if le_lt_dec n m then
                                match m - n with
                                  | 0 => x0
                                  | 1 => x1
                                  | 2 => x2
                                  | _ => x3
                                end
                              else x3.

    Let g0_0 (n x0 x1 x2 x3 : nat) : g0 n x0 x1 x2 x3 n = x0.
    Proof.
      unfold g0; destruct (le_lt_dec n n); try omega.
      replace (n-n) with 0 by omega; auto.
    Qed.

    Let g0_1 (n x0 x1 x2 x3 : nat) : g0 n x0 x1 x2 x3 (n+1) = x1.
    Proof.
      unfold g0; destruct (le_lt_dec n (n+1)); try omega.
      replace (n+1-n) with 1 by omega; auto.
    Qed.

    Let g0_2 (n x0 x1 x2 x3 : nat) : g0 n x0 x1 x2 x3 (n+2) = x2.
    Proof.
      unfold g0; destruct (le_lt_dec n (n+2)); try omega.
      replace (n+2-n) with 2 by omega; auto.
    Qed.

    Let g0_3 (n x0 x1 x2 x3 : nat) : g0 n x0 x1 x2 x3 (n+3) = x3.
    Proof.
      unfold g0; destruct (le_lt_dec n (n+3)); try omega.
      replace (n+3-n) with 3 by omega; auto.
    Qed.

    (* x1+(x2*5) at 4 ~~> v4 = v5 + v6, v5 = x1, v6 = v7 * v8, v7 = x2, v8 = 5
       x3 at 9        ~~> v9 = x3

       x1+(x2*5) = x3 at 0
                      ~~> v3 = v1 + v4, v3 = v2 + v9, v0 = v1 + v2
    *)

    Lemma dio_repr_at_eq n e1 e2 : dio_repr_at (fun ν => de_eval ν e1 = de_eval ν e2) n (4+de_size e1+de_size e2) (3+de_size e1+de_size e2).
    Proof.
      exists ((n+3, dee_add (n+1) (n+4)) ::
              (n+3, dee_add (n+2) (n+4+de_size e1)) ::
              (n,   dee_add (n+1) (n+2)) ::
              (de_eqns e1 (n+4) ++ de_eqns e2 (n+4+de_size e1))) n.
      + simpl; rewrite app_length; do 2 rewrite de_eqns_length; auto.
      + intros x c [ Hc | [ Hc | [ Hc | Hc ] ] ].
        * subst; simpl; generalize (de_size_ge_1 e2); omega.
        * subst; simpl; generalize (de_size_ge_1 e2); omega.
        * subst; simpl; generalize (de_size_ge_1 e2); omega.
        * intros Hx; apply in_app_or in Hc.
          destruct Hc as [ Hc | Hc ]; apply de_eqns_vars with (2 := Hx) in Hc;
             simpl in *; omega.
      + simpl; omega.
      + intros f.
        destruct (@dc_eval_exists_Forall f e1 (n+4)) as (g1 & H2).
        destruct (@dc_eval_exists_Forall f e2 (n+4+de_size e1)) as (g2 & H4).
        destruct (compare_lemma (g1 (n+4)) (g2 (n+4+de_size e1))) as (u & v & Huv).
        set (g3 := g0 n (u+v) u v (u+g1 (n+4))).
        destruct (@valuation_union (n+4, n+4+de_size e1) g1 (n+4+de_size e1, n+4+de_size e1+de_size e2) g2)
           as (g4 & H5 & H6).
        { intro; simpl; omega. }
        destruct (@valuation_union (n,n+4) g3 (n+4,n+4+de_size e1+de_size e2) g4)
           as (g & H7 & H8).
        { intro; simpl; omega. }
        generalize (de_size_ge_1 e1) (de_size_ge_1 e2); intros E1 E2.
        exists g; repeat constructor; simpl.
        * rewrite H7, H7; simpl; auto; try omega.
          rewrite H8; simpl; try omega.
          rewrite H5; simpl; try omega.
          unfold g3; rewrite g0_1, g0_3; omega.
        * rewrite H7, H7; simpl; auto; try omega.
          rewrite H8; simpl; try omega.
          rewrite H6; simpl; auto; try omega.
          unfold g3; rewrite g0_2, g0_3; omega.
        * rewrite H7, H7, H7; simpl; try omega.
          unfold g3; rewrite g0_0, g0_1, g0_2; auto.
        * apply Forall_app; split.
          - revert H2; do 2 rewrite Forall_forall.
            intros H c Hc; generalize (H _ Hc).
            apply dc_eval_ext; auto.
            intros x Hx; rewrite H8.
            ++ apply H5, de_eqns_vars with (1 := Hc); auto.
            ++ apply de_eqns_vars with (1 := Hc) in Hx.
               simpl in *; omega.
          - revert H4; do 2 rewrite Forall_forall.
            intros H c Hc; generalize (H _ Hc).
            apply dc_eval_ext; auto.
            intros x Hx; rewrite H8.
            ++ apply H6, de_eqns_vars with (1 := Hc); auto.
            ++ apply de_eqns_vars with (1 := Hc) in Hx.
               simpl in *; omega.
      + intros f; split.
        * intros Hf.
          destruct (@dc_eval_exists_Forall f e1 (n+4)) as (g1 & H2).
          destruct (@dc_eval_exists_Forall f e2 (n+4+de_size e1)) as (g2 & H4).
          generalize (dc_Forall_eval _ _ H2) (dc_Forall_eval _ _ H4); intros H1 H3.
          set (g3 := g0 n 0 0 0 (de_eval f e1)).
          destruct (@valuation_union (n+4, n+4+de_size e1) g1 (n+4+de_size e1, n+4+de_size e1+de_size e2) g2)
             as (g4 & H5 & H6).
          { intro; simpl; omega. }
          destruct (@valuation_union (n, n+4) g3 (n+4, n+4+de_size e1+de_size e2) g4)
            as (g & H7 & H8).
          { intro; simpl; omega. }
          generalize (de_size_ge_1 e1) (de_size_ge_1 e2); intros E1 E2.
          exists g; repeat constructor; simpl.
          - rewrite H7, H7; simpl; auto; try omega.
            rewrite H8; simpl; try omega.
            rewrite H5; simpl; try omega.
            unfold g3; rewrite g0_3, g0_1; omega.
          - rewrite H7, H7; simpl; auto; try omega.
            rewrite H8; simpl; try omega.
            unfold g3; rewrite g0_3, g0_2.
            rewrite Hf, H6; simpl; auto; omega.
          - rewrite H7, H7, H7; simpl; try omega.
            unfold g3; rewrite g0_0, g0_1, g0_2; auto.
          - apply Forall_app; split.
            ++ revert H2; do 2 rewrite Forall_forall.
               intros H c Hc; generalize (H _ Hc).
               apply dc_eval_ext; auto.
               intros x Hx; rewrite H8.
               ** apply H5, de_eqns_vars with (1 := Hc); auto.
               ** apply de_eqns_vars with (1 := Hc) in Hx.
                  simpl in *; omega.
            ++ revert H4; do 2 rewrite Forall_forall.
               intros H c Hc; generalize (H _ Hc).
               apply dc_eval_ext; auto.
               intros x Hx; rewrite H8.
               ** apply H6, de_eqns_vars with (1 := Hc); auto.
               ** apply de_eqns_vars with (1 := Hc) in Hx.
                  simpl in *; omega.
          - rewrite H7; simpl; try omega.
            unfold g3; rewrite g0_0; auto.
        * intros (g & H1 & H0).
          do 3 rewrite Forall_cons_inv in H1.
          rewrite Forall_app in H1.
          destruct H1 as (H1 & H2 & H3 & H4 & H5).
          simpl in *.
          rewrite dc_Forall_eval with (1 := H4).
          rewrite dc_Forall_eval with (1 := H5).
          omega.
    Defined.

  End diophantine_sys_expr.

  Let not_interval_union a1 n1 a2 n2 :
           a1+n1 <= a2
        -> ~ in_interval (interval_union (a1, a1 + n1) (a2, a2 + n2)) (a2 + n2).
  Proof.
    simpl; intros H1 (_ & H3).
    rewrite Nat.max_r in H3; omega.
  Qed.

  Lemma dio_repr_at_conj R1 a1 n1 p1 R2 a2 n2 p2 n :
          dio_repr_at R1 a1 n1 p1
       -> dio_repr_at R2 a2 n2 p2
       -> a1+n1 <= a2
       -> n = 1+a2+n2-a1
       -> dio_repr_at (fun ν => R1 ν /\ R2 ν) a1 n (1+p1+p2).
  Proof.
    intros [ l1 r1 F0 F1 F2 F3 F4 ] [ l2 r2 G0 G1 G2 G3 G4 ] H12 ?; subst n.
    exists ((a2+n2,dee_add r1 r2)::l1++l2) (a2+n2).
    + simpl; rewrite app_length, F0, G0; omega.
    + replace (a1+(1+a2+n2-a1)) with (1+a2+n2) by omega.
      intros x c [ Hc | Hc ].
      * subst; simpl; omega.
      * intros H1; apply in_app_or in Hc; destruct Hc as [ Hc | Hc ].
        - specialize (F1 _ _ Hc H1); omega.
        - specialize (G1 _ _ Hc H1); omega.
    + omega.
    + intros f.
      destruct (F3 f) as (g1 & H1).
      destruct (G3 f) as (g2 & H2).
      destruct (@valuation_one_union (a2+n2) (g1 r1+g2 r2) (a1,a1+n1) g1 (a2,a2+n2) g2)
        as (g & Hg1 & Hg2 & Hg3); auto.
      { red; simpl; intros; omega. }
      exists g; constructor; [ | apply Forall_app; split ].
      * simpl; rewrite (Hg2 r1), (Hg3 r2); auto.
      * apply Forall_impl with (2 := H1).
        intros c Hc; apply dc_eval_ext; auto.
        intros x Hx; apply Hg2, F1 with c; auto.
      * apply Forall_impl with (2 := H2).
        intros c Hc; apply dc_eval_ext; auto.
        intros x Hx; apply Hg3, G1 with c; auto.
    + intros f; rewrite F4, G4; split.
      * intros ((g1 & H1 & H2) & (g2 & H3 & H4)).
        destruct (@valuation_one_union (a2+n2) 0 (a1,a1+n1) g1 (a2,a2+n2) g2)
          as (g & Hg1 & Hg2 & Hg3); auto.
        { red; simpl; intros; omega. }
        exists g; split; auto; constructor; simpl.
        ++ rewrite Hg1, Hg2, Hg3; auto; omega.
        ++ apply Forall_app; split.
           ** apply Forall_impl with (2 := H1).
              intros c Hc; apply dc_eval_ext; auto.
              intros x Hx; apply Hg2, F1 with c; auto.
           ** apply Forall_impl with (2 := H3).
              intros c Hc; apply dc_eval_ext; auto.
              intros x Hx; apply Hg3, G1 with c; auto.
      * intros (g & Hg1 & Hg2).
        inversion Hg1 as [ | ? ? Hg3 Hg4 ].
        apply Forall_app in Hg4; destruct Hg4 as (Hg4 & Hg5).
        simpl in Hg3; split; exists g; split; auto; omega.
  Defined.

  Lemma dio_repr_at_disj R1 a1 n1 p1 R2 a2 n2 p2 n :
          dio_repr_at R1 a1 n1 p1
       -> dio_repr_at R2 a2 n2 p2
       -> a1+n1 <= a2
       -> n = 1+a2+n2-a1
       -> dio_repr_at (fun ν => R1 ν \/ R2 ν) a1 n (1+p1+p2).
  Proof.
    intros [ l1 r1 F0 F1 F2 F3 F4 ] [ l2 r2 G0 G1 G2 G3 G4 ] H12 ?; subst n.
    exists ((a2+n2,dee_mul r1 r2)::l1++l2) (a2+n2).
    + simpl; rewrite app_length, F0, G0; omega.
    + replace (a1+(1+a2+n2-a1)) with (1+a2+n2) by omega.
      intros x c [ Hc | Hc ].
      * subst; simpl; omega.
      * intros H1; apply in_app_or in Hc; destruct Hc as [ Hc | Hc ].
        - specialize (F1 _ _ Hc H1); omega.
        - specialize (G1 _ _ Hc H1); omega.
    + omega.
    + intros f.
      destruct (F3 f) as (g1 & H1).
      destruct (G3 f) as (g2 & H2).
      destruct (@valuation_one_union (a2+n2) (g1 r1*g2 r2) (a1,a1+n1) g1 (a2,a2+n2) g2)
        as (g & Hg1 & Hg2 & Hg3); auto.
      { red; simpl; intros; omega. }
      exists g; constructor; [ | apply Forall_app; split ].
      * simpl; rewrite (Hg2 r1), (Hg3 r2); auto.
      * apply Forall_impl with (2 := H1).
        intros c Hc; apply dc_eval_ext; auto.
        intros x Hx; apply Hg2, F1 with c; auto.
      * apply Forall_impl with (2 := H2).
        intros c Hc; apply dc_eval_ext; auto.
        intros x Hx; apply Hg3, G1 with c; auto.
    + intros f; rewrite F4, G4; split.
      * intros [ (g1 & H1 & H2) | (g2 & H1 & H2) ].
        - destruct (G3 f) as (g2 & H3).
          destruct (@valuation_one_union (a2+n2) 0 (a1,a1+n1) g1 (a2,a2+n2) g2)
            as (g & Hg1 & Hg2 & Hg3); auto.
          { red; simpl; intros; omega. }
          exists g; split; auto.
          constructor; simpl; [ | apply Forall_app; split ].
          ++ rewrite Hg1, Hg2, H2; auto.
          ++ apply Forall_impl with (2 := H1).
             intros c Hc; apply dc_eval_ext; auto.
             intros x Hx; apply Hg2, F1 with c; auto.
          ++ apply Forall_impl with (2 := H3).
             intros c Hc; apply dc_eval_ext; auto.
             intros x Hx; apply Hg3, G1 with c; auto.
        - destruct (F3 f) as (g1 & H3).
          destruct (@valuation_one_union (a2+n2) 0 (a1,a1+n1) g1 (a2,a2+n2) g2)
            as (g & Hg1 & Hg2 & Hg3); auto.
          { red; simpl; intros; omega. }
          exists g; split; auto.
          constructor; simpl; [ | apply Forall_app; split ].
          ++ rewrite Hg1, (Hg3 r2), H2, mult_comm; auto.
          ++ apply Forall_impl with (2 := H3).
             intros c Hc; apply dc_eval_ext; auto.
             intros x Hx; apply Hg2, F1 with c; auto.
          ++ apply Forall_impl with (2 := H1).
             intros c Hc; apply dc_eval_ext; auto.
             intros x Hx; apply Hg3, G1 with c; auto.
      * intros (g & Hg1 & Hg2).
        inversion Hg1 as [ | ? ? Hg3 Hg4 ].
        apply Forall_app in Hg4; destruct Hg4 as (Hg4 & Hg5).
        simpl in Hg3; rewrite Hg2 in Hg3.
        symmetry in Hg3; apply mult_is_O in Hg3.
        destruct Hg3 as [ Hg3 | Hg3 ]; [ left | right ]; exists g; auto.
  Defined.

  Lemma dio_repr_at_exst R a n m p :
          dio_repr_at R a n p
       -> m = n+1
       -> dio_repr_at (fun ν => exists n, R (dv_lift ν n)) a m p.
  Proof.
    intros [ l r F0 F1 F2 F3 F4 ] ?; subst m.
    exists (map (dc_dec (a+n)) l) r.
    + rewrite map_length; auto.
    + intros x c'; rewrite in_map_iff.
      intros (c & E & Hc) H; subst.
      apply dc_vars_dec in H.
      destruct H as [ | H ]; subst; simpl; try omega.
      apply F1 in H; simpl in *; auto; omega.
    + omega.
    + intros f.
      destruct (F3 (fun x => match x with 0 => 0 | S x => f x end)) as (g & Hg).
      exists (fun x => if eq_nat_dec x (a+n) then 0 else g x).
      rewrite Forall_map.
      apply Forall_impl with (2 := Hg).
      intros c Hc; rewrite dc_eval_dec; apply dc_eval_ext; auto.
      * intros x Hx.
        destruct (eq_nat_dec x (a+n)); subst; auto.
        apply F1 in Hx; auto; omega.
      * intros [ | x ]; auto.
        destruct (eq_nat_dec (a+n) (a+n)); tauto.
    + intros f; split.
      * intros (u & Hu).
        apply F4 in Hu.
        destruct Hu as (g & H1 & H2).
        exists (fun x => if eq_nat_dec x (a+n) then u else g x); simpl; split.
        - rewrite Forall_map.
          apply Forall_impl with (2 := H1).
          intros c Hc; rewrite dc_eval_dec; apply dc_eval_ext; auto.
          ++ intros x Hx.
             destruct (eq_nat_dec x (a+n)); auto.
             subst x; apply F1 in Hx; auto; omega.
          ++ intros [ | x ]; auto.
             destruct (eq_nat_dec (a+n) (a+n)); tauto.
        - destruct (eq_nat_dec r (a+n)); auto.
          subst; omega.
      * intros (g & H1 & H2).
        exists (g (a+n)); rewrite F4.
        exists g; split; auto.
        revert H1; do 2 rewrite Forall_forall.
        intros H c Hc.
        apply in_map with (f := dc_dec _), H in Hc.
        revert Hc; rewrite dc_eval_dec; apply dc_eval_ext; auto.
  Defined.

  Fixpoint df_weight_1 f :=
    match f with
      | df_atm a b  => 4 + de_size a + de_size b
      | df_conj f g => 1 + df_weight_1 f + df_weight_1 g
      | df_disj f g => 1 + df_weight_1 f + df_weight_1 g
      | df_exst f   => 1 + df_weight_1 f
    end.

  Fact df_weigth_1_size f : df_weight_1 f <= 4*df_size f.
  Proof. induction f; simpl; omega. Qed.

  Fixpoint df_weight_2 f :=
    match f with
      | df_atm a b  => 3 + de_size a + de_size b
      | df_conj f g => 1 + df_weight_2 f + df_weight_2 g
      | df_disj f g => 1 + df_weight_2 f + df_weight_2 g
      | df_exst f   => df_weight_2 f
    end.

  Fact df_weigth_2_size f : df_weight_2 f <= 3*df_size f.
  Proof. induction f; simpl in *; omega. Qed.

  Lemma dio_repr_at_form n f : dio_repr_at (df_pred f) n (df_weight_1 f) (df_weight_2 f).
  Proof.
    revert n;
    induction f as [ a b | f IHf g IHg | f IHf g IHg | f IHf ]; intros n; simpl df_pred; simpl df_weight_1; simpl df_weight_2.
    + apply dio_repr_at_eq.
    + apply dio_repr_at_conj with (n1 := df_weight_1 f) (a2 := n+df_weight_1 f) (n2 := df_weight_1 g); auto; omega.
    + apply dio_repr_at_disj with (n1 := df_weight_1 f) (a2 := n+df_weight_1 f) (n2 := df_weight_1 g); auto; omega.
    + apply dio_repr_at_exst with (n := df_weight_1 f); auto; omega.
  Defined.

  (** For any diophantine logic formula f of size s, one can compute a list l
      of at most 1+3*s elementary diophantine constraints, containing at
      most 4*s variables and such that df_pred f ν is equivalent to
      the simultaneous satisfiability at ν of all the elementary constraints in l *)

  Theorem dio_formula_elem f : { l | length l <= 1+3*df_size f
                                 /\ (forall c x, In c l -> dc_vars c x -> x < 4*df_size f)
                                 /\  forall ν, df_pred f ν <-> exists φ, Forall (dc_eval φ ν) l }.
  Proof.
    destruct (dio_repr_at_form 0 f) as [l r H0 H1 H2 H3 H4].
    exists ((r,dee_nat 0) :: l); split; [ | split ]; simpl length; try omega.
    + rewrite H0; apply le_n_S, df_weigth_2_size.
    + intros c x [ [] | H ].
      * simpl dc_vars; intros [ | [] ]; subst.
        generalize (df_weigth_1_size f); intros; omega.
      * intros G; apply H1 in G; auto.
        generalize (df_weigth_1_size f); intros; omega.
    + intros ν; rewrite H4.
      split; intros (φ & H); exists φ; revert H; rewrite Forall_cons_inv; simpl; tauto.
  Defined.

  Definition dio_fs f := proj1_sig (dio_formula_elem f).

End diophantine_system.

(* Check dio_formula_elem.
Print Assumptions dio_formula_elem. *)


Require Import Lists.List.
Import ListNotations.

(** * Exercise 1: *)

Section Ex1.

(** Implement a datatype [Fml] of propositional formulas parameterized
over [P : Type]. *)

Inductive Fml (P: Type): Type :=
| Atom  : P -> Fml P
| Neg   : Fml P -> Fml P
| Or    : Fml P -> Fml P -> Fml P
| And   : Fml P -> Fml P -> Fml P
| Impl  : Fml P -> Fml P -> Fml P.

End Ex1.

(** * Exercise 2: recursion over lists *)

Section Ex2.

Section FoldList.

Variable A X: Type.

(** Define the signature functor [sigma_list] of lists as an inductive
type *)

Inductive sigma_list X :=
| OpNil : sigma_list X
| OpCons : A -> X -> sigma_list X.

Variable alpha : sigma_list X -> X.

(** Implement a function [fold_list : list A -> X] *)

Fixpoint fold_list (l: list A): X :=
  match l with
  | [] => alpha (OpNil _)
  | a :: xs => alpha (OpCons _ a (fold_list xs))
  end.

End FoldList.

Check fold_right.

(** Implement a function [length : list A -> nat] using [fold_list] *)

Definition length {A} :=
  fold_list A nat (fun xs => match xs with
                        | OpNil => 0
                        | OpCons _ n => S n
                        end).

Compute (length (1 :: 2 :: 3 :: 4 :: [])).

End Ex2.

(** * Exercise 3: recursion over trees *)

Section Ex3.

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

Inductive sigma_tree (X: Type): Type :=
| OpLeaf : sigma_tree X
| OpNode : nat -> X -> X -> sigma_tree X.

Section FoldTree.

Variable X: Type.
Variable alpha : sigma_tree X -> X.

(** Implement a function [fold_tree : tree -> X] *)

Fixpoint fold_tree (t: tree): X :=
    match t with
  | Leaf => alpha (OpLeaf _)
  | Node n l r => alpha (OpNode _ n (fold_tree l)
                                   (fold_tree r))
  end.

End FoldTree.

Check fold_tree.

(** Implement a function [height : tree -> nat] that computes the
maximal height of a tree *)

Definition height :=
  fold_tree nat
            (fun xs => match xs with
                    | OpLeaf => 0
                    | OpNode _ lh rh => 1 + max lh rh
                    end).

Compute (height (Node 3 (Node 0 Leaf Leaf) (Node 1 (Node 2 Leaf Leaf) Leaf))).

End Ex3.

(** * Exercise 4: Initial algebra semantics *)

Section Ex4.

(** Implement [out_tree : tree -> sigma_tree tree] *)

Definition out_tree (t: tree): sigma_tree tree :=
  match t with
  | Leaf => OpLeaf _
  | Node n l r => OpNode _ n l r
  end.

(** Implement the functorial map [sigma_tree_map : (X -> Y) ->
sigma_tree X -> sigma_tree Y] *)

Definition sigma_tree_map {X Y} (f: X -> Y)
           (xs: sigma_tree X): sigma_tree Y :=
  match xs with
  | OpLeaf => OpLeaf _
  | OpNode n l r => OpNode _ n (f l) (f r)
  end.

End Ex4.

(** * Exercise 5: Uniform induction over natural numbers *)

Section Ex5.

Hypothesis P: nat -> Type.

Inductive sigma_ind_nat: nat -> Type :=
| OpIndZ :
    sigma_ind_nat 0
| OpIndS: forall n,
    P n -> sigma_ind_nat (S n).

Fixpoint nat_rect'
         (IH: forall n, sigma_ind_nat n -> P n)
         (n: nat): P n :=
  match n with
  | 0 => IH 0 OpIndZ
  | S n => IH (S n) (OpIndS n (nat_rect' IH n))
  end.

End Ex5.

(** * Exercise 6: recursion from induction *)

Section Ex6.

Section FoldTree'.

Variable X : Type.
Variable alpha : sigma_tree X -> X.

(** Implement [fold_tree' : tree -> X] from [tree_rect] *)

Definition fold_tree' : tree -> X
  := @tree_rect (fun _ => X)
                (alpha (OpLeaf _))
                (fun n l xl r xr => alpha (OpNode _ n xl xr)).

End FoldTree'.

(** Reimplement [height : tree -> nat] using this [fold_tree'] *)

Definition height' :=
  fold_tree' nat
            (fun xs => match xs with
                    | OpLeaf => 0
                    | OpNode _ lh rh => 1 + max lh rh
                    end).

Compute (height' (Node 3 (Node 0 Leaf Leaf) (Node 1 (Node 2 Leaf Leaf) Leaf))).

End Ex6.

(** * Exercise 7: induction over tree *)

Section Ex7.

(** Implement the uniform induction principle over trees *)

Section TreeRect.

Hypothesis P: tree -> Type.

Inductive sigma_ind_tree: tree -> Type :=
| OpIndLeaf :
    sigma_ind_tree Leaf
| OpIndNode : forall n l r,
    P l -> P r -> sigma_ind_tree (Node n l r).

Fixpoint tree_rect'
         (IH: forall t, sigma_ind_tree t -> P t)
         (t : tree): P t :=
  match t with
  | Leaf => IH Leaf OpIndLeaf
  | Node n l r => IH (Node n l r)
                    (OpIndNode n l r
                               (tree_rect' IH l)
                               (tree_rect' IH r))
  end.

End TreeRect.

Section Ex7.

(** * Exercise 8: induction over rose trees *)

Section Ex8.

Inductive rosetree :=
| rosenode : nat -> list rosetree -> rosetree.

(** Implement induction over [rosetree] *)

Fixpoint rosetree_ind'
         (P: rosetree -> Prop)
         (Pl: list rosetree -> Prop)
         (IH1: forall n ts, Pl ts -> P (rosenode n ts))
         (IH2: Pl [])
         (IH3: forall t ts, P t -> Pl ts -> Pl (t :: ts))
         (t: rosetree): P t.
destruct t; apply IH1.
induction l.
- apply IH2.
- apply IH3.
  + eapply rosetree_ind'; eauto.
  + apply IHl.
Show Proof.
Defined.

End Ex8.


Require Import Coq.Unicode.Utf8.

Require Export Induction.
Require Export Basics.
Module NatList.

  Inductive natprod : Type :=
  | pair : nat → nat → natprod.

  Check (pair 3 4).

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

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

  Compute fst (3,4).

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

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

  Compute snd (4,5).

Theorem surjective_pairing_stuck : ∀ (p : natprod),
  p = (fst p, snd p).
Proof.
  destruct p.
  reflexivity.
Qed.

Theorem snd_fst_is_swap : ∀ (p : natprod),
  (snd p, fst p) = swap_pair p.
Proof.
  destruct p.
  reflexivity.
Qed.

Theorem fst_swap_is_snd : ∀ (p : natprod),
  fst (swap_pair p) = snd p.
Proof.
  destruct p.
  reflexivity.
Qed.

Inductive natlist : Type :=
  | nil : natlist
  | cons : nat → natlist → natlist.

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

Notation "[ ]" := nil.

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

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

Compute (repeat 10 42).

Fixpoint length (l : natlist) : nat :=
  match l with
  | nil => 0
  | (_ :: xs) => 1 + (length xs)
  end.

Compute length [1; 2; 3; 4].

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

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

Compute [1; 2; 3] ++ [4; 5; 6].

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

Definition tl (l : natlist) : natlist :=
  match l with
  | nil => nil
  | (x :: xs) => xs
  end.

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

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

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

Fixpoint filter (l : natlist) (p : nat → bool) : natlist :=
  match l with
  | nil => nil
  | (x :: xs) =>
    match p x with
    | true => x :: (filter xs p)
    | false => filter xs p
    end
  end.

Check beq_nat 0.

Definition nonzeros (l : natlist) : natlist :=
  filter l (fun (x : nat) => negb (beq_nat x 0)).
(* I should use composition, but I dont know how *)

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

Definition oddmembers (l : natlist) : natlist := filter l oddb.

Example test_oddmembers: oddmembers [0;1;0;2;3;0;0] = [1;3].
Proof.
  reflexivity.
Qed.

Definition countoddmembers (l : natlist) : nat := length (oddmembers l).

Compute oddmembers [1;0;3;1;4;5].

Example test_countoddmembers1: countoddmembers [1;0;3;1;4;5] = 4.
Proof.
  reflexivity.
Qed.

Example test_countoddmembers2: countoddmembers [0;2;4] = 0.
Proof.
  reflexivity.
Qed.

Example test_countoddmembers3: countoddmembers nil = 0.
Proof.
  reflexivity.
Qed.

Fixpoint alternate (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil => l2
  | (x :: xs) =>
    match l2 with
    | nil => l1
    | (y :: ys) => x :: y :: (alternate xs ys)
    end
  end.

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

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

Example test_alternate3:
  alternate [1;2;3] [4] = [1;4;2;3].
Proof.
  reflexivity.
Qed.

Example test_alternate4:
  alternate [] [20;30] = [20;30].
Proof.
  reflexivity.
Qed.

Definition bag := natlist.

Fixpoint count (v : nat) (s : bag) : nat :=
  match s with
  | nil => 0
  | (x :: xs) =>
    match beq_nat x v with
    | true => 1 + (count v xs)
    | false => count v xs
    end
  end.

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

Example test_count2: count 6 [1;2;3;1;4;1] = 0.
Proof.
  reflexivity.
Qed.

Definition sum : bag → bag → bag := app.

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

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

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

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

Definition member (v : nat) (s : bag) : bool :=
  match (length s) - (length (filter s (fun x => negb (beq_nat x v)))) with
  | O => false
  | n => true
  end.

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

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

(* Exercise: 3 stars, optional (bag_more_functions)
Muh, boring *)

Theorem tl_length_pred : ∀ l : natlist,
    pred (length l) = length (tl l).
Proof.
  destruct l.
  - reflexivity.
  - reflexivity.
Qed.

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

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

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

Example test_rev2: rev nil = nil.
Proof.
  reflexivity.
Qed.

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

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

Theorem app_nil_r : ∀ l : natlist,
  l ++ [] = l.
Proof.
  induction l as [|n l' IHl'].
  - reflexivity.
  - simpl.
    rewrite -> IHl'.
    reflexivity.
Qed.

Theorem rev_app_distr: ∀ l1 l2 : natlist,
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  induction l1 as [|n l1' IHl1'].
  - intros l2.
    simpl.
    rewrite -> app_nil_r.
    reflexivity.
  - intros l2.
    simpl.
    rewrite -> IHl1'.
    rewrite -> app_assoc.
    reflexivity.
Qed.

Theorem rev_involutive : ∀ l : natlist,
  rev (rev l) = l.
Proof.
  induction l as [|n l' IHl'].
  - reflexivity.
  - simpl.
    rewrite -> rev_app_distr.
    rewrite -> IHl'.
    reflexivity.
Qed.

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

(* TODO *) (*
Lemma nonzeros_app : ∀ l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof. *)

Fixpoint beq_natlist (l1 l2 : natlist) : bool :=
  match l1 with
  | nil =>
    match l2 with
    | nil => true
    | _ => false
    end
  | (x :: xs) =>
    match l2 with
    | nil => false
    | (y :: ys) =>
      match beq_nat x y with
      | true => beq_natlist xs ys
      | false => false
      end
    end
  end.

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

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

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

Theorem beq_natlist_refl : ∀ l : natlist,
  true = beq_natlist l l.
Proof.
  induction l as [|n l' IHl'].
  - reflexivity.
  - simpl.
    rewrite <- IHl'.
    assert (H: beq_nat n n = true). {
      induction n as [|n' IHn'].
      + reflexivity.
      + simpl.
        rewrite -> IHn'.
        reflexivity.
    }
    rewrite -> H.
    reflexivity.
Qed.

(* Boring. *)

(* Exercise: 4 stars, advanced (rev_injective) *)
Theorem rev_inj : ∀ (l1 l2 : natlist), rev l1 = rev l2 → l1 = l2.
Proof.
  intros l1 l2 Eq.
  assert (H: rev (rev l1) = l1). {
    rewrite -> rev_involutive.
    reflexivity.
  }
  rewrite <- H.
  rewrite -> Eq.
  rewrite -> rev_involutive.
  reflexivity.
Qed.

Inductive natoption : Type :=
  | Some : nat → natoption
  | None : natoption.

Fixpoint nth_error (l:natlist) (n:nat) : natoption :=
  match l with
  | nil => None
  | a :: l' => match beq_nat n O with
               | true => Some a
               | false => nth_error l' (pred n)
               end
  end.

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

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

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

Fixpoint nth_error' (l:natlist) (n:nat) : natoption :=
  match l with
  | nil => None
  | a :: l' => if beq_nat n O then Some a
               else nth_error' l' (pred n)
  end.

(* Exercise: 2 stars (hd_error) *)
(* Boring *)

Inductive id : Type :=
| Id : nat → id.

Definition beq_id (x1 x2 : id) :=
  match x1, x2 with
  | Id n1, Id n2 => beq_nat n1 n2
  end.

Theorem beq_id_refl : ∀ x, true = beq_id x x.
Proof.
  destruct x.
  induction n as [|n' IHn'].
  - reflexivity.
  - rewrite -> IHn'.
    reflexivity.
Qed.

End NatList.

Module PartialMap.

  Export NatList.

  Inductive partial_map : Type :=
  | empty : partial_map
  | record : id → nat → partial_map → partial_map.

  Definition update (d : partial_map) (x : id) (value : nat) : partial_map :=
    record x value d.

  Fixpoint find (x : id) (d : partial_map) : natoption :=
    match d with
    | empty => None
    | record y v d' => if beq_id x y
                      then Some v
                      else find x d'
    end.

  Compute find (Id 2) (record (Id 1) 42 (record (Id 2) 16 empty)).

Theorem update_eq :
  ∀ (d : partial_map) (x : id) (v: nat),
    find x (update d x v) = Some v.
Proof.
  intros d x v.
  simpl.
  rewrite <- beq_id_refl.
  reflexivity.
Qed.

Theorem update_neq :
  ∀ (d : partial_map) (x y : id) (o: nat),
    beq_id x y = false → find x (update d y o) = find x d.
Proof.
  intros d x y o.
  intros H.
  simpl.
  rewrite -> H.
  reflexivity.
Qed.

End PartialMap.


Inductive I (A : Type) (x : A) : A -> Type :=
  refl : I A x x.

Arguments refl {_} _.

Notation "x = y" := (I _ x y): type_scope.

Definition subst (A:Type) (t:A) (P : forall y:A, t = y -> Type)
           (u : A) (p : t = u) (v:P t (refl t)) : P u p :=
  match p with
  | refl _ => v (* : P t (refl t) *)
  end.

Section subst_computation.

  Variable A : Type.
  Variable t : A.
  Variable P : forall y:A, t = y -> Type.
  Variable v : P t (refl t).

  Eval cbn in
      subst A t P t (refl t) v.

End subst_computation.

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

Fixpoint rec (P : nat -> Type) (P0 : P O) (PS: forall n : nat, P n -> P (S n)) (n : nat) : P n :=
  match n with
  | O => P0
  | S n' => PS n' (rec P P0 PS n')
  end.

Section nat_computation.

  Variable n : nat.
  Variable P : nat -> Type.
  Variable P0 : P O.
  Variable PS : forall n : nat, P n -> P (S n).

  Eval cbn in
      rec P P0 PS O.

  Eval cbn in
      rec P P0 PS (S n).

  Eval cbn in
      rec P P0 PS (S (S (S O))).

End nat_computation.

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

Check (fun m => refl m) : forall m:nat, plus O m = m.

Fail Check (fun n => refl n) : forall n:nat, plus n O = n.

Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
  := match p with refl _ => refl (f x) end.

Fixpoint plus_O_r (n : nat) : plus n O = n :=
  match n with
  | O => refl O (* : plus O O = O *)
  | S n' => ap S (plus_O_r n') (* S (plus  n' 0) = S n' *)
  end.

(* Alternative definition of dependent pairs  *)

Inductive sigma (A: Type) (B: A -> Type) : Type :=
  | exist : forall (a:A), B a -> sigma A B.


(** %\chapter{Inductive Reasoning in SSReflect}% *)

From mathcomp
Require Import ssreflect eqtype ssrnat ssrbool ssrfun seq.
Module SsrStyle.

(**

In the rest of this lecture we will be constantly relying on a series
of standard SSReflect modules, such as [ssrbool], [ssrnat] and
[eqtype], which we import right away.

*)

(**  * Structuring the proof scripts

An important part of the proof process is keeping to an established
proof layout, which helps to maintain the proofs readable and restore
the intuition driving the prover's hand.  SSReflect offers a number of
syntactic primitives that help to maintain such a layout, and in this
section we give a short overview of them. As usual, the SSReflect
reference manual provides an exhaustive formal definition of each
primitive's semantics, so we will just cover the base cases here,
hoping that the subsequent proofs will provide more intuition on
typical usage scenarios.

** Bullets and terminators

*)

Lemma andb_true_elim b c: b && c -> c = true.

Proof.
case: c.

(**
[[
true = true

subgoal 2 (ID 15) is:
 b && false -> false = true
]]
*)

- by case: b.

(** ** Using selectors and discharging subgoals

Let us restart this proof and show an alternative way to structure the
proof script, which should account for multiple cases.

*)

Restart.

case: c; first by [].

(**
[[
  b : bool
  ============================
   b && false -> false = true
]]
*)

Restart.

case:c; [by [] | by case: b].

(**

The script above solves the first generated goal using [by []], and
then solves the second one via [by case: b].

*)

(** ** Iteration and alternatives *)

Restart.

by do ![done | apply: eqxx | case: b | case: c].

Qed.

(** * Inductive predicates that should be functions *)

Inductive isZero (n: nat) : Prop := IsZero of n = 0.

(**

Naturally, such equality can be exploited to derived paradoxes, as the
following lemma shows:

*)

Lemma isZero_paradox: isZero 1 -> False.
Proof. by case. Qed.

(**

However, the equality on natural numbers is, decidable, so the very
same definition can be rewritten as a function employing the boolean
equality [(==)], which will make the proofs of paradoxes even shorter
than they already are:

*)

Definition is_zero n : bool := n == 0.

Lemma is_zero_paradox: is_zero 1 -> False.
Proof. done. Qed.

(**

That is, instead of the unavoidable case-analysis with the first
[Prop]-based definition, the functional definition made Coq compute
the result for us, deriving the falsehood automatically.

The benefits of the computable definitions become even more obvious
when considering the next example, the predicate defining whether a
natural number is even or odd. Again, we define two versions, the
inductive predicate and a boolean function.

*)

Inductive evenP n : Prop :=
  Even0 of n = 0 | EvenSS m of n = m.+2 & evenP m.

Fixpoint evenb n := if n is n'.+2 then evenb n' else n == 0.

(**

Let us now prove a simple property: that fact that [(n + 1 + n)] is
even leads to a paradox. We first prove it for the version defined in
[Prop].

*)

Lemma evenP_contra n : evenP (n + 1 + n) -> False.
Proof.
elim: n=>//[| n Hn]; first by rewrite addn0 add0n; case=>//.

(**
[[
  n : nat
  Hn : evenP (n + 1 + n) -> False
  ============================
   evenP (n.+1 + 1 + n.+1) -> False
]]
*)

rewrite addn1 addnS addnC !addnS.
rewrite addnC addn1 addnS in Hn.

(**
[[
  n : nat
  Hn : evenP (n + n).+1 -> False
  ============================
   evenP (n + n).+3 -> False
]]
*)

case=>// m /eqP.

(**

[[
  n : nat
  Hn : evenP (n + n).+1 -> False
  m : nat
  ============================
   (n + n).+3 = m.+2 -> evenP m -> False
]]
*)

by rewrite !eqSS; move/eqP=><-.
Qed.

(**

Now, let us take a look at the proof of the same fact, but with the
computable version of the predicate [evenb].

*)

Lemma evenb_contra n: evenb (n + 1 + n) -> False.
Proof.
elim: n=>[|n IH] //.

(**
[[
  n : nat
  IH : evenb (n + 1 + n) -> False
  ============================
   evenb (n.+1 + 1 + n.+1) -> False
]]
*)

by rewrite addSn addnS.
Qed.

(**

Sometimes, though, the value "orbits", which can be advantageous for
the proofs involving [bool]-returning predicates, might require a bit
trickier induction hypotheses than just the statement required to be
proved. Let us compare the two proofs of the same fact, formulated
with [evenP] and [evennb].

*)

Lemma evenP_plus n m : evenP n -> evenP m -> evenP (n + m).
Proof.
elim=>//n'; first by move=>->; rewrite add0n.

(**

[[
  n : nat
  m : nat
  n' : nat
  ============================
   forall m0 : nat,
   n' = m0.+2 ->
   evenP m0 -> (evenP m -> evenP (m0 + m)) -> evenP m -> evenP (n' + m)
]]
*)

move=> m'->{n'} H1 H2 H3; rewrite addnC !addnS addnC.

(**

[[
  n : nat
  m : nat
  m' : nat
  H1 : evenP m'
  H2 : evenP m -> evenP (m' + m)
  H3 : evenP m
  ============================
   evenP (m' + m).+2
]]

*)

Check EvenSS.

(**
[[
EvenSS
     : forall n m : nat, n = m.+2 -> evenP m -> evenP n
]]
*)

apply: (EvenSS _ (m' + m))=>//.

(**

[[
  n : nat
  m : nat
  m' : nat
  H1 : evenP m'
  H2 : evenP m -> evenP (m' + m)
  H3 : evenP m
  ============================
   evenP (m' + m)
]]

*)

by apply: H2.

Qed.

(**

In this particular case, the resulting proof was quite
straightforward, thanks to the explicit equality [n = m.+2] in the
definition of the [EvenSS] constructor.

In the case of the boolean specification, though, the induction should
be done on the natural argument itself, which makes the first attempt
of the proof to be not entirely trivial.

*)

Lemma evenb_plus n m : evenb n -> evenb m -> evenb (n + m).
Proof.
elim: n=>[|n Hn]; first by rewrite add0n.

(**
[[
  m : nat
  n : nat
  Hn : evenb n -> evenb m -> evenb (n + m)
  ============================
   evenb n.+1 -> evenb m -> evenb (n.+1 + m)
]]

The problem now is that, if we keep building the proof by induction on
[n] or [m], the induction hypothesis and the goal will be always
"mismatched" by one, which will prevent us finishing the proof using
the hypothesis.

There are multiple ways to escape this vicious circle, and one of them
is to _generalize_ the induction hypothesis. To do so, let us restart
the proof.

*)

Restart.

move: (leqnn n).

(**

[[
  n : nat
  m : nat
  ============================
   n <= n -> evenb n -> evenb m -> evenb (n + m)
]]

Now, we are going to proceed with the proof by _selective_ induction
on [n], such that some of its occurrences in the goal will be a
subject of inductive reasoning (namely, the second one), and some
others will be left generalized (that is, bound by a forall-quantified
variable). We do so by using SSReflect's tactics [elim] with explicit
_occurrence selectors_.

*)

elim: n {-2}n.

(**

[[
  m : nat
  ============================
   forall n : nat, n <= 0 -> evenb n -> evenb m -> evenb (n + m)

subgoal 2 (ID 860) is:
 forall n : nat,
 (forall n0 : nat, n0 <= n -> evenb n0 -> evenb m -> evenb (n0 + m)) ->
 forall n0 : nat, n0 <= n.+1 -> evenb n0 -> evenb m -> evenb (n0 + m)
]]

The same effect could be achieved by using [elim: n {1 3 4}n], that
is, indicating which occurrences of [n] _should_ be generalized,
instead of specifying, which ones should not (as we did by means of
[{-2}n]).

*)

- by case=>//.

(**

For the second goal, we first move some of the assumptions to the context.

*)

move=>n Hn.

(**
[[
  m : nat
  n : nat
  Hn : forall n0 : nat, n0 <= n -> evenb n0 -> evenb m -> evenb (n0 + m)
  ============================
   forall n0 : nat, n0 <= n.+1 -> evenb n0 -> evenb m -> evenb (n0 + m)
]]

We then perform the case-analysis on [n0] in the goal, which results
in two goals, one of which is automatically discharged.

*)

case=>//.

(**

[[
  m : nat
  n : nat
  Hn : forall n0 : nat, n0 <= n -> evenb n0 -> evenb m -> evenb (n0 + m)
  ============================
   forall n0 : nat, n0 < n.+1 -> evenb n0.+1 -> evenb m -> evenb (n0.+1 + m)
]]

Doing _one more_ case analysis will adde one more [1] to the induction
variable [n0], which will bring us to the desired [(.+2)]-orbit.

*)

case=>// n0.

(**
[[
  m : nat
  n : nat
  Hn : forall n0 : nat, n0 <= n -> evenb n0 -> evenb m -> evenb (n0 + m)
  n0 : nat
  ============================
   n0.+1 < n.+1 -> evenb n0.+2 -> evenb m -> evenb (n0.+2 + m)
]]

The only thing left to do is to tweak the top assumption (by relaxing
the inequality via the [ltnW] lemma), so we could apply the induction
hypothesis [Hn].

*)

by move/ltnW /Hn=>//.
Qed.

(** ** Eliminating assumptions with a custom induction hypothesis

The functions like [evenb], with specific value orbits, are not
particularly uncommon, and it is useful to understand the key
induction principles to reason about them. In particular, the above
discussed proof could have been much more straightforward if we first
proved a different induction principle [nat2_ind] for natural numbers.

*)

Lemma nat2_ind (P: nat -> Prop):
  P 0 -> P 1 -> (forall n, P n -> P (n.+2)) -> forall n, P n.
Proof.
move=> H0 H1 H n.

(**
[[
  P : nat -> Prop
  H0 : P 0
  H1 : P 1
  H : forall n : nat, P n -> P n.+2
  n : nat
  ============================
   P n
]]

Unsurprisingly, the proof of this induction principle follows the same
pattern as the proof of [evenb_plus]---generalizing the hypothesis. In
this particular case, we generalize it in the way that it would
provide an "impedance matcher" between the 1-step "default" induction
principle on natural numbers and the 2-step induction in the
hypothesis [H]. We show that for the proof it is sufficient to
establish [(P n /\ P (n.+1))]:

*)

suff: (P n /\ P (n.+1)) by case.

(**

The rest of the proof proceeds by the standard induction on [n].

*)

by elim: n=>//n; case=> H2 H3; split=>//; last by apply: H.
Qed.

(**

Now, since the new induction principle [nat2_ind] exactly matches the
2-orbit, we can directly employ it for the proof of the previous result.

*)

Lemma evenb_plus' n m : evenb n -> evenb m -> evenb (n + m).
Proof.
by elim/nat2_ind : n.
Qed.

(**

Notice that we used the version of the [elim] tactics with specific
_elimination view_ [nat2_ind], different from the default one, which
is possible using the view tactical [/]. In this sense, the "standard
induction" [elim: n] would be equivalent to [elim/nat_ind: n].

*)

(** * Inductive predicates that are hard to avoid *)

Inductive beautiful (n: nat) : Prop :=
| b_0 of n = 0
| b_3 of n = 3
| b_5 of n = 5
| b_sum n' m' of beautiful n' & beautiful m' & n = n' + m'.

(**

The number is beautiful if it's either [0], [3], [5] or a sum of two
beautiful numbers. Indeed, there are many ways to decompose some
numbers into the sum $3 * n + 5 * n$. Encoding a function,
which checks whether a number is beautiful or not, although not
impossible, is not entirely trivial (and, in particular, it's not
trivial to prove the correctness of such function with respect to the
definition above). Therefore, if one decides to stick with the
predicate definition, some operations become tedious, as, even for
constants the property should be _inferred_ rather than proved:

*)

Theorem eight_is_beautiful: beautiful 8.
Proof.
apply: (b_sum _ 3 5)=>//; first by apply: b_3.
by apply b_5.
Qed.

Theorem b_times2 n: beautiful n ->  beautiful (2 * n).
Proof.
by move=>H; apply: (b_sum _ n n)=>//; rewrite mul2n addnn.
Qed.

(**

In particular, the negation proofs become much less straightforward
than one would expect:

*)

Lemma one_not_beautiful n:  n = 1 -> ~ beautiful n.
Proof.
move=>E H.

(**

[[
  n : nat
  E : n = 1
  H : beautiful n
  ============================
   False
]]
*)

elim: H E=>n'; do?[by move=>->].
move=> n1 m' _ H2 _ H4 -> {n' n}.

(**

Notice how the assumptions [n'] and [n] are removed from the context
(since we don't need them any more) by enumerating them using [{n' n}]
notation.

*)

case: n1 H2=>// n'=> H3.
by case: n' H3=>//; case.
Qed.

(** * Working with SSReflect libraries

We conclude this chapter with a short overview of a subset of the
standard SSReflect programming and naming policies, which will,
hopefully, simplify the use of the libraries in a standalone
development.

** Notation and standard operation properties

SSReflect's module [ssrbool] introduces convenient notation for
predicate connectives, such as [/\] and [\/]. In particular, multiple
conjunctions and disjunctions are better to be written as [[ /\ P1, P2
& P3]] and [[ \/ P1, P2 | P3]], respectively, opposed to [P1 /\ P2 /\
P3] and [P1 \/ P2 \/ P3]. The specific notation makes it more
convenient to use such connectives in the proofs that proceed by case
analysis. Compare.

*)

Lemma conj4 P1 P2 P3 P4 : P1 /\ P2 /\ P3 /\ P4 -> P3.
Proof. by case=>p1 [p2][p3]. Qed.

Lemma conj4' P1 P2 P3 P4 : [ /\ P1, P2, P3 & P4] -> P3.
Proof. by case. Qed.

Locate "_ ^~ _".
(**
[[
"f ^~ y" := fun x => f x y     : fun_scope
]]

For instance, this is how one can now express the partially applied
function, which applies its argument to the list [[:: 1; 2; 3]]:

*)

Check map ^~ [:: 1; 2; 3].

(**

[[
map^~ [:: 1; 2; 3]
     : (nat -> ?2919) -> seq ?2919
]]

Finally, [ssrfun] defines a number of standard operator properties,
such as commutativity, distributivity etc in the form of the
correspondingly defined predicates: [commutative], [right_inverse]
etc. For example, since we have now [ssrbool] and [ssrnat] imported,
we can search for left-distributive operations defined in those two
modules (such that they come with the proofs of the corresponding
predicates):

*)

Search _ (left_distributive _).

(**

[[
andb_orl  left_distributive andb orb
orb_andl  left_distributive orb andb
andb_addl  left_distributive andb addb
addn_maxl  left_distributive addn maxn
addn_minl  left_distributive addn minn
...
]]
*)

(** ** A library for lists

For instance, properties of some of the functions, such as _list
reversal_ are simpler to prove not by the standard "direct" induction
on the list structure, but rather iterating the list from its last
element, for which the [seq] library provides the necessary definition
and induction principle:

[[
Fixpoint rcons s z := if s is x :: s' then x :: rcons s' z else [:: z].
]]

*)

Check last_ind.

(**

[[
last_ind
     : forall (T : Type) (P : seq T -> Type),
       P [::] ->
       (forall (s : seq T) (x : T), P s -> P (rcons s x)) ->
       forall s : seq T, P s
]]

To demonstrate the power of the library for reasoning with lists, let
us prove the following property, known as _Dirichlet's box principle_
(sometimes also referred to as _pigeonhole principle_).

*)

Variable A : eqType.

Fixpoint has_repeats (xs : seq A) :=
  if xs is x :: xs' then (x \in xs') || has_repeats xs' else false.

(**

The following lemma states that for two lists [xs1] and [xs2], is the
size [xs2] is strictly smaller than the size of [xs1], but
nevertheless [xs1] as a set is a subset of [xs2] then there ought to
be repetitions in [xs1].

*)

Theorem dirichlet xs1 xs2 :
        size xs2 < size xs1 -> {subset xs1 <= xs2} -> has_repeats xs1.
Proof.

(**

First, the proof scripts initiates the induction on the structure of
the first, "longer", list [xs1], simplifying and moving to the context
some hypotheses in the "step" case (as the [nil]-case is proved
automatically).

*)

elim: xs1 xs2=>[|x xs1 IH] xs2 //= H1 H2.

(**
[[
  x : A
  xs1 : seq A
  IH : forall xs2 : seq A,
       size xs2 < size xs1 -> {subset xs1 <= xs2} -> has_repeats xs1
  xs2 : seq A
  H1 : size xs2 < (size xs1).+1
  H2 : {subset x :: xs1 <= xs2}
  ============================
   (x \in xs1) || has_repeats xs1
]]
*)

case H3: (x \in xs1) => //=.
(**
[[
  ...
  H3 : (x \in xs1) = false
  ============================
   has_repeats xs1
]]
*)

pose xs2' := filter (predC (pred1 x)) xs2.
apply: (IH xs2'); last first.

(**
[[
  ...
  H2 : {subset x :: xs1 <= xs2}
  H3 : (x \in xs1) = false
  xs2' := [seq x <- xs2 | (predC (pred1 x)) x0] : seq A
  ============================
   {subset xs1 <= xs2'}

subgoal 2 (ID 5716) is:
 size xs2' < size xs1
]]
*)

- move=>y H4; move: (H2 y); rewrite inE H4 orbT mem_filter /=.
  by move => -> //; case: eqP H3 H4 => // ->->.

(**

The second goal requires to prove the inequality, which states that
after removal of [x] from [xs2], the length of the resulting list
[xs2] is smaller than the length of [xs1].

*)

rewrite ltnS in H1; apply: leq_trans H1.
rewrite -(count_predC (pred1 x) xs2) -addn1 addnC.
rewrite /xs2' size_filter leq_add2r -has_count.

(**
[[
  ...
  H2 : {subset x :: xs1 <= xs2}
  H3 : (x \in xs1) = false
  xs2' := [seq x <- xs2 | (predC (pred1 x)) x0] : seq A
  ============================
   has (pred1 x) xs2
]]
*)

by apply/hasP; exists x=>//=; apply: H2; rewrite inE eq_refl.
Qed.

(*******************************************************************)
(**                     * Exercices *                              *)
(*******************************************************************)

(**
---------------------------------------------------------------------
Exercise [Integer binary division]
---------------------------------------------------------------------

Let us define the binary division function [div2] as follows.
*)

Fixpoint div2 (n: nat) := if n is p.+2 then (div2 p).+1 else 0.

(**

Prove the following lemma directly by induction on [n], _without_
using the [nat2_ind] induction principle. Then prove it using
[nat2_ind].

*)

Lemma div2_le n: div2 n <= n.
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

(**
---------------------------------------------------------------------
Exercise [Some facts about beautiful numbers]
---------------------------------------------------------------------

Proof the following theorem about beautiful numbers.

Hint: Choose wisely, what to build the induction on.
*)

Lemma b_timesm n m: beautiful n ->  beautiful (m * n).
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

(**
---------------------------------------------------------------------
Exercise [Gorgeous numbers]
---------------------------------------------------------------------

To practice with proofs by induction, let us consider yet another
inductive predicate, defining which of natural numbers are _gorgeous_.

*)

Inductive gorgeous (n: nat) : Prop :=
| g_0 of n = 0
| g_plus3 m of gorgeous m & n = m + 3
| g_plus5 m of gorgeous m & n = m + 5.

(**
Prove by induction the following statements about gorgeous numbers.

Hint: As usual, do not hesitate to use the [Search] utility for
finding the necessary rewriting lemmas from the [ssrnat] module.
*)

Lemma gorgeous_plus13 n: gorgeous n -> gorgeous (n + 13).
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

Lemma beautiful_gorgeous (n: nat) : beautiful n -> gorgeous n.
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

Lemma g_times2 (n: nat): gorgeous n -> gorgeous (n * 2).
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

Lemma gorgeous_beautiful (n: nat) : gorgeous n -> beautiful n.
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

(**
---------------------------------------------------------------------
Exercise [Gorgeous reflection]
---------------------------------------------------------------------

Gorgeous and beautiful numbers, defining, in fact, exactly the same
subset of [nat] are a particular case of Frobenius coin problem, which
asks for the largest integer amount of money, that cannot be obtained
using only coins of specified denominations.  In the case of
[beautiful] and [gorgeous] numbers we have two denominations
available, namely 3 and 5. An explicit formula exists for the case
of only two denominations n_1 and n_2, which allows one to compute
the Frobenius number as

g(n_1, n_2) = n_1 * n_2 - n_1 - n_2.

That said, for the case n_1 = 3 and n_2 = 5 the Frobenius number is 7,
which means that all numbers greater or equal than 8 are in fact
beautiful and gorgeous (since the two are equivalent, as was
established by the previous exercise).

In this exercise, we suggest the reader to prove that the efficient
procedure of "checking" for gorgeousness is in fact correct. First,
let us defined the following candidate function.

*)

Fixpoint gorgeous_b n : bool := match n with
 | 1 | 2 | 4 | 7 => false
 | _ => true
 end.

(**

The ultimate goal of this exercise is to prove the proposition
[reflect (gorgeous n) (gorgeous_b n)], which would mean that the two
representations are equivalent. Let us divide the proof into two
stages:

- The first stage is proving that all numbers greater or equal than
  8 are gorgeous. To prove thism it might be useful to have the
  following two facts established:

Hint: Use the tactic [constructor i] to prove a goal, which is an
n-ary disjunction, which is satisfied if its i-th disjunct is true.

*)

Lemma repr3 n : n >= 8 ->
  exists k, [\/ n = 3 * k + 8, n = 3 * k + 9 | n = 3 * k + 10].
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

Lemma gorg3 n : gorgeous (3 * n).
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

(**

Next, we can establish by induction the following criteria using the
lemmas [repr3] and [gorg3] in the subgoals of the proof.

*)

Lemma gorg_criteria n : n >= 8 -> gorgeous n.
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

(**

This makes the proof of the following lemma trivial.

*)

Lemma gorg_refl' n: n >= 8 -> reflect (gorgeous n) true.
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

(**

- In the second stage of the proof of reflection, we will
  need to prove four totally boring but unavoidable lemmas.

Hint: The rewriting lemmas [addnC] and [eqSS] from the [ssrnat]
module might be particularly useful here.

*)

Lemma not_g1: ~(gorgeous 1).
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

Lemma not_g2: ~(gorgeous 2).
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

Lemma not_g4: ~(gorgeous 4).
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

Lemma not_g7: ~(gorgeous 7).
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

(**

We can finally provide prove the ultimate reflection predicate,
relating [gorgeous] and [gorgeous_b].

*)
Lemma gorg_refl n : reflect (gorgeous n) (gorgeous_b n).
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

(**
---------------------------------------------------------------------
Exercise [Boolean element inclusion predicate for lists]
---------------------------------------------------------------------

Assuming a type [X] with the boolean equality (i.e., elements of [X]
can be compared for being equal using the [==] operator returning
[true] or [false]), define a recursive funciton [appears_in] on lists
that takes an element [a : X], a list [l : seq X] and returns a
boolean value indicating whether [a] appears in [l] or not.

*)

Section Appears_bool.
Variable X: eqType.

Fixpoint appears_in (a: X) (l: seq X) : bool :=
(* fill in your implemenation istead of the [false] stub *)
  false.

(**

Next, prove the following lemma, relating [appears_in] and list
concatenation [++].

*)

Lemma appears_in_app (xs ys : seq X) (x:X):
     appears_in x (xs ++ ys) = appears_in x xs || appears_in x ys.
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

(**

Let us define the functions [disjoint] and [no_repeats] using
[appears_in] as follows:

*)

Fixpoint disjoint (l1 l2: seq X): bool :=
  if l1 is x::xs then ~~(appears_in x l2) && disjoint xs l2 else true.

Fixpoint no_repeats (ls : seq X) :=
  if ls is x :: xs then ~~ (appears_in x xs) && no_repeats xs else true.

(**

Finally, prove the following lemma, realting [no_repeats] and
[disjoint].

*)

Theorem norep_disj_app l1 l2:
  no_repeats l1 -> no_repeats l2 -> disjoint l1 l2 -> no_repeats (l1 ++ l2).
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

End Appears_bool.

Eval compute in appears_in (EqType nat _) 1 [:: 1; 2; 3].
(* true *)

Eval compute in appears_in (EqType nat _) 1 [:: 2; 4; 3].
(* false *)

(**
---------------------------------------------------------------------
Exercise [Element inclusion predicate for lists in Prop]
---------------------------------------------------------------------

For types [Y] with propositional equality, define the [appears_inP]
predicate, which returns [Prop].

*)

Section Appears_Prop.
Variable Y: Type.

Variable appears_inP : forall (a: Y) (l: seq Y), Prop.
(* Replace Variable by the actual implementation *)

(**
Prove the lemma [appears_in_appP]:
*)

Lemma appears_in_appP (xs ys : seq Y) (x:Y):
     appears_inP x (xs ++ ys) <-> appears_inP x xs \/ appears_inP x ys.
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

(**

Finally, define the [Prop]-versions of the [disjoint] and [no_repeat]
predicates: [disjointP] and [no_repeatP] and prove the following lemma
relating them.

*)

Variable disjointP : forall (l1 l2: seq Y), Prop.
(* Replace Variable by the actual implementation *)

Variable no_repeatsP : forall (ls : seq Y), Prop.
(* Replace Variable by the actual implementation *)

Theorem norep_disj_appP l1 l2:
  no_repeatsP l1 -> no_repeatsP l2 -> disjointP l1 l2 -> no_repeatsP (l1 ++ l2).
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

End Appears_Prop.

(**
---------------------------------------------------------------------
Exercise ["All" predicate for lists]
---------------------------------------------------------------------

Define two version of version of "all-elements-satisfy" predicate for
lists.

- The version [all] takes a type [X], a predicate [P : X -> Prop] and
  a list [ls: seq X] and returns element of sort [Prop] which carries
  a proof that all elements of ls satisfy [P].

- The decidable version [allb] takes a type [X], a predicate [test : X
  -> bool] and a list [ls: seq X], and returns a boolean result.

Prove the lemma [allP], stating that the two representations are
equivalent whenever [P] and [test] are equivalent.

*)

Variable all : forall {X} (P : X -> Prop) (ls: seq X), Prop.
(* Replace Variable by the actual implementation *)

Variable allb : forall {X : Type} (test : X -> bool) (ls : seq X), bool.
(* Replace Variable by the actual implementation *)

Lemma allP T P test:
  (forall x: T, reflect (P x) (test x)) ->
  forall ls, reflect (all P ls) (allb test ls).
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

End SsrStyle.