(** * Maps: Total and Partial Maps *)

(** _A lot of text needs written here_... *)

(** Maps (aka dictionaries) are ubiquitous data structures in software
    construction in general and, in particular, in the theory of
    programming languages.  We're going to need them in many places in
    the coming chapters.  They also make a nice case study using
    several of the ideas we've seen in previous chapters, including
    building data structures out of higher-order functions (from
    [Basics] and [Poly]) and the use of reflection in proofs (from
    [IndProp]).

    We'll define two flavors of maps: _total_ maps, which include a
    "default" element to be returned when a key being looked up
    doesn't exist in the map, and _partial_ maps, which return an
    [option].  The latter is defined in terms of the former (using
    [None] as the default element). *)

(* ###################################################################### *)
(** * Coq's Standard Library *)

(** One small digression before we start.  Unlike the chapters we have
    seen so far, this one is not going to [Import] the chapter before
    it (and, transitively, all the earlier chapters).  Instead, in
    this chapter and from now, on we're going to import the
    definitions and theorems we need directly from Coq's standard
    library stuff.  You should not notice much difference, though,
    because we've been careful to name our own definitions and
    theorems consistently with their counterparts in the standard
    library. *)

Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Logic.FunctionalExtensionality.

(** Documentation for the standard library can be found at
    http://coq.inria.fr/library/. *)
(**  What's the best way to search for things in the library?
 *)

(* ###################################################################### *)
(** * Identifiers *)

(** First, we need a type of keys for our maps.  We repeat the
    definition of [id]s from the [Lists] chapter, plus the equality
    comparison function for [id]s and its fundamental property: *)

Inductive id : Type :=
  | Id : nat -> id.

Definition beq_id id1 id2 :=
  match id1,id2 with
    | Id n1, Id n2 => beq_nat n1 n2
  end.

Theorem beq_id_refl : forall id, true = beq_id id id.
Proof.
  intros [n]. simpl. rewrite <- beq_nat_refl.
  reflexivity. Qed.

Check ((Id 1) = (Id 2)).

(** The following useful property of [beq_id] follows from a similar
    lemma about numbers: *)

Theorem beq_id_true_iff : forall id1 id2 : id,
  beq_id id1 id2 = true <-> id1 = id2.
Proof.
   intros [n1] [n2].
   unfold beq_id.
   rewrite beq_nat_true_iff.
   split.
   - (* -> *) intros H. rewrite H. reflexivity.
   - (* <- *) intros H. inversion H. reflexivity.
Qed.

(** (Note that [beq_nat_true_iff] was not proved above; it can be
    found in the standard library.) *)

(** Similarly: *)

Theorem beq_id_false_iff : forall x y : id,
  beq_id x y = false <-> x <> y.
Proof.
  intros x y. rewrite <- beq_id_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.

(** Now this useful variant follows just by rewriting: *)

Theorem false_beq_id : forall x y : id,
   x <> y  -> beq_id x y = false.
Proof.
  intros x y. rewrite beq_id_false_iff.
  intros H. apply H. Qed.

(* ###################################################################### *)
(** * Total Maps *)

(** Our main job in this chapter is to build a definition of partial
    maps that is similar in behavior to the one we saw in the [Poly]
    chapter, plus accompanying lemmas about their behavior.  This time
    around, though, we're going to use _functions_ rather than lists
    of key-value pairs to build maps.  The advantage of this
    representation is that it offers a more _extensional_ view of
    maps, where two maps that respond to queries in the same way will
    be represented as literally the same thing (the same function),
    rather than just "equivalent" data structures.  This, in turn,
    simplifies proofs that use maps.

    We build partial maps in two steps.  First, we define a type of
    _total maps_ that return a default value when we look up a key
    that is not present in the map. *)

Definition total_map (A:Type) := id -> A.

(** Intuitively, a total map over an element type [A] _is_ just a
    function that can be used to look up [id]s, yielding [A]s.

    The function [t_empty] yields an empty total map, given a default
    element, which always returns the default element when applied to
    any id. *)

Definition t_empty {A:Type} (v : A) : total_map A :=
  (fun _ => v).

Compute ((t_empty false) (Id 1)).
Compute (total_map nat).

(** More interesting is the [update] function, which (as before) takes
    a map [m], a key [x], and a value [v] and returns a new map that
    takes [x] to [v] and takes every other key to whatever [m] does. *)

Definition t_update {A:Type} (m : total_map A)
                    (x : id) (v : A) :=
  fun x' => if beq_id x x' then v else m x'.

(** This definition is a nice example of higher-order programming.
    The [t_update] function takes a _function_ [m] and yields a new
    function [fun x' => ...] that behaves like the desired map.

    For example, we can build a map taking [id]s to [bool]s, where [Id
    3] is mapped to [true] and every other key is mapped to [false],
    like this: *)

Definition m0 := t_empty 0.
Definition m1 := t_update m0 (Id 1) 1.
Definition m2 := t_update m1 (Id 2) 2.
Definition m3 := t_update m2 (Id 2) 20.
Compute (m0 (Id 1)).
Compute (m1 (Id 1)).
Compute (m2 (Id 1)).
Compute (m2 (Id 2)).
Compute (m3 (Id 2)).

Definition examplemap :=
  t_update (t_update (t_empty false) (Id 1) false)
           (Id 3) true.

(** This completes the definition of total maps.  Note that we don't
    need to define a [find] operation because it is just function
    application! *)

Example update_example1 : examplemap (Id 0) = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap (Id 1) = false.
Proof. reflexivity. Qed.

Example update_example3 : examplemap (Id 2) = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap (Id 3) = true.
Proof. reflexivity. Qed.

(** To reason about maps in later chapters, we need to establish
    several fundamental facts about how they behave.  (Even if you
    don't work the following exercises, make sure you thoroughly
    understand the statements of the lemmas!)  Some of the proofs will
    require the functional extensionality axiom discussed in the
    [Logic] chapter. *)

(** **** Exercise: 2 stars, optional (t_update_eq)  *)
(** First, if we update a map [m] at a key [x] with a new value [v]
    and then look up [x] in the map resulting from the [update], we
    get back [v]: *)

Lemma t_update_eq : forall A (m: total_map A) x v,
  (t_update m x v) x = v.
Proof.
  intros. unfold t_update. destruct (beq_id x x).
    + reflexivity.
    + admit.
Qed.

(** **** Exercise: 2 stars, optional (t_update_neq)  *)
(** On the other hand, if we update a map [m] at a key [x1] and then
    look up a _different_ key [x2] in the resulting map, we get the
    same result that [m] would have given: *)

Theorem t_update_neq : forall (X:Type) v x1 x2
                         (m : total_map X),
  x1 <> x2 ->
  (t_update m x1 v) x2 = m x2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_shadow)  *)
(** If we update a map [m] at a key [x1] with a value [v1] and then
    update again with the same key [x1] and another value [x2], then
    the resulting map behaves the same (i.e., it gives the same result
    whwn applied to any key [x2]) as the simpler map obtained by
    performing just the second [update] on [m]: *)

Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x,
    t_update (t_update m x v1) x v2
  = t_update m x v2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** For the final two lemmas about total maps, it is convenient to use
    the reflection idioms that we introduced in chapter [IndProp].  We
    begin by proving a fundamental _reflection lemma_ relating the
    equality proposition on [id]s with the boolean function
    [beq_id]. *)

(** **** Exercise: 2 stars (beq_idP)  *)
(** Use the proof of [beq_natP] in chapter [IndProp] as a template to
    prove the following: *)

Lemma beq_idP : forall x y, reflect (x = y) (beq_id x y).
Proof.
  intros x y. apply iff_reflect. rewrite beq_id_true_iff. reflexivity.
Qed.

(** Now, given [id]s [x1] and [x2], we can use the [destruct (beq_idP
    x1 x2)] to simultaneously perform case analysis on the result of
    [beq_id x1 x2] and generate hypotheses about the equality (in the
    sense of [=]) of [x1] and [x2]. *)

(** **** Exercise: 2 stars (t_update_same)  *)
(** Using the example in chapter [IndProp] as a template, use
    [beq_idP] to prove the following theorem, which states that if we
    update a map to assign key [x] the same value as it already has in
    [m], then the result is equal to [m]: *)

Definition n0 := t_empty 0.
Definition n1 := t_update n0 (Id 1) 12.
Definition n2 := t_update n1 (Id 1) (n1 (Id 1)).
Compute (n2 (Id 1)).

Theorem t_update_same : forall (X : Type)  (x : id) (m : total_map X),
  t_update m x (m x) = m.
Proof.
  intros. apply functional_extensionality.
  intros x'. unfold t_update. destruct (beq_id x x') eqn: Hb.
    + apply beq_id_true_iff in Hb. rewrite Hb. reflexivity.
    + reflexivity.
Qed.

(*
Axiom functional_extensionality : ∀ {X Y: Type} {f g : X → Y},
  (∀(x:X), f x = g x) → f = g.
*)

(** **** Exercise: 3 stars, recommended (t_update_permute)  *)
(** Use [beq_idP] to prove one final property of the [update]
    function: If we update a map [m] at two distinct keys, it doesn't
    matter in which order we do the updates. *)

Theorem t_update_permute : forall (X:Type) v1 v2 x1 x2
                             (m : total_map X),
  x2 <> x1 ->
    (t_update (t_update m x2 v2) x1 v1)
  = (t_update (t_update m x1 v1) x2 v2).
Proof.
  intros. apply functional_extensionality. intros x.
  unfold t_update. destruct (beq_id x1 x) eqn: Hb1.
    + destruct (beq_id x2 x) eqn: Hb2.
        - apply beq_id_true_iff in Hb1. apply beq_id_true_iff in Hb2.
          subst. exfalso. apply H. reflexivity.
        - reflexivity.
    + destruct (beq_id x2 x) eqn: Hb2.
        - reflexivity.
        - reflexivity.
Qed.

(* ###################################################################### *)
(** * Partial maps *)

(** Finally, we can define _partial maps_ on top of total maps.  A
    partial map with elements of type [A] is simply a total map with
    elements of type [option A] and default element [None]. *)

Definition partial_map (A:Type) := total_map (option A).

Definition empty {A:Type} : partial_map A :=
  t_empty None.

Definition update {A:Type} (m : partial_map A)
                  (x : id) (v : A) :=
  t_update m x (Some v).

(** We can now lift all of the basic lemmas about total maps to
    partial maps.  *)

Lemma update_eq : forall A (m: partial_map A) x v,
  (update m x v) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (X:Type) v x1 x2
                       (m : partial_map X),
  x2 <> x1 ->
  (update m x2 v) x1 = m x1.
Proof.
  intros X v x1 x2 m H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall A (m: partial_map A) v1 v2 x,
  update (update m x v1) x v2 = update m x v2.
Proof.
  intros A m v1 v2 x1. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall X v x (m : partial_map X),
  m x = Some v ->
  update m x v = m.
Proof.
  intros X v x m H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (X:Type) v1 v2 x1 x2
                                (m : partial_map X),
  x2 <> x1 ->
    (update (update m x2 v2) x1 v1)
  = (update (update m x1 v1) x2 v2).
Proof.
  intros X v1 v2 x1 x2 m. unfold update.
  apply t_update_permute.
Qed.

(** $Date: 2015-12-11 17:17:29 -0500 (Fri, 11 Dec 2015) $ *)


(* (c) Copyright ? *)

(*****************************************************************************
  Derivation. This file defines the hierarchy of derivation morphisms.

  * DerMorph (derivative morphism):
         derMorph f == forall a b, f (a * b) = f a *: b + a :* f b.
                       It says f of type R -> V is derivative, i.e., enjoys
                       the Lebniz product rule.
                       R must have a ringType canonical structure.
                       V must have a (bimodType R R) canonical structure.
  {derMorph R -> V} == the interface type for a Structure (keyed on
                       a function f : R -> V) that encapsulates the
                       derivative property.
DerMorphFor V der_f == packs der_f : derMorph f into an derMorph
                       function structure of type {derMorph R -> V}.
     DerMorph der_f == DerMorphFor _ der_f

  Properties of derMorph f:
                derM : f (a * b) = f a *: b + a :* f b
                der1 : f 1 = 0
                der0 : f 0 = 0
                derV : a \is a GRing.unit -> f (a^-1) = - a^-1 * f a / a
                       where a : R and R : unitRingType

  * DerAdd (derivative and additive):
    {derAdd R -> V} == the interface type for a Structure (keyed on
                       a function f : R -> V) that encapsulates the
                       derivative and additive property.
     packDerAdd V f == packs the DerMorph and Additive canonical structures on
                       f into a DerAdd structure

  * LinearDer (derivative and linear):
 {linearDer A -> V} == the interface type for a Structure (keyed on
                       a function f : A -> V) that encapsulates the
                       derivative and linear property.
                       It coerces to {linear A -> V | cscale}.
                       A must have a (lalgType R) canonical structure, where
                       R : ringType.
                       V must have a (bimodType A A) canonical structure.
         cscale r v == r *: 1 *: v.
                       r : R, v : V, V : lmodType A, A : lalgType R.
 AddScale (A -> V) scale_f == packs the scalability property scale_f of f into an
                       linearDer function structure of type {linearDer A -> V}.
                       scale_f should have type:
                         forall (c : R) (v : A), f (c *: v) = c *: 1 *: f v.
                       f must already have a {derAdd A -> V} canonical structure.

******************************************************************************)

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

Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq choice fintype.
Require Import finfun bigop prime binomial.
Require Import zmodp.

Require Import ssralg.
Import GRing.Theory.
Open Local Scope ring_scope.

Require Import bimodule.

(* Derivative morphism, a morphism that enjoys the Lebniz product rule: f (a * b) = f a * b + a * f b, where f : (R : ringType) -> (V : bimodType R R) *)
Module DerMorph.

Section ClassDef.

Variable R : ringType.
Variable V : bimodType R R.

Definition axiom (f : R -> V) := forall a b, f (a * b) = f a :* b + a *: f b.

Structure map (phV : phant V) := Pack {apply; _ : axiom apply}.
Local Coercion apply : map >-> Funclass.

Variables (phV : phant V) (f g : R -> V) (cF : map phV).
Definition class := let: Pack _ c as cF' := cF return axiom cF' in c.
Definition clone fA of phant_id g (apply cF) & phant_id fA class :=
  @Pack phV f fA.

End ClassDef.

Module Exports.
Notation derMorph f := (axiom f).
Coercion apply : map >-> Funclass.
Notation DerMorphFor V fA := (Pack (Phant V) fA).
Notation DerMorph fA := (DerMorphFor _ fA).
Notation "{ 'derMorph' V }" := (map (Phant V))
  (at level 0, format "{ 'derMorph'  V }") : ring_scope.
Notation "[ 'derMorph' 'of' f 'as' g ]" := (@clone _ _ _ f g _ _ idfun id)
  (at level 0, format "[ 'derMorph'  'of'  f  'as'  g ]") : form_scope.
Notation "[ 'derMorph' 'of' f ]" := (@clone _ _ _ f f _ _ id id)
  (at level 0, format "[ 'derMorph'  'of'  f ]") : form_scope.
End Exports.

End DerMorph.
Import DerMorph.Exports.

Section DerMorphTheory.

Variable R : ringType.
Variable V : bimodType R R.
Variable f : {derMorph V}.

Lemma derM a b : f (a * b) = f a :* b + a *: f b.
Proof. by case f. Qed.

Lemma der1 : f 1 = 0.
Proof.
  by apply: (addIr (f (1 * 1))); rewrite add0r {1}mul1r derM scale1r /rscale scale1r.
Qed.

Lemma der0 : f 0 = 0.
Proof.
  by rewrite -(mul0r 0) derM /rscale !scale0r addr0.
Qed.

End DerMorphTheory.

Lemma addNRL {Z : zmodType} (x y : Z) : x + y = 0 -> x = -y.
  move => H.
  rewrite -sub0r.
  rewrite -H.
  rewrite addrK.
  by [].
Qed.

Section Inverse.

Variable R : unitRingType.
Variable V : bimodType R R.
Variable f : {derMorph V}.

Lemma derV x : x \is a GRing.unit -> f (x^-1) = - (x^-1 *: f x :* x^-1).
Proof.
  move => Hu.
  have He: x^-1 *: f (x / x) = 0 by rewrite (mulrV Hu) der1 scaler0.
  rewrite derM  scalerDr scalerlA scalerA (mulVr Hu) scale1r addrC in He.
  by apply addNRL.
Qed.

End Inverse.

Import GRing.

(* Derivative and additive morphism *)
Module DerAdd.

Section ClassDef.

Variable R : ringType.
Variable V : bimodType R R.
Implicit Types f : R -> V.

Record class_of f : Prop := Class {base : derMorph f; mixin : additive f}.

Local Coercion base : class_of >-> derMorph.
Local Coercion mixin : class_of >-> additive.

Structure map (phV : phant V) := Pack {apply; _ : class_of apply}.
Local Coercion apply : map >-> Funclass.

Variables (phV : phant V) (f g : R -> V) (cF : map phV).
Definition class := let: Pack _ c as cF' := cF return class_of cF' in c.
Definition clone fA of phant_id g (apply cF) & phant_id fA class :=
  @Pack phV f fA.

Definition pack f :=
   fun bT b & phant_id (@DerMorph.class R V phV bT) (b : derMorph f) =>
   fun mT m & phant_id (@Additive.class R V (Phant _) mT) m =>
   Pack phV (@Class f b m).

Definition to_der := DerMorph class.
Definition to_add := Additive class.

End ClassDef.

Module Exports.
Notation derAdd f := (class_of f).
Coercion apply : map >-> Funclass.
Coercion class : map >-> class_of.
Coercion base : class_of >-> derMorph.
Coercion mixin : class_of >-> additive.
Coercion to_der : map >-> DerMorph.map.
Canonical to_der.
Coercion to_add : map >-> Additive.map.
Canonical to_add.
Notation DerAdd fA := (Pack (Phant _) fA).
Notation packDerAdd V f := (@pack _ _ (Phant V) f _ _ id _ _ id).
Notation "{ 'derAdd' V }" := (map (Phant V))
  (at level 0, format "{ 'derAdd'  V }") : ring_scope.
Notation "[ 'derAdd' 'of' f 'as' g ]" := (@clone _ _ _ f g _ _ idfun id)
  (at level 0, format "[ 'derAdd'  'of'  f  'as'  g ]") : form_scope.
Notation "[ 'derAdd' 'of' f ]" := (@clone _ _ _ f f _ _ id id)
  (at level 0, format "[ 'derAdd'  'of'  f ]") : form_scope.
End Exports.

End DerAdd.
Import DerAdd.Exports.

Module ConstScale.
Module Exports.
Section Def.

Variable R : ringType.
Variable A : lalgType R.
Variable V : lmodType A.
Definition cscale (r : R) (v : V) : V := r%:A *: v.

Lemma cscaleN1r : cscale (-1) =1 -%R.
Proof. by move => v; rewrite /cscale !scaleN1r. Qed.

Lemma cscalerBr a : additive (cscale a).
Proof. by move => v1 v2; rewrite /cscale !scalerBr. Qed.

(* Register that cscale has proper scale laws, required by linear_for *)
Canonical cscale_law := Scale.Law (erefl cscale) cscaleN1r cscalerBr.

End Def.
End Exports.
End ConstScale.
Import ConstScale.Exports.

(* Derivative and linear morphism *)
Module LinearDer.

Section ClassDef.

Variable R : ringType.
Variable A : lalgType R.
Variable V : bimodType A A.
Implicit Types f : A -> V.

Record class_of f : Prop := Class {base : derAdd f; mixin : Linear.mixin_of (@cscale _ _ _) f}.

Local Coercion base : class_of >-> derAdd.
Local Coercion mixin : class_of >-> Linear.mixin_of.
Definition base2 f (c : class_of f) := Linear.Class c c.
Local Coercion base2 : class_of >-> Linear.class_of.

Structure map (phAV : phant (A -> V)) := Pack {apply; _ : class_of apply}.
Local Coercion apply : map >-> Funclass.

Variables (phAV : phant (A -> V)) (f g : A -> V) (cF : map phAV).
Definition class := let: Pack _ c as cF' := cF return class_of cF' in c.
Definition clone fA of phant_id g (apply cF) & phant_id fA class :=
  @Pack phAV f fA.

Definition pack (fZ : forall (c : R) (v : A), f (c *: v) = c%:A *: f v) :=
   fun (bF : DerAdd.map (Phant V)) fA & phant_id (DerAdd.class bF) fA =>
   Pack phAV (Class fA fZ).

Definition to_der := DerMorph class.
Definition to_add := Additive class.
Definition to_linear := Linear class.
Definition to_derAdd := DerAdd class.

End ClassDef.

Module Exports.
Notation linearDer f := (class_of f).
Coercion apply : map >-> Funclass.
Coercion class : map >-> class_of.
Coercion base : class_of >-> derAdd.
Coercion base2 : class_of >-> Linear.class_of.
Coercion mixin : class_of >-> Linear.mixin_of.
Coercion to_der : map >-> DerMorph.map.
Canonical to_der.
Coercion to_add : map >-> Additive.map.
Canonical to_add.
Coercion to_linear : map >-> Linear.map.
Canonical to_linear.
Coercion to_derAdd : map >-> DerAdd.map.
Canonical to_derAdd.
Notation LinearDer fA := (Pack (Phant _) fA).
Notation AddScale fAV fZ := (@pack _ _ _ (Phant fAV) _ fZ _ _ id).
Notation "{ 'linearDer' fAV }" := (map (Phant fAV))
  (at level 0, format "{ 'linearDer'  fAV }") : ring_scope.
Notation "[ 'linearDer' 'of' f 'as' g ]" := (@clone _ _ _ f g _ _ idfun id)
  (at level 0, format "[ 'linearDer'  'of'  f  'as'  g ]") : form_scope.
Notation "[ 'linearDer' 'of' f ]" := (@clone _ _ _ f f _ _ id id)
  (at level 0, format "[ 'linearDer'  'of'  f ]") : form_scope.
End Exports.

End LinearDer.
Import LinearDer.Exports.

Export DerMorph.Exports.
Export DerAdd.Exports.
Export LinearDer.Exports.
Export ConstScale.Exports.


Require Import Coq.ZArith.ZArith.
Require Import coqutil.Z.Lia.
Require Import coqutil.Map.Interface.
Require Import coqutil.Map.SortedList.

Local Unset Universe Minimization ToSet.

#[global] Instance Zltb_strictorder: SortedList.parameters.strict_order Z.ltb.
Proof.
  constructor; intros; rewrite ?Z.ltb_lt, ?Z.ltb_ge, ?Z.ltb_irrefl in *;
    reflexivity || blia.
Qed.

#[global] Instance Zkeyed_map_params(V: Type): SortedList.parameters := {|
  parameters.key := Z;
  parameters.value := V;
  parameters.ltb := Z.ltb;
|}.

#[global] Instance Zkeyed_map(V: Type): map.map Z V :=
  SortedList.map (Zkeyed_map_params V) Zltb_strictorder.

#[global] Instance Zkeyed_map_ok(V: Type): map.ok (Zkeyed_map V).
Proof.
  apply (@SortedList.map_ok (Zkeyed_map_params V) Zltb_strictorder).
Qed.


Require Import Ics.

Inductive action := Nothing | Fill | Empty.
(** What the controller may do in each timestep (lasting 1 s) *)

(** * As a warmup, consider a controller in a very friendly world where physics is entirely predictable.
    * Whenever the controller asks for filling or emptying, it is easy to predict precisely
    * how much will happen in 1 second. *)

Module Type DETERMINISTIC.
  Parameter tankMax : Z.
  (** How high (m) may the water rise safely? *)

  Parameter sensorAccuracy : Z.
  (** Our one sensor must be at least this close to the true water value. *)

  Axiom sensorAccuracy_positive : 0 <= sensorAccuracy.

  Parameter fillRate : Z.
  (** Rate (m/s) at which tank fills on request *)

  Parameter emptyRate : Z.
  (** Rate (m/s) at which tank empties on request *)
End DETERMINISTIC.

Module Deterministic(Import M : DETERMINISTIC).
  Local Hint Extern 1 (0 <= sensorAccuracy) => apply sensorAccuracy_positive.

  (** Type signature of an implementation *)
  Definition sig : ADTSig :=
    ADTsignature {
      Constructor "new" : Z -> rep,
      (** Initialize, with starting water level (trusted to be accurate). *)

      Method "update" : rep x Z -> rep x unit,
      (** Record new sensor reading. *)

      Method "timestep" : rep x Z -> rep x action
      (** Decide what to do over the next second. *)
    }.

  (** Now the spec, which builds in the plant model, namely the true water level. *)
  Definition spec := ADTRep Z {
    Def Constructor "new"(trueLevel : Z) : rep :=
      ret trueLevel,
    Def Method "update"(trueLevel : rep, sensor : Z) : unit :=
      if Zabs (sensor - trueLevel) <? sensorAccuracy then
        ret (trueLevel, tt)
      else
        (* The sensor broke the rules!  Change the state arbitrarily to make anything safe. *)
        trueLevel' <- {_ | True};
        ret (trueLevel', tt),
    Def Method "timestep"(trueLevel : rep, targetLevel : Z) : action :=
      act <- {act | match act with
                    | Nothing => True
                    | Fill => trueLevel + fillRate < tankMax
                    | Empty => trueLevel - emptyRate >= 0
                    end};
      ret (match act with
           | Nothing => trueLevel
           | Fill => trueLevel + fillRate
           | Empty => trueLevel - emptyRate
           end, act)
  }.

  (** A basic fact about approximation: it's always OK to give the exact answer! *)
  Lemma easy_approx : forall (d : Z),
    refine {nr' : Z | Zabs (nr' - d) <= sensorAccuracy} (ret d).
  Proof.
    implement.
  Qed.

  (** Any new sensor value is a proper approximation of the water level. *)
  Lemma newSensorOk : forall sensor trueLevel,
    refine (p <- (if Z.abs (sensor - trueLevel) <? sensorAccuracy
                  then ret (trueLevel, ())
                  else trueLevel' <- {_ | True};
                       ret (trueLevel', ()));
            sensor' <- {nr' : Z | Z.abs (nr' - fst p) <= sensorAccuracy};
            ret (sensor', snd p))
           (ret (sensor, ())).
  Proof.
    implement;
    try match goal with
        | [ H : _ = ?sensor - ?E |- _ ] =>
          unify E sensor; generalize sensorAccuracy_positive
        end; implement.
  Qed.

  (** Justify the obvious choice of actions. *)
  Lemma chooseAction : forall trueLevel sensor targetLevel,
    Z.abs (sensor - trueLevel) <= sensorAccuracy
    -> refine (p <- (act <- {act : action |
                             match act with
                             | Nothing => True
                             | Fill => trueLevel + fillRate < tankMax
                             | Empty => trueLevel - emptyRate >= 0
                             end};
                     ret
                       (match act with
                        | Nothing => trueLevel
                        | Fill => trueLevel + fillRate
                        | Empty => trueLevel - emptyRate
                        end, act));
               sensor' <- {n : Z | Z.abs (n - fst p) <= sensorAccuracy};
               ret (sensor', snd p))
              (if (sensor <? targetLevel) && (sensor + sensorAccuracy + fillRate <? tankMax) then
                 ret (sensor + fillRate, Fill)
               else if (sensor >? targetLevel) && (sensor - sensorAccuracy - emptyRate >=? 0) then
                 ret (sensor - emptyRate, Empty)
               else
                 ret (sensor, Nothing)).
  Proof.
    implement.
  Qed.

  (** Now we derive the overall implementation. *)
  Definition impl : Sharpened spec.
  Proof.
    unfold spec.

    (** The main idea of the implementation is to store the sensor value as an approximation of water level.
      * Here we give an abstraction relation capturing that idea. *)
    hone representation using (fun abs conc => Zabs (conc - abs) <= sensorAccuracy).

    (** Now we fill in method implementations, one at a time. *)

    hone constructor "new". {
      simplify.
      rewrite easy_approx.
      finish honing.
    }

    hone method "update". {
      rewrite newSensorOk.
      finish honing.
    }

    hone method "timestep". {
      rewrite chooseAction with (targetLevel := n) by eauto.
      finish honing.
    }

    (** Inspecting the code, we see that it looks good.  Time to end the derivation. *)
    finished.
  Defined.

  (** As a last check, we extract an executable Coq program from the derivation and print it. *)

  Definition impl' : cADT sig.
  Proof.
    extract impl.
  Defined.

  Print impl'.
End Deterministic.

(** * Now let's move to a more realistic world, where we only have bounds on filling/emptying speeds. *)

Module Type NONDETERMINISTIC.
  Parameter tankMax : Z.
  (** How high (m) may the water rise safely? *)

  Parameter sensorAccuracy : Z.
  (** Our one sensor must be at least this close to the true water value. *)

  Axiom sensorAccuracy_positive : 0 <= sensorAccuracy.

  (** Bounds on how much filling or emptying will happen in 1 second *)
  Parameters minFill maxFill minEmpty maxEmpty : Z.

  Axiom fillBounds : minFill <= maxFill.
  Axiom emptyBounds : minEmpty <= maxEmpty.
End NONDETERMINISTIC.

Module Nondeterministic(Import M : NONDETERMINISTIC).
  Local Hint Extern 1 (0 <= sensorAccuracy) => apply sensorAccuracy_positive.

  (** We use this type as input to the main controller method.
    * Only the [TargetLevel] field would actually be present at runtime;
    * the others are just a specification device, and the final implementation shouldn't inspect them. *)
  Record request := {
    TargetLevel : Z;
    FillRate : Z;
    EmptyRate : Z
  }.

  (** Type signature of an implementation *)
  Definition sig : ADTSig :=
    ADTsignature {
      Constructor "new" : Z -> rep,
      (** Initialize, with starting water level (trusted to be accurate). *)

      Method "update" : rep x Z -> rep x unit,
      (** Record new sensor reading. *)

      Method "timestep" : rep x request -> rep x action
      (** Decide what to do over the next second. *)
    }.

  (** Now the spec, modeling nondeterministic filling/emptying. *)
  Definition spec := ADTRep Z {
    Def Constructor "new"(trueLevel : Z) : rep :=
      ret trueLevel,
    Def Method "update"(trueLevel : rep, sensor : Z) : unit :=
      if Zabs (sensor - trueLevel) <? sensorAccuracy then
        ret (trueLevel, tt)
      else
        (* The sensor broke the rules!  Change the state arbitrarily to make anything safe. *)
        trueLevel' <- {_ | True};
        ret (trueLevel', tt),
    Def Method "timestep"(trueLevel : rep, r : request) : action :=
      act <- {act | match act with
                    | Nothing => True
                    | Fill => trueLevel + maxFill < tankMax
                    | Empty => trueLevel - maxEmpty >= 0
                    end};
      trueLevel' <- {trueLevel' | minFill <= FillRate r <= maxFill
                                  -> minEmpty <= EmptyRate r <= maxEmpty
                                  -> match act with
                                     | Nothing => trueLevel' = trueLevel
                                     | Fill => trueLevel' = trueLevel + FillRate r
                                     | Empty => trueLevel' = trueLevel - EmptyRate r
                                     end};
      ret (trueLevel', act)
  }.

  (** Intervals of possible values, which we'll use to record our knowledge in the implementation *)
  Record interval := Interval {
    Min : Z;
    Max : Z
  }.

  (** A basic fact about interval approximation: it's always OK to give the exact answer! *)
  Lemma easy_approx : forall (d : Z),
    refine {i | Min i <= d <= Max i} (ret (Interval d d)).
  Proof.
    implement.
  Qed.

  (** Any new sensor value is a proper approximation of the water level. *)
  Lemma newSensorOk : forall sensor trueLevel,
    refine (p <- (if Z.abs (sensor - trueLevel) <? sensorAccuracy
                  then ret (trueLevel, ())
                  else trueLevel' <- {_ | True};
                       ret (trueLevel', ()));
            sensor' <- {i | Min i <= fst p <= Max i};
            ret (sensor', snd p))
           (ret (Interval (sensor - sensorAccuracy) (sensor + sensorAccuracy), ())).
  Proof.
    implement; generalize sensorAccuracy_positive; implement.
  Qed.

  (** Justify the obvious choice of actions. *)
  Lemma chooseAction : forall trueLevel sensor r,
    Min sensor <= trueLevel <= Max sensor
    -> refine (p <- (act <- {act : action |
                             match act with
                             | Nothing => True
                             | Fill => trueLevel + maxFill < tankMax
                             | Empty => trueLevel - maxEmpty >= 0
                             end};
                     trueLevel' <- {trueLevel' : Z |
                                    minFill <= FillRate r <= maxFill ->
                                    minEmpty <= EmptyRate r <= maxEmpty ->
                                    match act with
                                    | Nothing => trueLevel' = trueLevel
                                    | Fill => trueLevel' = trueLevel + FillRate r
                                    | Empty => trueLevel' = trueLevel - EmptyRate r
                                    end};
                     ret (trueLevel', act));
               sensor' <- {sensor' : interval | Min sensor' <= fst p <= Max sensor'};
               ret (sensor', snd p))
              (if (Min sensor <? TargetLevel r) && (Max sensor + maxFill <? tankMax) then
                 ret (Interval (Min sensor + minFill) (Max sensor + maxFill), Fill)
               else if (Max sensor >? TargetLevel r) && (Min sensor - maxEmpty >=? 0) then
                 ret (Interval (Min sensor - maxEmpty) (Max sensor - minEmpty), Empty)
               else
                 ret (sensor, Nothing)).
  Proof.
    intros.

    (* Case split on whether the environment is following the rules in choosing water motion rates *)
    assert ((minFill <= FillRate r <= maxFill /\ minEmpty <= EmptyRate r <= maxEmpty)
            \/ ~(minFill <= FillRate r <= maxFill /\ minEmpty <= EmptyRate r <= maxEmpty))
      by (destruct (Z_le_gt_dec minFill (FillRate r)), (Z_le_gt_dec (FillRate r) maxFill),
          (Z_le_gt_dec minEmpty (EmptyRate r)), (Z_le_gt_dec (EmptyRate r) maxEmpty); omega).

    intuition; implement1;
    (simplify with monad laws;
     do 2 intro;
     repeat computes_to_inv; subst; simpl in *;
       solve [ econstructor; split;
               repeat match goal with
                      | [ |- Ensembles.In _ _ _ ] => econstructor; split
                      end; repeat implement; generalize fillBounds, emptyBounds; omega
             | econstructor; split;
               repeat match goal with
                      | [ |- Ensembles.In _ _ _ ] => econstructor; split
                      end;
               try match goal with
                   | [ |- Ensembles.In _ _ {| Min := ?min; Max := _ |} ] => instantiate (1 := min)
                   end;
               repeat implement; generalize fillBounds, emptyBounds; omega ]).
  Qed.

  (** Now we derive the overall implementation. *)
  Definition impl : Sharpened spec.
  Proof.
    unfold spec.

    (** This time around, we represent our sensor estimate with _intervals_. *)
    hone representation using (fun abs conc => Min conc <= abs <= Max conc).

    (** Now we fill in method implementations, one at a time. *)

    hone constructor "new". {
      simplify.
      rewrite easy_approx.
      finish honing.
    }

    hone method "update". {
      rewrite newSensorOk.
      finish honing.
    }

    hone method "timestep". {
      rewrite chooseAction with (r := n) by eauto.
      finish honing.
    }

    (** Inspecting the code, we see that it looks good.  Time to end the derivation. *)
    finished.
  Defined.

  (** As a last check, we extract an executable Coq program from the derivation and print it. *)

  Definition impl' : cADT sig.
  Proof.
    extract impl.
  Defined.

  Print impl'.
End Nondeterministic.


From mathcomp Require Import ssreflect eqtype.
From deriving Require Import deriving.

(* seq_indType is already defined, so to be sure that we don't rely on it,
   we redefine list *)
Inductive list A := | nil | cons : A -> list A -> list A.

Definition list_indDef A := [indDef for list_rect A].
Canonical list_indType A := IndType (list A) (list_indDef A).

Definition list_eqMixin (A : eqType) := [derive eqMixin for list A].
Canonical list_eqType (A:eqType) := EqType (list A) (list_eqMixin A).


From Coq Require Import Lists.List.
From Coq Require Import Lists.ListSet.
From Coq Require Import PeanoNat.
From Coq Require Import Arith.Le Arith.Plus.
From Coq Require Import Relations.Relation_Definitions Relations.Relation_Operators.
From Coq Require Import ssreflect.

Inductive term : Type :=
  | ttrue                         : term
  | tfalse                        : term
  | tZ                            : term
  | tsucc (t1 : term)             : term
  | tpred (t1 : term)             : term
  | tiszero (t1 : term)           : term
  | tifthenelse (t1 t2 t3 : term) : term.

Proposition term_dec : forall x y : term, {x = y} + {x <> y}.
Proof.
  decide equality.
Qed.

Definition term_set_add (t : term) (s : set term) : set term :=
  set_add term_dec t s.

Lemma term_set_add_le_cons : forall (t : term) (s : set term),
  length (term_set_add t s) <= length (t :: s).
Proof.
  intros t s.
  induction s.
  - simpl. apply le_n.
  - simpl.
    destruct (term_dec t a).
    + simpl. apply le_S. apply le_n.
    + simpl in *. apply le_n_S. apply IHs.
Qed.

Definition term_set_union (s1 s2 : set term) : set term :=
  set_union term_dec s1 s2.

Lemma term_set_union_le_append : forall (s1 s2 : set term),
  length (term_set_union s1 s2) <= length (s1 ++ s2).
Proof.
  intros s1 s2.
  induction s2.
  - unfold term_set_union. unfold set_union.
    rewrite app_nil_r. apply le_n.
  - simpl.
    rewrite app_length in IHs2.
    rewrite app_length.
    simpl. rewrite Nat.add_succ_r.
    apply le_trans with (length (a :: term_set_union s1 s2)).
    + apply term_set_add_le_cons.
    + simpl. apply le_n_S. apply IHs2.
Qed.

Lemma term_set_union_length_le : forall (s1 s2 : set term) (n1 n2 : nat),
  length s1 <= n1 -> length s2 <= n2 -> length (term_set_union s1 s2) <= n1 + n2.
Proof.
  intros s1 s2 n1 n2 Hle1 Hle2.
  apply le_trans with (length (s1 ++ s2)).
  - apply term_set_union_le_append.
  - rewrite app_length.
    apply Nat.add_le_mono; assumption.
Qed.

Fixpoint consts (t : term) : set term :=
  match t with
  | tsucc t1 => consts t1
  | tpred t1 => consts t1
  | tiszero t1 => consts t1
  | tifthenelse t1 t2 t3 =>
      term_set_union (consts t1) (term_set_union (consts t2) (consts t3))
  | c => term_set_add c (empty_set term)
  end.

Fixpoint size (t : term) : nat :=
  match t with
  | tsucc t1 => S (size t1)
  | tpred t1 => S (size t1)
  | tiszero t1 => S (size t1)
  | tifthenelse t1 t2 t3 => S (size t1 + size t2 + size t3)
  | _ => 1
  end.

Fixpoint depth (t : term) : nat :=
  match t with
  | tsucc t1 => S (depth t1)
  | tpred t1 => S (depth t1)
  | tiszero t1 => S (depth t1)
  | tifthenelse t1 t2 t3 => S (max (depth t1) (max (depth t2) (depth t3)))
  | _ => 1
  end.

(* 3.3.3 *)
Lemma consts_leq_size : forall t : term, length (consts t) <= size t.
Proof.
  intros t.
  induction t; try (apply le_S; assumption); auto.
  simpl.
  apply le_S.
  rewrite <- plus_assoc.
  apply term_set_union_length_le; try assumption.
  apply term_set_union_length_le; assumption.
Qed.

Inductive value_b : term -> Prop :=
  | V_true  : value_b ttrue
  | V_false : value_b tfalse.

Proposition value_b_dec : forall (t : term), { value_b t } + { ~(value_b t) }.
Proof.
  intros t.
  induction t;
  try (left; constructor);
  try (right; intros contra; inversion contra).
Qed.

Inductive value_n : term -> Prop :=
  | V_Z               : value_n tZ
  | V_succ (t : term) : value_n t -> value_n (tsucc t).

Proposition value_n_dec : forall (t : term), {value_n t} + {~(value_n t)}.
Proof.
  intros t.
  induction t;
  try (by (left; constructor));
  try (by (right; intros contra; inversion contra)).
  destruct IHt as [H_tval|H_tnotval].
  - left. apply V_succ. apply H_tval.
  - right. intros contra. inversion contra.
    apply H_tnotval. apply H0.
Qed.

Inductive value : term -> Prop :=
  | V_bool (t : term) : value_b t -> value t
  | V_nat (t : term) : value_n t -> value t.

Proposition value_dec : forall (t : term), {value t} + {~(value t)}.
Proof.
  intros t.
  destruct (value_b_dec t).
  - left. apply V_bool. apply v.
  - destruct (value_n_dec t).
    + left. apply V_nat. apply v.
    + right. intros contra. inversion contra; subst.
      * apply (n H).
      * apply (n0 H).
Qed.

Reserved Notation "t '==>' v" (at level 90, left associativity).
Inductive evalR : relation term :=
  | E_IfTrue : forall (t2 t3 : term),
      tifthenelse ttrue t2 t3 ==> t2
  | E_IfFalse : forall (t2 t3 : term),
      tifthenelse tfalse t2 t3 ==> t3
  | E_If : forall (t1 t2 t3 t1' : term),
      t1 ==> t1' ->
      tifthenelse t1 t2 t3 ==> tifthenelse t1' t2 t3
  | E_Succ : forall (t1 t1' : term),
      t1 ==> t1' ->
      tsucc t1 ==> tsucc t1'
  | E_PredZ : tpred tZ ==> tZ
  | E_PredSucc : forall (t1 : term),
      value_n t1 ->
      tpred (tsucc t1) ==> t1
  | E_Pred : forall (t1 t1' : term),
      t1 ==> t1' ->
      tpred t1 ==> tpred t1'
  | E_IszeroZ : tiszero tZ ==> ttrue
  | E_IszeroSucc : forall (t1 : term),
      value_n t1 ->
      tiszero (tsucc t1) ==> tfalse
  | E_Iszero : forall (t1 t1' : term),
      t1 ==> t1' ->
      tiszero t1 ==> tiszero t1'
  where "t '==>' v" := (evalR t v) : type_scope.

(* 3.5.6 *)
Definition normal_form (t : term) : Prop := ~(exists t', t ==> t').

Lemma value_b_is_normal_form : forall (t : term),
  value_b t -> normal_form t.
Proof.
  unfold normal_form.
  intros t H_tval [t' H_tt'].
  inversion H_tval; subst; inversion H_tt'.
Qed.

Lemma value_n_is_normal_form : forall (t : term),
  value_n t -> normal_form t.
Proof.
  unfold normal_form.
  intros t H_tval.
  induction H_tval; intros [t' H_tt']; inversion H_tt'; subst.
  apply IHH_tval. exists t1'. apply H0.
Qed.

(* 3.5.7 *)
Theorem value_is_normal_form : forall (t : term),
  value t -> normal_form t.
Proof.
  intros t [|].
  - apply value_b_is_normal_form. assumption.
  - apply value_n_is_normal_form. assumption.
Qed.

(* 3.5.4 *)
Theorem evalR_deterministic : forall (t t' t'' : term),
  t ==> t' -> t ==> t'' -> t' = t''.
Proof.
  intros t t' t'' H_tt'. generalize dependent t''.
  induction H_tt'; intros t'' H_tt''.
  - inversion H_tt''; try reflexivity; subst.
    inversion H3.
  - inversion H_tt''; try reflexivity; subst.
    inversion H3.
  - inversion H_tt''; subst.
    + inversion H_tt'.
    + inversion H_tt'.
    + f_equal.
      apply IHH_tt'. apply H3.
  - inversion H_tt''. subst.
    f_equal. apply IHH_tt'. apply H0.
  - inversion H_tt''; try reflexivity; subst.
    inversion H0.
  - inversion H; subst.
    + inversion H_tt''; try reflexivity; subst.
      exfalso. apply value_n_is_normal_form with (tsucc tZ).
      * apply V_succ. apply H.
      * exists t1'. apply H1.
    + inversion H_tt''; try reflexivity; subst.
      exfalso. apply value_n_is_normal_form with (tsucc (tsucc t)).
      * repeat apply V_succ. apply H0.
      * exists t1'. apply H2.
  - inversion H_tt''; subst.
    + inversion H_tt'.
    + inversion H0; subst.
      * inversion H_tt'; subst. inversion H1.
      * inversion H_tt'; subst.
        exfalso. apply value_n_is_normal_form with (tsucc t).
        -- apply V_succ. apply H.
        -- exists t1'0. apply H2.
    + f_equal. apply IHH_tt'. apply H0.
  - inversion H_tt''; try reflexivity; subst.
    inversion H0.
  - inversion H_tt''; try reflexivity; subst.
    exfalso. apply value_n_is_normal_form with (tsucc t1).
    + apply V_succ. apply H.
    + exists t1'. apply H1.
  - inversion H_tt''; subst.
    + inversion H_tt'.
    + exfalso. apply value_n_is_normal_form with (tsucc t0).
      * apply V_succ. apply H0.
      * exists t1'. apply H_tt'.
    + f_equal. apply IHH_tt'. apply H0.
Qed.

(* Not true with nats:
Theorem normal_form_is_value : forall (t : term),
  normal_form t -> value t.
Proof.
  unfold normal_form.
  intros t.
  induction t; intros H_noexist.
  - apply V_bool. apply V_true.
  - apply V_bool. apply V_false.
  - apply V_nat. apply V_Z.
  - remember (tsucc t) as tsucct.
    apply V_nat. apply V_succ.
Admitted.
*)

(* 3.5.9 *)
Definition evalR_multi : relation term := clos_refl_trans_1n term evalR.
Notation "t '==>*' v" := (evalR_multi t v)
  (at level 90, left associativity) : type_scope.

Theorem rt1n_trans_general : forall (A : Type) (R : relation A) (x y z : A),
  clos_refl_trans_1n A R x y ->
  clos_refl_trans_1n A R y z ->
  clos_refl_trans_1n A R x z.
Proof.
  intros A R x y z Hxy Hyz.
  induction Hxy.
  - assumption.
  - apply rt1n_trans with y.
    + assumption.
    + apply IHHxy. assumption.
Qed.

Theorem rt1n_step : forall (A : Type) (R : relation A) (x y : A),
  R x y -> clos_refl_trans_1n A R x y.
Proof.
  intros A R x y Hxy.
  apply rt1n_trans with y. assumption. apply rt1n_refl.
Qed.

Theorem rtn1_trans_general : forall (A : Type) (R : relation A) (x y z : A),
  clos_refl_trans_n1 A R x y ->
  clos_refl_trans_n1 A R y z ->
  clos_refl_trans_n1 A R x z.
Proof.
  intros A R x y z Hxy Hyz.
  induction Hyz.
  - assumption.
  - apply rtn1_trans with y0; assumption.
Qed.

Theorem rtn1_step : forall (A : Type) (R : relation A) (x y : A),
  R x y -> clos_refl_trans_n1 A R x y.
Proof.
  intros A R x y Hxy.
  apply rtn1_trans with x. assumption. apply rtn1_refl.
Qed.

Theorem rt1n_iff_rtn1 : forall (A : Type) (R : relation A) (x y : A),
  clos_refl_trans_1n A R x y <-> clos_refl_trans_n1 A R x y.
Proof.
  intros A R x y.
  split.
  - intros Hxy.
    induction Hxy.
    + apply rtn1_refl.
    + apply rtn1_trans_general with y.
      * apply rtn1_step. assumption.
      * assumption.
  - intros Hxy.
    induction Hxy.
    + apply rt1n_refl.
    + apply rt1n_trans_general with y.
      * assumption.
      * apply rt1n_step. assumption.
Qed.

(* 3.5.11 *)
Theorem normal_form_unique : forall (t u u' : term),
  normal_form u -> normal_form u' -> t ==>* u -> t ==>* u' -> u = u'.
Proof.
  intros t u u' H_normu H_normu' H_tu H_tu'.
  induction H_tu; subst.
  - inversion H_tu'; subst.
    + reflexivity.
    + exfalso. apply H_normu. exists y. apply H.
  - apply (IHH_tu H_normu).
    inversion H_tu'; subst.
    + exfalso. apply H_normu'. exists y. apply H.
    + replace y with y0. apply H1.
      apply evalR_deterministic with x; assumption.
Qed.

Lemma succ_inner_reduces : forall (t t' : term),
  t ==>* t' ->
  tsucc t ==>* tsucc t'.
Proof.
  intros t t' Htt'.
  induction Htt'. apply rt1n_refl.
  apply rt1n_trans with (tsucc y); try (apply E_Succ); assumption.
Qed.

Lemma pred_inner_reduces : forall (t t' : term),
  t ==>* t' ->
  tpred t ==>* tpred t'.
Proof.
  intros t t' Htt'.
  induction Htt'. apply rt1n_refl.
  apply rt1n_trans with (tpred y); try (apply E_Pred); assumption.
Qed.

Lemma iszero_inner_reduces : forall (t t' : term),
  t ==>* t' ->
  tiszero t ==>* tiszero t'.
Proof.
  intros t t' Htt'.
  induction Htt'. apply rt1n_refl.
  apply rt1n_trans with (tiszero y); try (apply E_Iszero); assumption.
Qed.

Lemma ifthenelse_inner_reduces : forall (t1 t1' t2 t3 : term),
  t1 ==>* t1' ->
  tifthenelse t1 t2 t3 ==>* tifthenelse t1' t2 t3.
Proof.
  intros t1 t1' t2 t3 Ht1t1'.
  induction Ht1t1'. apply rt1n_refl.
  apply rt1n_trans with (tifthenelse y t2 t3); try (apply E_If); assumption.
Qed.

Lemma succ_inner_normal_form : forall (t : term),
  normal_form (tsucc t) ->
  normal_form t.
Proof.
  intros t Hnorm [t' Htt'].
  apply Hnorm.
  exists (tsucc t'). apply E_Succ. assumption.
Qed.

Lemma pred_inner_normal_form : forall (t : term),
  normal_form (tpred t) ->
  normal_form t.
Proof.
  intros t Hnorm [t' Htt'].
  apply Hnorm.
  exists (tpred t'). apply E_Pred. assumption.
Qed.

Lemma iszero_inner_normal_form : forall (t : term),
  normal_form (tiszero t) ->
  normal_form t.
Proof.
  intros t Hsuccnorm [t' Htt'].
  apply Hsuccnorm.
  exists (tiszero t'). apply E_Iszero. assumption.
Qed.

Lemma ifthenelse_inner_normal_form : forall (t1 t2 t3 : term),
  normal_form (tifthenelse t1 t2 t3) ->
  normal_form t1.
Proof.
  intros t1 t2 t3 Hnorm [t1' Ht1t1'].
  apply Hnorm.
  exists (tifthenelse t1' t2 t3). apply E_If. assumption.
Qed.

(* 3.5.12 *)
Theorem evalR_terminates : forall (t : term),
  exists (t' : term), normal_form t' /\ (t ==>* t').
Proof.
  intros t.
  induction t.
  - exists ttrue. split.
    + apply value_b_is_normal_form. apply V_true.
    + apply rt1n_refl.
  - exists tfalse. split.
    + apply value_b_is_normal_form. apply V_false.
    + apply rt1n_refl.
  - exists tZ. split.
    + apply value_n_is_normal_form. apply V_Z.
    + apply rt1n_refl.
  - destruct IHt as [t' [H_normt' H_tt']].
    exists (tsucc t'). split.
    + intros [t'' H_tsucct't''].
      inversion H_tsucct't''; subst.
      apply H_normt'. exists t1'. apply H0.
    + apply succ_inner_reduces. assumption.
  - destruct IHt as [t' [H_normt' H_tt']].
    assert (Hreduce : tpred t ==>* tpred t').
    { apply pred_inner_reduces. assumption. }
    destruct (value_n_dec t').
    + inversion v; subst.
      * exists tZ. split.
        -- apply value_n_is_normal_form. apply v.
        -- apply rt1n_trans_general with (tpred tZ). assumption.
           apply rt1n_step. apply E_PredZ.
      * exists t0. split.
        -- inversion v. apply value_n_is_normal_form. apply H.
        -- apply rt1n_trans_general with (tpred (tsucc t0)).
           ++ apply pred_inner_reduces. assumption.
           ++ apply rt1n_step. apply E_PredSucc. assumption.
    + exists (tpred t'). split.
      * intros [t'' Htt''].
         inversion Htt''; subst.
         -- apply n. apply V_Z.
         -- apply n. apply V_succ. apply H0.
         -- apply H_normt'. exists t1'. apply H0.
      * apply pred_inner_reduces. assumption.
  - destruct IHt as [t' [H_normt' H_tt']].
    assert (Hreduce : tiszero t ==>* tiszero t').
    { apply iszero_inner_reduces. assumption. }
    destruct (value_n_dec t').
    + inversion v; subst.
      * exists ttrue. split. apply value_b_is_normal_form. apply V_true.
        apply rt1n_trans_general with (tiszero tZ). assumption.
        apply rt1n_step. apply E_IszeroZ.
      * exists tfalse. split. apply value_b_is_normal_form. apply V_false.
        apply rt1n_trans_general with (tiszero (tsucc t0)). assumption.
        apply rt1n_step. apply E_IszeroSucc. assumption.
    + exists (tiszero t'). split.
      * intros [t'' Htt''].
        inversion Htt''; subst; try (by (apply n; constructor; assumption)).
        apply H_normt'. exists t1'. assumption.
      * assumption.
  - destruct IHt1 as [t1' [Hnormt1' Ht1t1']].
    destruct IHt2 as [t2' [Hnormt2' Ht2t2']].
    destruct IHt3 as [t3' [Hnormt3' Ht3t3']].
    assert (Hreduce : tifthenelse t1 t2 t3 ==>* tifthenelse t1' t2 t3).
    { apply ifthenelse_inner_reduces. assumption. }
    destruct (value_b_dec t1').
    + inversion v; subst.
      * exists t2'. split. assumption.
        apply rt1n_trans_general with (tifthenelse ttrue t2 t3). assumption.
        apply rt1n_trans_general with t2. apply rt1n_step. apply E_IfTrue.
        assumption.
      * exists t3'. split. assumption.
        apply rt1n_trans_general with (tifthenelse tfalse t2 t3). assumption.
        apply rt1n_trans_general with t3. apply rt1n_step. apply E_IfFalse.
        assumption.
    + exists (tifthenelse t1' t2 t3). split.
      * intros [t'' Htt''].
        inversion Htt''; subst; try (by (apply n; constructor; assumption)).
        apply Hnormt1'. exists t1'0. assumption.
      * assumption.
Qed.

Definition stuck (t : term) : Prop := normal_form t /\ ~(value t).


From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From fcsl
Require Import prelude pred pcm unionmap heap.
From HTT
Require Import stmod stsep stlog stlogR.

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

Definition llist (T : Type) := ptr.

Section LList.
Variable T : Type.
Notation llist := (llist T).

Fixpoint lseg (p q : ptr) (xs : seq T): Pred heap :=
  if xs is x::xt then
    [Pred h | exists r h',
       h = p :-> x \+ (p .+ 1 :-> r \+ h') /\ h' \In lseg r q xt]
  else [Pred h | p = q /\ h = Unit].

Lemma lseg_null xs q h :
         valid h -> h \In lseg null q xs ->
         [/\ q = null, xs = [::] & h = Unit].
Proof.
case: xs=>[|x xs] D /= H; first by case: H=><- ->.
case: H D=>r [h'][->] _.
by rewrite validPtUn.
Qed.

Definition lseq p := lseg p null.

Program Definition insert p x :
  {xs}, STsep (lseq p xs, [vfun y => lseq y (x::xs)]) :=
  Do (q <-- allocb p 2;
      q ::= x;;
      ret q).
Next Obligation.
apply: ghR=>i xs H _.
heval=>x1.
rewrite unitR -joinA.
heval.
Qed.

Lemma lseq_null xs h : valid h -> h \In lseq null xs -> xs = [::] /\ h = Unit.
Proof. by move=>D; case/(lseg_null D)=>_ ->. Qed.

Lemma lseq_pos xs p h :
        p != null -> h \In lseq p xs ->
        exists x, exists r, exists h',
          [/\ xs = x :: behead xs,
              p :-> x \+ (p .+ 1 :-> r \+ h') = h & h' \In lseq r (behead xs)].
Proof.
case: xs=>[|x xs] /= H [].
 - move=>E.
   by rewrite E eq_refl in H.
by move=>y [h'][->] H1; heval.
Qed.

Program Definition
remove p : {xs}, STsep (lseq p xs, [vfun y => lseq y (behead xs)]) :=
  Do (if p == null then ret p
      else pnext <-- !(p .+ 1);
           dealloc p;;
           dealloc p .+ 1;;
           ret pnext).

Next Obligation.
apply: ghR=>i xs H V; case: ifP H=>H1.
- by rewrite (eqP H1); case/(lseq_null V)=>->->; heval.
case/(lseq_pos (negbT H1))=>x [q][h][->] <- /= H2.
by heval; rewrite 2!unitL.
Qed.

End LList.

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

(**
---------------------------------------------------------------------
Exercise [Swapping two values]
---------------------------------------------------------------------

Implement in HTT a function that takes as arguments two pointers, [x]
and [y], which point to natural numbers, and swaps their
values. Reflect this effect in the function's specification and verify
it.

Hint: Instead of reading the value of a pointer into a variable [t]
using the [t <-- !p] notation, you might need to specify the _type_ of
the expected value explicitly by using the "de-sugared" version of the
command [t <-- read T p], where [T] is the expected type. This way,
the proof will be more straightforward.

*)

Program Definition swap (x y : ptr):
  {(a b : nat)},
  STsep (fun h => h = x :-> a \+ y :-> b,
        [vfun (_: unit) h => h = x :-> b \+ y :-> a]) :=
  Do (vx <-- read nat x;
      vy <-- read nat y;
      x ::= vy;;
      y ::= vx).
Next Obligation.
by apply:ghR=>_ [a b]->/= _; heval.
Qed.

(**
---------------------------------------------------------------------
Exercise [Swapping two values without heval]
---------------------------------------------------------------------

Try to redo the previous exercise _without_ using the automation
provided by the [heval] tactic. The goal of this exercise is to
explore the library of HTT lemmas, mimicking the rules of the
separation logic. You can alway displat the whole list of the
available lemmas by running the command [Search _ (verify _ _ _)] and
then refine the query for specific programs (e.g., [read] or [write]).
*)

Program Definition swap' (x y : ptr):
  {(a b : nat)},
  STsep (fun h => h = x :-> a \+ y :-> b,
        [vfun _ h => h = x :-> b \+ y :-> a]) :=
  Do (vx <-- read nat x;
      vy <-- read nat y;
      x ::= vy;;
      y ::= vx).
Next Obligation.
apply:ghR=>_ [a b]-> _.
apply: bnd_seq; apply: val_read => _.
apply: bnd_seq; apply: val_readR => _.
apply: bnd_seq; apply: val_write => _.
by apply: val_writeR.
Qed.

(**
---------------------------------------------------------------------
Exercise [Imperative procedure for Fibonacci numbers]
---------------------------------------------------------------------

The following program is an implementation in pseudocode of an
efficient imperative implementation of the function [fib] that
computes the [N]th Fibonacci number.

    fun fib (N : nat): nat = {
      if N == 0 then ret 0
       else if N == 1 then ret 1
       else n <-- alloc 2;
            x <-- alloc 1;
            y <-- alloc 1;
            res <--
              (fix loop (_ : unit).
                 n' <-- !n;
                 y' <-- !y;
                 if n' == N then ret y'
                 else tmp <-- !x;
                      x ::= y';;
                      x' <-- !x;
                      y ::= x' + tmp;;
                      n ::= n' + 1;;
                      loop(tt))(tt).
            dealloc n;;
            dealloc x;;
            dealloc y;;
            ret res
    }

Your task will be to prove its correctness with respect to the "pure"
function [fib_pure] (which you should define in plain Coq) as well as
the fact that it starts and ends in an empty heap.

Hint: What is the loop invariant of the recursive computation defined
by means of the [loop] function?

Hint: Try to decompose the reasoning into verification of several code
pieces as in the factorial example and then composing them together in
the "main" function.

*)

Fixpoint fib_pure n :=
  if n is n'.+1 then
    if n' is n''.+1 then fib_pure n' + fib_pure n'' else 1
  else 0.

Definition fib_inv (n x y : ptr) (N : nat) h : Prop :=
  exists n' x' y': nat,
  [/\ h = n :-> n'.+1 \+ x :-> x' \+ y :-> y',
      x' = fib_pure n' & y' = fib_pure (n'.+1)].

Definition fib_tp n x y N :=
  unit ->
     STsep (fib_inv n x y N,
           [vfun (res : nat) h => fib_inv n x y N h /\ res = fib_pure N]).

Program Definition fib_acc (n x y : ptr) N: fib_tp n x y N :=
  Fix (fun (loop : fib_tp n x y N) (_ : unit) =>
    Do (n' <-- read nat n;
        y' <-- !y;
        if n' == N then ret y'
        else tmp <-- !x;
             x ::= y';;
             x' <-- !x;
             y ::= x' + tmp;;
             n ::= n' + 1;;
             loop tt)).

Next Obligation.
move=>h /=[n'][_][_][->{h}]->->.
heval; case X: (n'.+1 == N)=>//.
- by apply: val_ret=>_; move/eqP: X=><-/=.
heval; apply: val_doR=>//. (* This line takes a while due to automation. *)
move=>_.
exists (n'.+1), (fib_pure (n'.+1)), (fib_pure n'.+1.+1).
by rewrite addn1.
Qed.

Program Definition fib N :
  STsep ([Pred h | h = Unit],
         [vfun res h => res = fib_pure N /\ h = Unit]) :=
  Do (
   if N == 0 then ret 0
   else if N == 1 then ret 1
   else n   <-- alloc 2;
        x <-- alloc 1;
        y <-- alloc 1;
        res <-- fib_acc n x y N tt;
        dealloc n;;
        dealloc x;;
        dealloc y;;
        ret res).

Next Obligation.
move=>_ /= ->.
case N1: (N == 0)=>//; first by move/eqP: N1=>->; apply:val_ret.
case N2: (N == 1)=>//; first by move/eqP: N2=>->; apply:val_ret.
heval=>n; heval=>x; heval=>y; rewrite unitR joinC [x:->_ \+ _]joinC.
apply: bnd_seq=>/=.
apply: val_doR; last first=>//[res h|].
- case; case=>n'[_][_][->{h}]->->->_.
  by heval; rewrite !unitR.
by exists 1, 1, 1.
Qed.

(**
---------------------------------------------------------------------
Exercise [Value-returning list beheading]
---------------------------------------------------------------------

Define and verify function [remove_val] which is similar to remove,
but also returns the value of the last "head" of the list before
removal, in addition to the "next" pointer. Use Coq's [option] type to
account for the possibility of an empty list in the result.

*)

Program Definition remove_val T p : {xs},
  STsep (lseq p xs,
         [vfun y h => lseq y.1 (behead xs) h /\
                      y.2 = (if xs is x::xs' then Some x else None)]) :=
  Do (if p == null then ret (p, None)
      else x <-- read T p;
           pnext <-- !(p .+ 1);
           dealloc p;;
           dealloc p .+ 1;;
           ret (pnext, Some x)).
Next Obligation.
apply: ghR=>i xs H V; case: ifP H=>H1.
- by rewrite (eqP H1); case/(lseq_null V)=>->->; heval.
case/(lseq_pos (negbT H1))=>x [q][h][->] <- /= H2.
by heval; rewrite 2!unitL.
Qed.

(**
---------------------------------------------------------------------
Exercise [Imperative in-place map]
---------------------------------------------------------------------

Define, specify and verify the imperative higher-order function
[list_map] that takes arguments two types, [S] and [T], a pure
function [f : T -> S] and a head [p] of a single-linked list,
described by a predicate [lseq], and changes the list in place by
applying [f] to each of its elements, while preserving the list's
structure. The specification should reflect the fact that the new
"logical" contents of the single-linked list are an [f] map-image of
the old content.

Hint: The lemmas [lseq_null] and [lseq_pos], proved previously, might
be useful in the proof of the established specification.

Hint: A tail-recursive call can be verified via HTT's [val_do] lemma,
reminiscent to the rule %\Rule{App}%. However, the heap it operates
with should be "massaged" appropriately via PCM's lemmas [joinC] and
[joinA].

Hint: A boolean lemma [negbT] can be useful to switch between
different representations of inequality.

*)

Definition mapT T S (f : T -> S) : Type :=
  forall p, {xs}, STsep (@lseq T p xs,
                         [vfun y h => y = tt /\ @lseq S p (map f xs) h]).

Program Definition list_map T S p (f : T -> S) :
   {xs}, STsep (@lseq T p xs,
                [vfun y h => y = tt /\ @lseq S p (map f xs) h]) :=
    Fix (fun (loop : mapT f) (p : ptr) =>
      Do (if p == null
          then ret tt
          else x <-- read T p;
               next <-- (read ptr p .+ 1);
               p ::= f x;;
               loop next)) p.
Next Obligation.
apply: ghR=>h xs H V.
case X: (p == null).
- apply: val_ret=>_ /=;  split=>//.
  by move/eqP: X H=>-> /=; case/(lseq_null V)=>->->.
case/negbT /lseq_pos /(_ H): X=>x[next][h'][Z1] Z2 H1; subst h.
heval.
move/validR: V=> V1; apply: (gh_ex (behead xs)).
rewrite [_ \+ h']joinC joinC -joinA; apply: val_do=>//=.
case=>m[_]H2 V2; split=>//.
rewrite [_ \+ p :-> _]joinC joinC.
by rewrite Z1 /=; exists next, m; rewrite joinA.
Qed.

(**
---------------------------------------------------------------------
Exercise [In-place list reversal]
---------------------------------------------------------------------

Let us define the following auxiliary predicates, where [shape_rev]
splits the heap into two disjoint linked lists (by means of the
separating conjunction [#]).

*)

Definition shape_rev T p s := [Pred h | h \In @lseq T p.1 s.1 # @lseq T p.2 s.2].

(**

Then the in-place list reversal is implemented by means of the
recursive function [reverse] with a loop invariant expressed using the
type [revT].

*)

Definition revT T : Type :=
  forall p, {ps}, STsep (@shape_rev T p ps, [vfun y => lseq y (rev ps.1 ++ ps.2)]).

Program Definition
reverse T p : {xs}, STsep (@lseq T p xs, [vfun y => lseq y (rev xs)]) :=
  Do (let: reverse := Fix (fun (reverse : revT T) p =>
                        Do (if p.1 == null then ret p.2
                            else xnext <-- !p.1 .+ 1;
                                 p.1 .+ 1 ::= p.2;;
                                 reverse (xnext, p.1)))
      in reverse (p, null)).

(**

You're invited to conduct the verification of [reverse], proving
that it satisfies the given specification.

Hint: It might be a good idea to make use of the previously proved
lemmas [lseq_null] and [lseq_pos].

Hint: Be careful with the logical values of variables passed to the
[gh_ex] lemma before verifying a recursive call of [reverse].

Hint: A verification goal to a function defined via [Fix] can be
reduced via the [val_doR] lemma or similar ones.

Hint: The [shape_rev] predicate is in fact an existential in disguise:
it can be proved by providing appropriate witnesses.

Hint: Lemmas [rev_cons], [cat_rcons] and [cats0] from the [seq]
library will be useful for establishing equalities between lists.

*)

Next Obligation.
apply:ghR=>i[xs1 xs2]; case=>h1[h2][->{i}]/=[H1 H2] V1.
case X: (p == null) H1=>H1.
- apply: val_ret=>/=_; move/eqP: X=>X; subst p.
  move/validL: (V1)=>V3; case:(lseq_null V3 H1)=>Z1 Z2; subst xs1 h1=>/=.
  by rewrite unitL.
case/negbT /(lseq_pos) /(_ H1): X=>x[next][h'][Exs]Z H3; subst h1.
heval; rewrite -!joinA -!(joinCA h'); apply: (gh_ex (behead xs1, x::xs2)).
apply: val_doR=>//=[V2|].
 - exists h', (p :-> x \+ (p .+ 1 :-> p1 \+ h2)); split=>//; split=>//.
   by exists p1, h2; rewrite !joinA.
by move=> z m H4 _; rewrite Exs rev_cons cat_rcons.
Qed.

Next Obligation.
apply: ghR=>i xs H V /=; apply: (gh_ex (xs, [::])).
apply: val_doR=>//=[_|]; first by exists i, Unit; rewrite unitR.
by rewrite cats0.
Qed.


Variables A B C : Prop.

(*Lemma and_commutative : A /\ B.
split.*)

Lemma and_commutative : A /\ B -> B /\ A.

intro H.

elim H.

(*auto.*)

(*apply conj.*)

intro.
intro.

split.

(*apply H1.*)
exact H1.
exact H0.

Qed.

Check conj.

Lemma or_commutative : A \/ B -> B \/ A.

intro H.

elim H.

intro HA.

clear H.

right.

apply HA.

intro HA.

clear H.

left.

apply HA.


Require Import A1_Plan A2_Orientation .
Require Import B2_CollinearProp B4_RaysProp B5_BetweenProp .
Require Import C1_Distance .
Require Import D3_SecondDimension .
Require Import E4_Tactics .
Require Import F2_MarkSegment.

Require Export Omega.

Section GRADUATION.

Definition GraduationSpec : forall A B : Point, forall Hab : A <> B, forall n : nat, {M : Point | Collinear A B M}.
Proof.
	intros; induction n.
	 exists A; apply CollinearABA.
	 destruct IHn as (An, Hn).
	   exists (AddSegmentPoint A B An A B Hab Hn).
	   assert (H := EquiOrientedAddSegmentPoint A B An A B Hab Hn).
	   apply CollinearBCA; apply (EquiOrientedCollinearACDCollinearBCD An).
	  exact H.
	  apply CollinearCAB; exact Hn.
Defined.

Definition Graduation (n : nat) (A B : Point) (Hab : A <> B) := let (An, _) := GraduationSpec A B Hab n in An.

Lemma Graduation0 : forall A B : Point, forall Hab : A <> B,
	Graduation 0 A B Hab = A.
Proof.
	intros; unfold Graduation in |- *.
	 simpl in |- *; trivial.
Qed.

Lemma Graduation1 : forall A B : Point, forall Hab : A <> B,
	Graduation 1 A B Hab = B.
Proof.
	intros; unfold Graduation in |- *; simpl in |- *.
	apply sym_eq; apply UniqueAddSegmentPoint; immediate4.
Qed.

Lemma CollinearGraduation : forall n : nat, forall A B : Point, forall Hab : A <> B,
	Collinear A B (Graduation n A B Hab).
Proof.
	intros; unfold Graduation in |- *; simpl in |- *.
	destruct (GraduationSpec A B Hab n) as (An, Hn).
	trivial.
Qed.

Lemma EqDistanceGraduation : forall n : nat, forall A B : Point, forall Hab : A <> B,
	Distance (Graduation n A B Hab) (Graduation (S n) A B Hab) = Distance A B.
Proof.
	intros; unfold Graduation in |- *; simpl in |- *.
	destruct (GraduationSpec A B Hab n) as (An, Hn).
	apply EqDistanceAddSegmentPoint.
Qed.

Lemma EquiOrientedGraduation : forall n : nat, forall A B : Point, forall Hab : A <> B,
	EquiOriented (Graduation n A B Hab) (Graduation (S n) A B Hab) A B.
Proof.
	intros; unfold Graduation in |- *; simpl in |- *.
	destruct (GraduationSpec A B Hab n) as (An, Hn).
	apply EquiOrientedAddSegmentPoint.
Qed.

Lemma GraduationSn : forall n : nat, forall A B : Point, forall Hab : A <> B,
	Graduation (S n) A B Hab = AddSegmentPoint A B (Graduation n A B Hab) A B Hab (CollinearGraduation n A B Hab).
Proof.
	intros.
	apply UniqueAddSegmentPoint.
	   apply EquiOrientedGraduation.
	   apply EqDistanceGraduation.
Qed.

Lemma GraduationDistinctnSn : forall n : nat, forall A B : Point, forall Hab : A <> B,
	Graduation n A B Hab <> Graduation (S n) A B Hab.
Proof.
	intros.
	assert (H0 := EqDistanceGraduation n A B Hab).
	step4 H0.
Qed.

Lemma GraduationBetweennSnSSn : forall n : nat, forall A B : Point, forall Hab : A <> B,
	Between (Graduation n A B Hab) (Graduation (S n) A B Hab) (Graduation (S (S n)) A B Hab).
Proof.
	intros; split.
	 apply GraduationDistinctnSn.
	 assert (H := EquiOrientedGraduation n A B Hab);
	  assert (H0 := EquiOrientedGraduation (S n) A B Hab).
	   step4 H.
	   step4 H0.
	  apply GraduationDistinctnSn.
	  right; assert (H1 := CollinearGraduation (S (S n)) A B Hab); immediate4.
Qed.

Lemma GraduationClosedRay : forall n : nat, forall A B : Point, forall Hab : A <> B,
	ClosedRay A B (Graduation n A B Hab).
Proof.
	intros; induction n.
	 rewrite Graduation0; immediate4.
	 apply (EquiOrientedClosedRayClosedRay A B (Graduation n A B Hab)).
	  apply EquiOrientedGraduation.
	  trivial.
Qed.

Lemma GraduationSegment : forall n : nat, forall A B : Point, forall Hab : A <> B,
	Segment A (Graduation (S n) A B Hab) (Graduation n A B Hab).
Proof.
	intros.
	apply (EquiOrientedClosedRaySegment A B).
	 apply EquiOrientedGraduation.
	 apply GraduationClosedRay.
Qed.

End GRADUATION.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
From fcsl
Require Import pred prelude ordtype finmap pcm unionmap.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Keys.
Variables (K : ordType) (V : Type) (U : union_map_class K V).
Implicit Types (k : K) (v : V) (f : U).

Lemma keys_last_mono f1 f2 k :
        path oleq k (dom f1) ->
        path oleq k (dom f2) ->
        (forall x, x \in dom f1 -> x \in dom f2) ->
        oleq (last k (dom f1)) (last k (dom f2)).
Proof.
rewrite !umEX; case: (UMC.from f1); first by move=>_ H _; apply: path_last H.
move=>{f1} f1 /= _ H1; case: (UMC.from f2)=>/=.
- by move=>_ /allP; case: (supp f1)=>//; rewrite /oleq eq_refl orbT.
by move=>{f2} f2 /= _; apply: seq_last_mono H1.
Qed.

End Keys.

(* Last_key and Fresh are constructs that work *)
(* for any union map with integer keys *)
(* Should be developed more generally for any union map class *)
(* with a proof that key U = nat, but I can't bother right now *)

Section FreshLastKey.
Variable V : Type.
Implicit Type f : union_map [ordType of nat] V.

Definition last_key f := last 0 (dom f).

Lemma last_key0 : last_key Unit = 0.
Proof. by rewrite /last_key /Unit /= !umEX. Qed.

Lemma last_key_dom f : valid f -> last_key f \notin dom f -> f = Unit.
Proof.
rewrite /valid /= /last_key /Unit /= !umEX /= -{4}[f]UMC.tfE.
case: (UMC.from f)=>//=; case=>s H /= H1 _ /seq_last_in.
rewrite /UM.empty UMC.eqE UM.umapE /supp fmapE /= {H H1}.
by elim: s.
Qed.

Lemma dom_last_key f :  valid f -> ~~ empb f -> last_key f \in dom f.
Proof. by move=>X; apply: contraR; move/(last_key_dom X)=>->; apply/empbP. Qed.

Lemma last_key_max f x : x \in dom f -> x <= last_key f.
Proof.
rewrite /last_key /= !umEX; case: (UMC.from f)=>//; case=>s H _ /=.
rewrite /supp /ord /= (leq_eqVlt x) orbC.
by apply: sorted_last_key_max (sorted_oleq H).
Qed.

Lemma max_key_last f x :
        x \in dom f -> {in dom f, forall y, y <= x} -> last_key f = x.
Proof.
rewrite /last_key !umEX; case: (UMC.from f)=>//; case=>s H _ /=.
move=>H1 /= H2; apply: sorted_max_key_last (sorted_oleq H) H1 _.
by move=>z /(H2 z); rewrite leq_eqVlt orbC.
Qed.

Lemma last_keyPt (x : nat) v : last_key (x \\-> v) = x.
Proof. by rewrite /last_key /um_pts /= !umEX. Qed.

Lemma hist_path f : path oleq 0 (dom f).
Proof.
rewrite !umEX; case: (UMC.from f)=>// {f} f /= _; case: f; case=>//= x s H.
rewrite {1}/oleq /ord /= orbC -leq_eqVlt /=.
by apply: sub_path H=>z y; rewrite /oleq=>->.
Qed.

Lemma last_key_mono f1 f2 :
        {subset dom f1 <= dom f2} -> last_key f1 <= last_key f2.
Proof.
rewrite leq_eqVlt orbC=>H; apply: (@keys_last_mono _ _ _ f1 f2);
try by apply: hist_path.
by move=>x /=; move: (H x).
Qed.

Lemma last_keyfUn f1 f2 :
        valid (f1 \+ f2) -> last_key f1 <= last_key (f1 \+ f2).
Proof. by move=>X; apply: last_key_mono=>x; rewrite domUn inE X => ->. Qed.

Lemma last_keyUnf f1 f2 :
        valid (f1 \+ f2) -> last_key f2 <= last_key (f1 \+ f2).
Proof. by rewrite joinC; apply: last_keyfUn. Qed.

(* freshness *)

Definition fresh f := (last_key f).+1.

Lemma dom_ordfresh f x : x \in dom f -> x < fresh f.
Proof. by move/last_key_max. Qed.

Lemma dom_freshn f n : fresh f + n \notin dom f.
Proof. by apply: contra (@dom_ordfresh _ _) _; rewrite -leqNgt leq_addr. Qed.

Lemma dom_fresh f : fresh f \notin dom f.
Proof. by move: (dom_freshn f 0); rewrite addn0.  Qed.

Lemma valid_fresh f v : valid (f \+ fresh f \\-> v) = valid f.
Proof. by rewrite joinC validPtUn dom_fresh andbT. Qed.

Lemma valid_fresh' f v i w :
  valid (f \+ i \\-> w) ->
  valid (f \+ fresh (f \+ i \\-> w) \\-> v).
Proof.
move=> W; rewrite joinC validPtUn.
move: (dom_fresh (f \+ i \\-> w)); rewrite domUn inE; rewrite W/=.
by rewrite negb_or=>/andP; case=>-> _;move/validL: W=>->.
Qed.

Lemma last_fresh f v : valid f -> last_key (f \+ fresh f \\-> v) = fresh f.
Proof.
move=>Vf; apply: max_key_last=>[|x] /=.
- by rewrite domUn inE valid_fresh Vf domPt inE eq_refl orbT.
rewrite domUn inE /= valid_fresh Vf /= domPt inE /= orbC eq_sym.
by rewrite leq_eqVlt; case: eqP=>//= _; apply: dom_ordfresh.
Qed.

End FreshLastKey.


Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
  (* FILL IN HERE *)
andb b3 (andb b1 b2).

Example test_andb31: (andb3 true true true) = true.
(* FILL IN HERE *) Proof. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
(* FILL IN HERE *) Proof. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
(* FILL IN HERE *) Proof. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
(* FILL IN HERE *) Proof. reflexivity. Qed.


Require Import Classical.
Require Import Eqdep_dec.
Require Import Fin.
Require Import List.

Require Import dec.
Require Import set.

Inductive isFinite `(T: EqDec): Prop :=
  isFinite_intro: forall s: SV.set T, (forall x, SV.set_In x s) -> isFinite T.

Class Finite {T} := {
  fin_dec : @EqDec T;
  fin_set: SV.set fin_dec;
  fin_all: forall x, SV.set_In x fin_set;
}.
Coercion fin_dec: Finite >-> EqDec.
Arguments fin_set _ _ : assert.

Fixpoint fin2list n : list (Fin.t n) :=
  match n with
    0 => nil
  | S m => cons F1 (List.map FS (fin2list m))
  end.

Lemma fin2list_all: forall n, forall x, SV.set_In x (fin2list n).
Proof.
  intros.
  destruct n.
  inversion x.
  revert n x.
  apply rectS; intros; try (simpl; now auto).
  right.
  induction (fin2list (S n)); simpl; auto.
  destruct H.
  subst p; left; now auto.
  right; apply IHl; auto.
Qed.

Instance uptoFinite n: @Finite (Fin.t n) := {|
  fin_dec := uptoDec n;
  fin_set := fin2list n;
  fin_all := fin2list_all n
|}.

Lemma FiniteIsFinite: forall `(F: Finite), isFinite F.
Proof.
  intros.
  apply isFinite_intro with (s:= fin_set).
  apply fin_all.
Qed.

Program Definition subDec `{T:EqDec} (P:T->Prop): @EqDec {x:T | P x} := {|
  eq_dec := _
|}.
Next Obligation.
  repeat intro.
  destruct x as [x hx].
  destruct y as [y hy].
  destruct (eq_dec x y).
  subst y.
  left.
  f_equal.
  apply proof_irrelevance.
  right; intro.
  apply n; clear n.
  injection H; clear H; intros; auto.
Qed.

Definition asDec `{T:EqDec} (s: SV.set T): @EqDec {x : T | SV.set_In x s} := subDec (fun x => SV.set_In x s).

Program Definition subFinite `(T:Finite) (P: T->Decidable): @Finite {x : T | P x} := {|
  fin_dec := subDec P;
  fin_set := SV.GUnion (T1 := T) (T2 := subDec P)
      fin_set  fin_set
      (fun x _ => match @dc_dec (P x) with
        left h => SV.sing (subDec P) (exist _ x h)
      | right _ => SV.empty (subDec P)
      end)
|}.
Next Obligation.
  destruct x.
  eapply SV.InCUnion_intro with (u:= x); intros; auto.
  apply fin_all.
  apply fin_all.
  destruct dc_dec; try tauto.
  apply SV.InSing.
  f_equal; apply proof_irrelevance.
Qed.

Program Definition asFinite `{T:EqDec} (s: SV.set T): @Finite {x : T | SV.set_In x s} := {|
  fin_dec := asDec s;
  fin_set := SV.GUnion (T1 := T) (T2 := asDec s)
      s s
      (fun x h => SV.sing (asDec s) (exist _ x h))
|}.
Next Obligation.
  destruct x.
  eapply SV.InCUnion_intro with (u:= x); intros; auto.
  left.
  f_equal; apply proof_irrelevance.
Qed.

Lemma InFin: forall `{T:EqDec} (s: SV.set T) (x: asFinite s), In (proj1_sig x) s.
Proof.
  intros.
  generalize (fin_all x).
  destruct x; simpl; intros.
  apply SV.InCUnion_elim in H; auto.
Qed.

Definition DepPairSet `{T1: EqDec} {U: T1 -> Type} {T2: forall t, @EqDec (U t)}  {e1: SV.set T1} (e2: forall x, SV.set (T2 x)): SV.set (DepPairDec T1 T2) :=
    SV.GUnion (T1 := T1) (T2 := DepPairDec T1 T2)
      e1 e1
      (fun s h =>
          SV.image (T1 := T2 s) (T2 := DepPairDec T1 T2)
            (fun d => (existT _ s d))
            (e2 s)).

Program Definition DepPairFin `(F1: Finite) {U2:F1->Type} (F2: forall t, @Finite (U2 t)): Finite := {|
  fin_dec := DepPairDec F1 F2;
  fin_set := DepPairSet (T1:=F1) (T2:=F2) (e1:=@fin_set _ F1) (fun x => @fin_set _ (F2 x))
|}.
Next Obligation.
  intros.
  destruct x.
  apply SV.InCUnion_intro with (u:= x); simpl; intros.
  apply fin_all.
  apply fin_all.
  apply (SV.InImage_intro (T1:=F2 x) (T2 := DepPairDec F1 F2)) with (w:=e); auto.
  apply fin_all.
Qed.

Definition PairSet `{T1: EqDec} `{T2: EqDec}  {e1: SV.set T1} (e2: SV.set T2): SV.set (PairDec T1 T2) :=
    SV.GUnion (T1 := T1) (T2 := PairDec T1 T2)
      e1 e1
      (fun s h =>
          SV.image (T1 := T2) (T2 := PairDec T1 T2)
            (fun d => (s, d))
            e2).

Program Definition PairFin `(F1: Finite) `(F2: Finite): Finite := {|
  fin_dec := PairDec F1 F2;
  fin_set := @PairSet _ _ _ _ (@fin_set _ F1) (@fin_set _ F2)
|}.
Next Obligation.
  intros.
  destruct x.
  apply SV.InCUnion_intro with (u:= e); simpl; intros.
  apply fin_all.
  apply fin_all.
  apply (SV.InImage_intro (T1:=F2) (T2 := PairDec F1 F2)) with (w:=e0); auto.
  apply fin_all.
Qed.

Definition SumSet `{T1: EqDec} `{T2: EqDec} (e1: SV.set T1) (e2: SV.set T2): SV.set (SumDec T1 T2) :=
  SV.union
    (SV.image (T1:=T1) (T2:=SumDec T1 T2) inl e1)
    (SV.image (T1:=T2) (T2:=SumDec T1 T2) inr e2).

Program Definition SumFin `(F1: Finite) `(F2: Finite): Finite := {|
  fin_dec := SumDec F1 F2;
  fin_set := SumSet (T1:=F1) (T2:=F2) (@fin_set _ F1) (@fin_set _ F2)
|}.
Next Obligation.
  intros; simpl in *.
  destruct x.
  apply SV.InUnion_l.
  apply SV.InImage_intro with (w:=e); auto.
  apply fin_all.
  apply SV.InUnion_r.
  apply SV.InImage_intro with (w:=e); auto.
  apply fin_all.
Qed.

Require Import FunctionalExtensionality.

Lemma len_CUnion_all: forall `(T: EqDec) (P: T->Decidable) (s: SV.set T),
  (forall x, In x s -> P x) ->
  length
    (SV.CUnion P s (fun (x:T) (h: P x) => SV.sing (subDec P) (exist P x h))) = length s.
Proof.
  intros until P.
  induction s; simpl; intros; auto.
  destruct dc_dec.
  simpl.
  f_equal.
  rewrite IHs; auto.

  exfalso; apply n; apply H; auto.
Qed.

Lemma asFinite_len: forall `(T: EqDec) (s: list T), length s = length (fin_set (Finite:=asFinite s)).
Proof.
  induction s; intros; auto.
  simpl.
  unfold SV.GUnion; simpl.
  destruct (eq_dec a a); try tauto.
  simpl.
  f_equal.
  rewrite IHs; clear IHs.
  unfold fin_set, asFinite, SV.GUnion; simpl.
  generalize (len_CUnion_all T (SV.InPred T s)); intros; auto.
  rewrite H; clear H.
  generalize (len_CUnion_all T (SV.InPred T (a::s))); intros; auto.
  rewrite H; clear H; auto.
  intros; right; now auto.
  intros; now auto.
  exfalso; tauto.
Qed.

Lemma CUnion_imp: forall `(T: Finite) (P Q1 Q2: T -> Decidable) s e
  (imp1: forall x, Q2 x -> Q1 x)
  (imp2: forall x, In x s -> Q1 x -> Q2 x),
  (@SV.CUnion T0 T {x : T | P x} (@subDec T0 T (fun x : T => P x))
     Q1 s e) =
  (@SV.CUnion T0 T {x : T | P x} (@subDec T0 T (fun x : T => P x))
     Q2 s (fun x h => e x (imp1 _ h))).
Proof.
  induction s; simpl; intros; auto.
  destruct (@dc_dec (Q2 a)).
  destruct (@dc_dec (Q1 a)).
  rewrite (proof_irrelevance _ (imp1 a d) d0).
  rewrite <-IHs.
  reflexivity.

  intros.
  apply imp2; now auto.

  exfalso; apply imp1 in d; tauto.

  rewrite <-IHs; clear IHs; auto.
  destruct (@dc_dec (Q1 a)); auto.
  exfalso; apply imp2 in d; tauto.
Qed.

Lemma CUnion_cons: forall `(T: Finite) (P: T -> Decidable) a s e,
  (@SV.CUnion T0 T {x : T | P x} (@subDec T0 T (fun x : T => P x))
     (@SV.InPred T0 T (a :: s)) s e) =
  (@SV.CUnion T0 T {x : T | P x} (@subDec T0 T (fun x : T => P x))
     (@SV.InPred T0 T s) s (fun v h => e v (or_intror h))).
Proof.
  intros.
  generalize (CUnion_imp _ P (@SV.InPred T0 T (a :: s)) (@SV.InPred T0 T s)); intro.
  rewrite <-H; clear H; auto.
Qed.

Lemma subFinite_len: forall `(T:Finite) (P: T->Decidable), length (fin_set (Finite:= subFinite T P)) = length (filter (fun x => if (@dc_dec (P x)) then true else false) (fin_set (Finite:=T))).
Proof.
  intros.
  unfold subFinite; simpl.
  induction (@fin_set T0 T); simpl; intros; auto.
  destruct (@dc_dec (P a)); simpl; auto.
  rewrite <-IHs; clear IHs.
  unfold SV.GUnion; simpl.
  destruct (@dc_dec (P a)); try tauto.
  destruct (@eq_dec T0 T a a); try (exfalso; tauto).
  rewrite app_length; simpl.
  f_equal.
  rewrite CUnion_cons; simpl.
  reflexivity.

  unfold SV.GUnion; simpl.
  destruct (@eq_dec T0 T a a); try (exfalso; tauto).
  destruct (@dc_dec (P a)); try tauto.
  unfold SV.empty; simpl.
  rewrite CUnion_cons; apply IHs.
Qed.

Lemma len_filter: forall T (l: list T) (P: T->bool), length (filter P l) <= length l.
Proof.
  induction l; simpl; intros; auto.
  destruct (P a); simpl; auto with arith.
Qed.

Program Instance FunDec `(T1: Finite) `(T2: EqDec) : @EqDec (T1->T2) := {| eq_dec := _ |}.
Next Obligation.
  repeat intro.
  set (n := List.length fin_set).
  assert (length fin_set <= n) by apply le_n; clearbody n.
  revert T T1 x y H.
  induction n; simpl; intros; auto.
  left.
  apply functional_extensionality; intro.
  generalize (fin_all x0); intro.
  destruct fin_set.
  inversion H0.
  inversion H.

  destruct fin_set eqn:fs.
  left.
  apply functional_extensionality; intro.
  generalize (fin_all x0); intro.
  rewrite fs in H0; destruct H0.

  destruct (eq_dec (x e) (y e)).
  set (T1s := (subFinite T1 (fun x => isNEq x e))).
  set (x1 := fun (i:T1s) => x (proj1_sig i)).
  set (y1 := fun (i:T1s) => y (proj1_sig i)).

  generalize (IHn _ (subFinite T1 (fun x => isNEq x e)) x1 y1); intro.
  destruct H0.

  clear x1 y1 IHn T1s.
  rewrite subFinite_len.
  rewrite fs; clear fs.
  simpl.
  destruct (@eq_dec T T1 e e); try (exfalso; tauto).
  simpl in H.
  assert (@length T1 s <= n) by auto with arith.
  apply Le.le_trans with (m := length s); auto.
  apply len_filter.

  left.
  apply functional_extensionality; intro.
  destruct (@dc_dec (isNEq x0 e)).
  assert (x1 (exist _ x0 d) = y1 (exist _ x0 d)).
  rewrite e1; reflexivity.
  apply H0.

  assert (x0=e).
  destruct (eq_dec x0 e); auto.
  exfalso; apply n0; simpl; apply n1.
  subst x0; now auto.

  right; intro; apply n0; clear n0.
  unfold x1,y1; subst; now auto.

  right; intro.
  apply n0; subst y; now auto.
Qed.

Lemma in_tl: forall `(T: EqDec) {x i} {e: SV.set T},
  In i (x::e) -> i <> x -> In i e.
Proof.
  intros.
  destruct H; auto.
  subst x; tauto.
Qed.

Fixpoint FunSet `{T1: Finite} `{T2: Finite} (e1: SV.set T1) (e2: SV.set T2): SV.set (FunDec (asFinite e1) T2) :=
  match e1 return SV.set (FunDec (asFinite e1) T2) with
    nil => SV.sing (FunDec (asFinite nil) T2) (fun v => let '(exist _ i h) := v in match h with end)
  | x::e =>
    SV.CUnion
      (U := FunDec (asFinite e) T2)
      (T0 := FunDec (asFinite (x::e)) T2)
      (fun _ => TrueDec)
      (FunSet e e2)
      (fun f h =>
        SV.CUnion
          (U := T2)
          (T0 := FunDec (asFinite (x::e)) T2)
          (fun _ => TrueDec)
          e2
          (fun y _ => SV.sing (FunDec (asFinite (x::e)) T2) (fun v => let '(exist _ i hi) := v in
            match eq_dec i x with
              left e => y
            | right n => f (exist _ i (in_tl T1 hi n))
            end)))
  end.

Program Definition FunFin `(F1: Finite) `(F2: Finite): Finite := {|
  fin_dec := FunDec F1 F2;
  fin_set :=
    List.map (fun f i => f (exist _ i (fin_all i)))
      (FunSet (T1:=F1) (T2:=F2) (@fin_set _ F1) (@fin_set _ F2))
|}.
Next Obligation.
  change (fix In (a : F1) (l : list F1) {struct l} : Prop :=
                  match l with
                  | nil => False
                  | b :: m => b = a \/ In a m
                  end) with (@In F1).
  apply in_map_iff; intros.
  exists (fun v => let '(exist _ i h) := v in x i).
  split; auto.
  match goal with |- @In _ ?v _ => generalize v; clear x end.
  induction (@fin_set T F1); intros; auto.

  simpl; left.
  apply functional_extensionality; intro i.
  destruct i; tauto.

  unfold FunSet.
  set (e0 := fun v => let ' (exist _ i h) := v in e (exist _ i (or_intror h))).
  apply SV.InCUnion_intro with (u:=e0); simpl; auto.
  apply IHs.

  intro.
  eapply SV.InCUnion_intro with (u:= e (exist _ a (or_introl eq_refl))); simpl; auto.
  apply fin_all.
  intro.
  left.
  apply functional_extensionality; intro v.
  destruct v; simpl; auto.
  destruct (eq_dec a x).
  subst x.
  destruct (@eq_dec T F1 a a); try (exfalso; tauto).
  rewrite (proof_irrelevance _ _ o).
  reflexivity.
  destruct (@eq_dec T F1 x a); simpl; auto.
  exfalso; subst x; tauto.
  rewrite (proof_irrelevance _ _ o).
  reflexivity.
Qed.

Program Instance DepFunDec {T1: Type} (F1: @Finite T1) {T2: T1 -> Type} (F2: forall x, @Finite (T2 x)) : @EqDec (forall x, F2 x) := {| eq_dec := _ |}.
Next Obligation.
  repeat intro.
  set (n := List.length (fin_set (Finite:=F1))).
  assert (length (fin_set (Finite:=F1)) <= n) by apply le_n; clearbody n.
  revert T1 F1 T2 F2 x y H.
  induction n; simpl; intros; auto.
  left.
  apply functional_extensionality_dep; intro.
  generalize (fin_all (Finite:=F1) x0); intro.
  destruct (fin_set (Finite:=F1)).
  inversion H0.
  inversion H.

  destruct (fin_set (Finite:=F1)) eqn:fs.
  left.
  apply functional_extensionality_dep; intro.
  generalize (fin_all (Finite:=F1) x0); intro.
  rewrite fs in H0; destruct H0.

  destruct (eq_dec (x e) (y e)).
  set (T1s := (subFinite F1 (fun x => isNEq x e))).
  set (x1 := fun (i:T1s) => x (proj1_sig i)).
  set (y1 := fun (i:T1s) => y (proj1_sig i)).

  generalize (IHn _ (subFinite F1 (fun x => isNEq x e)) _ _ x1 y1); intro.
  destruct H0.

  clear x1 y1 IHn T1s.
  rewrite subFinite_len.
  rewrite fs; clear fs.
  simpl.
  destruct (@eq_dec T1 F1 e e); try (exfalso; tauto).
  simpl in H.
  assert (@length T1 s <= n) by auto with arith.
  apply Le.le_trans with (m := length s); auto.
  apply len_filter.

  left.
  apply functional_extensionality_dep; intro.
  destruct (@dc_dec (isNEq x0 e)).
  assert (x1 (exist _ x0 d) = y1 (exist _ x0 d)).
  rewrite e1; reflexivity.
  apply H0.

  assert (x0=e).
  destruct (eq_dec x0 e); auto.
  exfalso; apply n0; simpl; apply n1.
  subst x0; now auto.

  right; intro; apply n0; clear n0.
  unfold x1,y1; subst; now auto.

  right; intro.
  apply n0; subst y; now auto.
Qed.

Fixpoint DepFunSet {T1:Type} `{F1: @Finite T1} {T2: T1->Type} {F2: forall x, @Finite (T2 x)} (e1: SV.set F1) (e2: forall x, SV.set (F2 x)): SV.set (DepFunDec (asFinite e1) (fun i => F2 (proj1_sig i))) :=
  match e1 return SV.set (DepFunDec (asFinite e1) (fun i => F2 (proj1_sig i))) with
    nil => SV.sing (DepFunDec (asFinite nil) (fun i => F2 (proj1_sig i))) (fun '(exist _ i h) => match h with end)
  | x::e =>
    SV.CUnion
      (U := DepFunDec (asFinite e) (fun i => F2 (proj1_sig i)))
      (T0 := DepFunDec (asFinite (x::e)) (fun  i => F2 (proj1_sig i)))
      (fun _ => TrueDec)
      (DepFunSet e e2)
      (fun f h =>
        SV.CUnion
          (U := F2 x)
          (T0 := DepFunDec (asFinite (x::e)) (fun i => F2 (proj1_sig i)))
          (fun _ => TrueDec)
          (e2 x)
          (fun y _ => SV.sing (DepFunDec (asFinite (x::e)) (fun i => F2 (proj1_sig i)))
            (fun '(exist _ i hi) =>
              match eq_dec i x return F2 i with
                left e => match eq_sym e in _=a return F2 a with eq_refl => y end
              | right n => f (exist (fun i => In i e) i (in_tl F1 hi n))
              end)))
  end.

Program Definition DepFunFin  {T1} (F1: @Finite T1) {T2:T1->Type} (F2: forall x:T1, @Finite (T2 x)): Finite := {|
  fin_dec := DepFunDec F1 F2;
  fin_set :=
    List.map (fun f i => f (exist _ i (fin_all i)))
      (DepFunSet (T1:=F1) (T2:=F2) (@fin_set F1 F1) (fun i => @fin_set _ (F2 i)))
|}.
Next Obligation.
  apply in_map_iff; intros.
  exists (fun v => x (proj1_sig v)).
  split; auto.
  match goal with |- @In _ ?v _ => generalize v; clear x end.
  induction (@fin_set F1 F1); intros; auto.

  simpl; left.
  apply functional_extensionality_dep; intro i.
  destruct i; tauto.

  set (e0 := fun (v: {i:T1 | In i s}) => match v return F2 (proj1_sig v) with (exist _ i h) => e (exist _ i (or_intror h)) end).
  apply SV.InCUnion_intro with (u:=e0); simpl; auto.
  apply IHs.

  intro.
  eapply SV.InCUnion_intro with (u:= e (exist _ a (or_introl eq_refl))); simpl; auto.
  apply fin_all.
  intro.
  left.
  apply functional_extensionality_dep; intro v.
  destruct v; simpl; auto.
  destruct (eq_dec a x).
  subst x.
  match goal with |- match ?cnd with _=>_ end = _ => destruct cnd; try (exfalso; tauto) end.
  rewrite (proof_irrelevance _ _ eq_refl).
  rewrite (proof_irrelevance _ _ o).
  reflexivity.
  match goal with |- match ?cnd with _=>_ end = _ => destruct cnd end.
  exfalso; subst x; tauto.
  rewrite (proof_irrelevance _ _ o).
  reflexivity.
Qed.

Program Definition EmptyFin: Finite := {| fin_dec := EmptyDec; fin_set := SV.empty _ |}.
Next Obligation.
  destruct x.
Defined.

Program Definition OneFin: Finite := {| fin_dec := OneDec; fin_set := SV.sing OneDec one |}.
Next Obligation.
  destruct x; left; reflexivity.
Qed.

Program Definition TwoFin: Finite := {| fin_dec := TwoDec; fin_set := SV.add (T:=TwoDec) true (SV.sing TwoDec false) |}.
Next Obligation.
  destruct x; tauto.
Qed.

Lemma ex_dec: forall `{F:Finite} (P: F -> Decidable), {k | P k}+{forall k, not (P k)}.
Proof.
  intros.
  destruct (SV.ex_dec P (@fin_set _ F)); [left|right]; intros.
  destruct s.
  exists x; tauto.
  apply (n k); clear n.
  apply fin_all.
Defined.

Lemma first_dec: forall `{F:Finite} (P: F -> Decidable), {k | P k}+{forall k, SV.set_In k fin_set -> not (P k)}.
Proof.
  intros.
  destruct (SV.first_dec P (@fin_set _ F)); [left|right]; intros.
  destruct s.
  exists x; tauto.
  apply (n k H).
Defined.

Lemma last_dec: forall `{F:Finite} (P: F -> Decidable), {k | P k}+{forall k, SV.set_In k fin_set -> not (P k)}.
Proof.
  intros.
  destruct (SV.last_dec P (@fin_set _ F)); [left|right]; intros.
  destruct s.
  exists x; tauto.
  apply (n k H).
Defined.

Lemma all_dec `{F: Finite} (P: F -> Decidable): (forall k, P k) + {k | not (P k)}.
Proof.
  destruct (ex_dec (fun x => NotDec (P x))).
  right; apply s.
  left; intro.
  apply NNPP; intro.
  apply (n k).
  apply H.
Defined.

Program Instance ExDecidable {T} {P: T -> Prop} (ch: {k:T | P k}+{forall k, not (P k)}): Decidable :=
{|
  dcPred := exists k, P k
|}.
Next Obligation.
  destruct ch; [left|right].
  destruct s as [k h]; exists k; auto.
  intro.
  destruct H as [k h]; apply (n k h).
Defined.

Program Instance AllDecidable {T} {P: T -> Prop} (ch: ((forall k, P k)+{k:T | not (P k)})): Decidable :=
{|
  dcPred := forall k, P k
|}.
Next Obligation.
  destruct ch; [left|right]; intros; auto.
  destruct s as [k h].
  intro.
  apply h; apply (H k).
Defined.

Lemma all1_dec `{F: Finite} (P: F -> Decidable): Decidable.
Proof.
  exists (forall x, @dcPred (P x)).
  destruct (all_dec (fun x => P x)); [left; auto|right; repeat intro].
  destruct s as [x h]; simpl in h.
  apply (h (H x)).
Defined.

Lemma all2_dec `{F: Finite} (P: F -> F -> Decidable): Decidable.
Proof.
  exists (forall x y, @dcPred (P x y)).
  destruct (all_dec (fun x => AllDecidable (all_dec (fun y => P x y)))); [left|right].
  apply d.
  intro.
  destruct s as [x h]; simpl in h.
  apply (h (H x)).
Defined.