(** * Poly: Polymorphism and Higher-Order Functions *)

(*Iniciado dia 29/07, puxando módulo List *)
(*Autor: geremias corrêa*)

(*Aqui também se encontram as resoluções da lista de 5 de polimorfismo.
Havia o documento ListaPoly.v para realizá-lo, porém por problema de import ficou mais fácil fazer aqui
A resolução deles se encontram anexados ao final. Na linha 1076 (prox do fim)*)
(*Para achar um ctrl f com: "LISTA 5" a encontra*)

(* Suppress some annoying warnings from Coq: *)
Set Warnings "-notation-overridden,-parsing".
(*From LF Require Export Lists. (*Já que não consigo importar*)*)

(* ################################################################# *)
(** * Polymorphism *)

(** In this chapter we continue our development of basic
    concepts of functional programming.  The critical new ideas are
    _polymorphism_ (abstracting functions over the types of the data
    they manipulate) and _higher-order functions_ (treating functions
    as data).  We begin with polymorphism. *)

(* ================================================================= *)
(** ** Polymorphic Lists *)

(** For the last couple of chapters, we've been working just
    with lists of numbers.  Obviously, interesting programs also need
    to be able to manipulate lists with elements from other types --
    lists of strings, lists of booleans, lists of lists, etc.  We
    _could_ just define a new inductive datatype for each of these,
    for example... *)

(*Import manual advindo do Lists.v, Basics.v - tinha importado os notation do List tbm, mas ele vai importar dps:*)
Module NatList.
From Coq Require Export String.
Fixpoint eqb (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => eqb n' m'
            end
  end.

(** Similarly, the [leb] function tests whether its first argument is
    less than or equal to its second argument, yielding a boolean. *)

Fixpoint leb (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => leb n' m'
      end
  end.
Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.
Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.
(*FIm import*)

(*Obs: Aqui nil e const são construtores polimórficos, difernete de no Lists.
Devem ser passados neles um parâmetro que identifica o tipo da lista sendo construída*)

Inductive boollist : Type :=
  | bool_nil
  | bool_cons (b : bool) (l : boollist).

(** ... but this would quickly become tedious, partly because we
    have to make up different constructor names for each datatype, but
    mostly because we would also need to define new versions of all
    our list manipulating functions ([length], [rev], etc.) for each
    new datatype definition. *)

(** To avoid all this repetition, Coq supports _polymorphic_
    inductive type definitions.  For example, here is a _polymorphic
    list_ datatype. *)

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

(** This is exactly like the definition of [natlist] from the
    previous chapter, except that the [nat] argument to the [cons]
    constructor has been replaced by an arbitrary type [X], a binding
    for [X] has been added to the header, and the occurrences of
    [natlist] in the types of the constructors have been replaced by
    [list X].  (We can re-use the constructor names [nil] and [cons]
    because the earlier definition of [natlist] was inside of a
    [Module] definition that is now out of scope.)

    What sort of thing is [list] itself?  One good way to think
    about it is that [list] is a _function_ from [Type]s to
    [Inductive] definitions; or, to put it another way, [list] is a
    function from [Type]s to [Type]s.  For any particular type [X],
    the type [list X] is an [Inductive]ly defined set of lists whose
    elements are of type [X]. *)

Check list.
(* ===> list : Type -> Type *)

(** The parameter [X] in the definition of [list] automatically
    becomes a parameter to the constructors [nil] and [cons] -- that
    is, [nil] and [cons] are now polymorphic constructors; when we use
    them, we must now provide a first argument that is the type of the
    list they are building. For example, [nil nat] constructs the
    empty list of type [nat]. *)

Check (nil nat).
(* ===> nil nat : list nat *)

(** Similarly, [cons nat] adds an element of type [nat] to a list of
    type [list nat]. Here is an example of forming a list containing
    just the natural number 3. *)

Check (cons nat 3 (nil nat)).
(* ===> cons nat 3 (nil nat) : list nat *)

(** What might the type of [nil] be? We can read off the type [list X]
    from the definition, but this omits the binding for [X] which is
    the parameter to [list]. [Type -> list X] does not explain the
    meaning of [X]. [(X : Type) -> list X] comes closer. Coq's
    notation for this situation is [forall X : Type, list X]. *)

Check nil.
(* ===> nil : forall X : Type, list X *)

(** Similarly, the type of [cons] from the definition looks like
    [X -> list X -> list X], but using this convention to explain the
    meaning of [X] results in the type [forall X, X -> list X -> list
    X]. *)

Check cons. (*Ideia de contrutor*)
(* ===> cons : forall X : Type, X -> list X -> list X *)

(** (Side note on notation: In .v files, the "forall" quantifier
    is spelled out in letters.  In the generated HTML files and in the
    way various IDEs show .v files (with certain settings of their
    display controls), [forall] is usually typeset as the usual
    mathematical "upside down A," but you'll still see the spelled-out
    "forall" in a few places.  This is just a quirk of typesetting:
    there is no difference in meaning.) *)

(** Having to supply a type argument for each use of a list
    constructor may seem an awkward burden, but we will soon see
    ways of reducing that burden. *)

Check (cons nat 2 (cons nat 1 (nil nat))).

(** (We've written [nil] and [cons] explicitly here because we haven't
    yet defined the [ [] ] and [::] notations for the new version of
    lists.  We'll do that in a bit.) *)

(** We can now go back and make polymorphic versions of all the
    list-processing functions that we wrote before.  Here is [repeat],
    for example: *)

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

(** As with [nil] and [cons], we can use [repeat] by applying it
    first to a type and then to an element of this type (and a number): *)

Example test_repeat1 :
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity.  Qed.

(** To use [repeat] to build other kinds of lists, we simply
    instantiate it with an appropriate type parameter: *)

Example test_repeat2 :
  repeat bool false 1 = cons bool false (nil bool).
Proof. reflexivity.  Qed.

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

    Consider the following two inductively defined types. *)

Module MumbleGrumble.

Inductive mumble : Type :=
  | a
  | b (x : mumble) (y : nat)
  | c.

Inductive grumble (X:Type) : Type :=
  | d (m : mumble)
  | e (x : X).

(** Which of the following are well-typed elements of [grumble X] for
    some type [X]?  (Add YES or NO to each line.)
      - [d (b a 5)]
      - [d mumble (b a 5)]
      - [d bool (b a 5)]
      - [e bool true]
      - [e mumble (b c 0)]
      - [e bool (b c 0)]
      - [c]  *)
(* FILL IN HERE *)
End MumbleGrumble.

(* Do not modify the following line: *)
Definition manual_grade_for_mumble_grumble : option (nat*string) := None.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Type Annotation Inference *)

(** Let's write the definition of [repeat] again, but this time we
    won't specify the types of any of the arguments.  Will Coq still
    accept it? *)

Fixpoint repeat' X x count : list X :=
  match count with
  | 0        => nil X
  | S count' => cons X x (repeat' X x count')
  end.

(** Indeed it will.  Let's see what type Coq has assigned to [repeat']: *)

Check repeat'.
(* ===> forall X : Type, X -> nat -> list X *)
Check repeat.
(* ===> forall X : Type, X -> nat -> list X *)

(** It has exactly the same type as [repeat].  Coq was able
    to use _type inference_ to deduce what the types of [X], [x], and
    [count] must be, based on how they are used.  For example, since
    [X] is used as an argument to [cons], it must be a [Type], since
    [cons] expects a [Type] as its first argument; matching [count]
    with [0] and [S] means it must be a [nat]; and so on.

    This powerful facility means we don't always have to write
    explicit type annotations everywhere, although explicit type
    annotations are still quite useful as documentation and sanity
    checks, so we will continue to use them most of the time.  You
    should try to find a balance in your own code between too many
    type annotations (which can clutter and distract) and too
    few (which forces readers to perform type inference in their heads
    in order to understand your code). *)

(* ----------------------------------------------------------------- *)
(** *** Type Argument Synthesis *)

(** To use a polymorphic function, we need to pass it one or
    more types in addition to its other arguments.  For example, the
    recursive call in the body of the [repeat] function above must
    pass along the type [X].  But since the second argument to
    [repeat] is an element of [X], it seems entirely obvious that the
    first argument can only be [X] -- why should we have to write it
    explicitly?

    Fortunately, Coq permits us to avoid this kind of redundancy.  In
    place of any type argument we can write a "hole" [_], which can be
    read as "Please try to figure out for yourself what belongs here."
    More precisely, when Coq encounters a [_], it will attempt to
    _unify_ all locally available information -- the type of the
    function being applied, the types of the other arguments, and the
    type expected by the context in which the application appears --
    to determine what concrete type should replace the [_].

    This may sound similar to type annotation inference -- indeed, the
    two procedures rely on the same underlying mechanisms.  Instead of
    simply omitting the types of some arguments to a function, like

      repeat' X x count : list X :=

    we can also replace the types with [_]

      repeat' (X : _) (x : _) (count : _) : list X :=

    to tell Coq to attempt to infer the missing information.

    Using holes, the [repeat] function can be written like this: *)

Fixpoint repeat'' X x count : list X :=
  match count with
  | 0        => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

(** In this instance, we don't save much by writing [_] instead of
    [X].  But in many cases the difference in both keystrokes and
    readability is nontrivial.  For example, suppose we want to write
    down a list containing the numbers [1], [2], and [3].  Instead of
    writing this... *)

Definition list123 :=
  cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

(** ...we can use holes to write this: *)

Definition list123' :=
  cons _ 1 (cons _ 2 (cons _ 3 (nil _))).
(*Nessa acima não declarando de forma clara qual o tipo, só que ele possuiu um qualquer*)

(* ----------------------------------------------------------------- *)
(** *** Implicit Arguments *)

(** We can go further and even avoid writing [_]'s in most cases by
    telling Coq _always_ to infer the type argument(s) of a given
    function.

    The [Arguments] directive specifies the name of the function (or
    constructor) and then lists its argument names, with curly braces
    around any arguments to be treated as implicit.  (If some
    arguments of a definition don't have a name, as is often the case
    for constructors, they can be marked with a wildcard pattern
    [_].) *)

(*Aqui repare no {X} sendo o tipo*)
Arguments nil {X}. (*Aqui só passo o tipo*)
Arguments cons {X} _ _. (*Tem cabeça e cauda da lista tbm*)
Arguments repeat {X} x count. (* o valor x é numero a ser repetido e count a qtd de vezes*)

(** Now, we don't have to supply type arguments at all: *)

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).

(** Alternatively, we can declare an argument to be implicit
    when defining the function itself, by surrounding it in curly
    braces '{}' instead of parens.  For example: *)
(*Sendo assim, não preciso declarar o tipo, ele inferi automaticamente nesses casos*)

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0        => nil
  | S count' => cons x (repeat''' x count')
  end.

(** (Note that we didn't even have to provide a type argument to the
    recursive call to [repeat''']; indeed, it would be invalid to
    provide one!)

    We will use the latter style whenever possible, but we will
    continue to use explicit [Argument] declarations for [Inductive]
    constructors.  The reason for this is that marking the parameter
    of an inductive type as implicit causes it to become implicit for
    the type itself, not just for its constructors.  For instance,
    consider the following alternative definition of the [list]
    type: *)

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

(** Because [X] is declared as implicit for the _entire_ inductive
    definition including [list'] itself, we now have to write just
    [list'] whether we are talking about lists of numbers or booleans
    or anything else, rather than [list' nat] or [list' bool] or
    whatever; this is a step too far. *)

(** Let's finish by re-implementing a few other standard list
    functions on our new polymorphic lists... *)

Fixpoint app {X : Type} (l1 l2 : list X)
             : (list X) :=
  match l1 with
  | nil      => l2
  | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil      => nil
  | cons h t => app (rev t) (cons h nil)
  end.

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

Example test_rev1 :
  rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. reflexivity.  Qed.

Example test_rev2:
  rev (cons true nil) = cons true nil.
Proof. reflexivity.  Qed.

Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity.  Qed.

(* ----------------------------------------------------------------- *)
(** *** Supplying Type Arguments Explicitly *)

(** One small problem with declaring arguments [Implicit] is
    that, occasionally, Coq does not have enough local information to
    determine a type argument; in such cases, we need to tell Coq that
    we want to give the argument explicitly just this time.  For
    example, suppose we write this: *)

Fail Definition mynil := nil.

(** (The [Fail] qualifier that appears before [Definition] can be
    used with _any_ command, and is used to ensure that that command
    indeed fails when executed. If the command does fail, Coq prints
    the corresponding error message, but continues processing the rest
    of the file.)

    Here, Coq gives us an error because it doesn't know what type
    argument to supply to [nil].  We can help it by providing an
    explicit type declaration (so that Coq has more information
    available when it gets to the "application" of [nil]): *)

Definition mynil : list nat := nil.

(** Alternatively, we can force the implicit arguments to be explicit by
   prefixing the function name with [@]. *)

(*Torna explíciti o tipo:*)
Check @nil.

Definition mynil' := @nil nat.

(** Using argument synthesis and implicit arguments, we can
    define convenient notation for lists, as before.  Since we have
    made the constructor type arguments implicit, Coq will know to
    automatically infer these when we use the notations. *)

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

(** Now lists can be written just the way we'd hope: *)

Definition list123''' := [1; 2; 3].

(* ----------------------------------------------------------------- *)
(** *** Exercises *)

(** **** Exercise: 2 stars, standard, optional (poly_exercises)

    Here are a few simple exercises, just like ones in the [Lists]
    chapter, for practice with polymorphism.  Complete the proofs below. *)

(*Obs: descobri que dá pra fazer direto induction l.
    Só daí a IH fica padrão com IHl, por exemplo.
    Assim como quando é uso do rewrite com ->, pode optar pode deixar sem nada, significa o mesmo*)

(*Fazer esses exercícios de fixação - não conta na tarefa*)

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
    intros X l. induction l as [ | h t IH]. (*ou induction l.*)
  - reflexivity.
  - simpl. rewrite -> IH. reflexivity.
 Qed.

(*Continuar a partir daqui para 03/08*)

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros A l m n. induction l as [ | h t IH]. (*Preciso do tipo A*)
  - reflexivity.
  - simpl. rewrite <- IH. reflexivity.
Qed.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros X l1 l2. induction l1 as [ | h t IH]. (*Preciso do tipo X*)
  - simpl. reflexivity.
  - simpl. rewrite -> IH. reflexivity.
Qed.

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros X l1 l2. induction l1 as [ | h t IH].
  - rewrite -> app_nil_r. simpl. reflexivity.
  - simpl. rewrite IH. rewrite <- app_assoc. reflexivity.
 Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros X l. induction l as [ | h t IH].
  - simpl. reflexivity.
  - simpl. rewrite rev_app_distr. rewrite -> IH. reflexivity.
Qed.

(* ================================================================= *)
(** ** Polymorphic Pairs *)

(** Following the same pattern, the type definition we gave in
    the last chapter for pairs of numbers can be generalized to
    _polymorphic pairs_, often called _products_: *)

Inductive prod (X Y : Type) : Type :=
| pair (x : X) (y : Y).

Check prod. (*Tem tipo A, tipo B e constroi um tipo novo*)

(*Check (prod nat bool).*) (*É um tipo nat com bool, que é do tipo set daí (dado criado)*)

Check pair.

(*Check pair nat bool 2 true.*)
(*Check pair nat nat 2 2.*)

(*Os tipos x e y são implícitos e devem ser inferidos*)
Arguments pair {X} {Y} _ _.

(*Check pair 2 true.*) (*Agora posso apenas passar assim que ele pega o tipo*)

(** As with lists, we make the type arguments implicit and define the
    familiar concrete notation. *)

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

(** We can also use the [Notation] mechanism to define the standard
    notation for product _types_: *)

Notation "X * Y" := (prod X Y) : type_scope.

(** (The annotation [: type_scope] tells Coq that this abbreviation
    should only be used when parsing types.  This avoids a clash with
    the multiplication symbol.) *)

(** It is easy at first to get [(x,y)] and [X*Y] confused.
    Remember that [(x,y)] is a _value_ built from two other values,
    while [X*Y] is a _type_ built from two other types.  If [x] has
    type [X] and [y] has type [Y], then [(x,y)] has type [X*Y]. *)

(** The first and second projection functions now look pretty
    much as they would in any functional programming language. *)

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

(** The following function takes two lists and combines them
    into a list of pairs.  In other functional languages, it is often
    called [zip]; we call it [combine] for consistency with Coq's
    standard library. *)

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

(** **** Exercise: 1 star, standard, optional (combine_checks)

    Try answering the following questions on paper and
    checking your answers in Coq:
    - What is the type of [combine] (i.e., what does [Check
      @combine] print?)
    - What does

        Compute (combine [1;2] [false;false;true;true]).

      print?

    [] *)

(** **** Exercise: 2 stars, standard, recommended (split)

    The function [split] is the right inverse of [combine]: it takes a
    list of pairs and returns a pair of lists.  In many functional
    languages, it is called [unzip].

    Fill in the definition of [split] below.  Make sure it passes the
    given unit test. *)

Definition app_list_pair {X Y : Type} (listp1 :
  (list X) * (list Y)) (listp2 : (list X) * (list Y)) : (list X) * (list Y) :=
  (app (fst listp1) (fst listp2), app (snd listp1) (snd listp2)).

(*Mais ou menso feito, tá ok *)
Fixpoint split {X Y : Type} (l : list (X*Y)) : (list X) * (list Y) :=
  match l with
  | [] => ([], [])
  | (h1, h2) :: t => app_list_pair ([h1], [h2]) (split t)
  end.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Polymorphic Options *)

(** One last polymorphic type for now: _polymorphic options_,
    which generalize [natoption] from the previous chapter.  (We put
    the definition inside a module because the standard library
    already defines [option] and it's this one that we want to use
    below.) *)

Module OptionPlayground.

(*Mesmo que o map do haskell, seugndo prof - ? *)
Inductive option (X:Type) : Type :=
  | Some (x : X)
  | None.

Arguments Some {X} _.
Arguments None {X}.

End OptionPlayground.

(** We can now rewrite the [nth_error] function so that it works
    with any type of lists. *)

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | [] => None
  | a :: l' => if n =? O then Some a else nth_error l' (pred n)
  end.
(*Importei o do eqb =? etc para uso aqui e etc*)

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [true] 2 = None.
Proof. reflexivity. Qed.

(** **** Exercise: 1 star, standard, optional (hd_error_poly)

    Complete the definition of a polymorphic version of the
    [hd_error] function from the last chapter. Be sure that it
    passes the unit tests below. *)

Definition hd_error {X : Type} (l : list X) : option X
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

(** Once again, to force the implicit arguments to be explicit,
    we can use [@] before the name of the function. *)

Check @hd_error.

Example test_hd_error1 : hd_error [1;2] = Some 1.
 (* FILL IN HERE *) Admitted.
Example test_hd_error2 : hd_error  [[1];[2]]  = Some [1].
 (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Functions as Data *)

(** Like many other modern programming languages -- including
    all functional languages (ML, Haskell, Scheme, Scala, Clojure,
    etc.) -- Coq treats functions as first-class citizens, allowing
    them to be passed as arguments to other functions, returned as
    results, stored in data structures, etc. *)

(* ================================================================= *)
(** ** Higher-Order Functions *)

(** Functions that manipulate other functions are often called
    _higher-order_ functions.  Here's a simple one: *)

Definition doit3times {X:Type} (f:X->X) (n:X) : X :=
  f (f (f n)).

(** The argument [f] here is itself a function (from [X] to
    [X]); the body of [doit3times] applies [f] three times to some
    value [n]. *)

Check @doit3times.
(* ===> doit3times : forall X : Type, (X -> X) -> X -> X *)

Example test_doit3times: doit3times minustwo 9 = 3.
Proof. reflexivity.  Qed.

Example test_doit3times': doit3times negb true = false.
Proof. reflexivity.  Qed.

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

(** Here is a more useful higher-order function, taking a list
    of [X]s and a _predicate_ on [X] (a function from [X] to [bool])
    and "filtering" the list, returning a new list containing just
    those elements for which the predicate returns [true]. *)

(*Essa foi explicada em aula, no dia 03/08*)
Fixpoint filter {X:Type} (test: X->bool) (l:list X)
                : (list X) :=
  match l with
  | []     => []
  | h :: t => if test h then h :: (filter test t)
                        else       filter test t
  end.

(** For example, if we apply [filter] to the predicate [evenb]
    and a list of numbers [l], it returns a list containing just the
    even members of [l]. *)
(*import para fazer funfar o test_filter1*)
Fixpoint evenb (n:nat) : bool :=
  match n with
  | O        => true
  | S O      => false
  | S (S n') => evenb n'
  end.

Example test_filter1: filter evenb [1;2;3;4] = [2;4].
Proof. reflexivity.  Qed.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  (length l) =? 1.

Example test_filter2:
    filter length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity.  Qed.

Definition oddb (n:nat) : bool   :=   negb (evenb n). (*para aux na countodd abaixo*)

(** We can use [filter] to give a concise version of the
    [countoddmembers] function from the [Lists] chapter. *)

Definition countoddmembers' (l:list nat) : nat :=
  length (filter oddb l).

Example test_countoddmembers'1:   countoddmembers' [1;0;3;1;4;5] = 4.
Proof. reflexivity.  Qed.
Example test_countoddmembers'2:   countoddmembers' [0;2;4] = 0.
Proof. reflexivity.  Qed.
Example test_countoddmembers'3:   countoddmembers' nil = 0.
Proof. reflexivity.  Qed.

(* ================================================================= *)
(** ** Anonymous Functions *)

(** It is arguably a little sad, in the example just above, to
    be forced to define the function [length_is_1] and give it a name
    just to be able to pass it as an argument to [filter], since we
    will probably never use it again.  Moreover, this is not an
    isolated example: when using higher-order functions, we often want
    to pass as arguments "one-off" functions that we will never use
    again; having to give each of these functions a name would be
    tedious.

    Fortunately, there is a better way.  We can construct a function
    "on the fly" without declaring it at the top level or giving it a
    name. *)

Example test_anon_fun':
  doit3times (fun n => n * n) 2 = 256.
Proof. reflexivity.  Qed.

(** The expression [(fun n => n * n)] can be read as "the function
    that, given a number [n], yields [n * n]." *)

(** Here is the [filter] example, rewritten to use an anonymous
    function. *)

Example test_filter2':
    filter (fun l => (length l) =? 1)
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity.  Qed.

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

    Use [filter] (instead of [Fixpoint]) to write a Coq function
    [filter_even_gt7] that takes a list of natural numbers as input
    and returns a list of just those that are even and greater than
    7. *)

Definition filter_even_gt7 (l : list nat) : list nat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
 (* FILL IN HERE *) Admitted.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
 (* FILL IN HERE *) Admitted.
(** [] *)

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

    Use [filter] to write a Coq function [partition]:

      partition : forall X : Type,
                  (X -> bool) -> list X -> list X * list X

   Given a set [X], a test function of type [X -> bool] and a [list
   X], [partition] should return a pair of lists.  The first member of
   the pair is the sublist of the original list containing the
   elements that satisfy the test, and the second is the sublist
   containing those that fail the test.  The order of elements in the
   two sublists should be the same as their order in the original
   list. *)

Definition partition {X : Type}
                     (test : X -> bool)
                     (l : list X)
                   : list X * list X
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
(* FILL IN HERE *) Admitted.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Map *)
(*Aula de 03/08!!!:*)

(** Another handy higher-order function is called [map]. *)

Fixpoint map {X Y: Type} (f:X->Y) (l:list X) : (list Y) :=
  match l with
  | []     => []
  | h :: t => (f h) :: (map f t)
  end.

(** It takes a function [f] and a list [ l = [n1, n2, n3, ...] ]
    and returns the list [ [f n1, f n2, f n3,...] ], where [f] has
    been applied to each element of [l] in turn.  For example: *)

Compute (map (fun x => plus 3 x) [2;0;2]). (*ex aplicando função x = 3 + x*)

Example test_map1: map (fun x => plus 3 x) [2;0;2] = [5;3;5].
Proof. reflexivity.  Qed.

(** The element types of the input and output lists need not be
    the same, since [map] takes _two_ type arguments, [X] and [Y]; it
    can thus be applied to a list of numbers and a function from
    numbers to booleans to yield a list of booleans: *)

Example test_map2:
  map oddb [2;1;2;5] = [false;true;false;true].
Proof. reflexivity.  Qed.

(** It can even be applied to a list of numbers and
    a function from numbers to _lists_ of booleans to
    yield a _list of lists_ of booleans: *)

Example test_map3:
    map (fun n => [evenb n;oddb n]) [2;1;2;5]
  = [[true;false];[false;true];[true;false];[false;true]].
Proof. reflexivity.  Qed.

(* ----------------------------------------------------------------- *)
(** *** Exercises *)

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

    Show that [map] and [rev] commute.  You may need to define an
    auxiliary lemma. *)

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, recommended (flat_map)

    The function [map] maps a [list X] to a [list Y] using a function
    of type [X -> Y].  We can define a similar function, [flat_map],
    which maps a [list X] to a [list Y] using a function [f] of type
    [X -> list Y].  Your definition should work by 'flattening' the
    results of [f], like so:

        flat_map (fun n => [n;n+1;n+2]) [1;5;10]
      = [1; 2; 3; 5; 6; 7; 10; 11; 12].
*)

Fixpoint flat_map {X Y: Type} (f: X -> list Y) (l: list X)
                   : (list Y)
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
 (* FILL IN HERE *) Admitted.
(** [] *)

(** Lists are not the only inductive type for which [map] makes sense.
    Here is a [map] for the [option] type: *)

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X)
                      : option Y :=
  match xo with
    | None => None
    | Some x => Some (f x)
  end.

(** **** Exercise: 2 stars, standard, optional (implicit_args)

    The definitions and uses of [filter] and [map] use implicit
    arguments in many places.  Replace the curly braces around the
    implicit arguments with parentheses, and then fill in explicit
    type parameters where necessary and use Coq to check that you've
    done so correctly.  (This exercise is not to be turned in; it is
    probably easiest to do it on a _copy_ of this file that you can
    throw away afterwards.)

    [] *)

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

(** An even more powerful higher-order function is called
    [fold].  This function is the inspiration for the "[reduce]"
    operation that lies at the heart of Google's map/reduce
    distributed programming framework. *)

(*mesmo que fold_r do haskell - ideia da dobra*)
(*ex 1 + (2 + (3 + (4 + 0)))  *)
Fixpoint fold {X Y: Type} (f: X->Y->Y) (l: list X) (b: Y)
                         : Y :=
  match l with
  | nil => b
  | h :: t => f h (fold f t b)
  end.

(** Intuitively, the behavior of the [fold] operation is to
    insert a given binary operator [f] between every pair of elements
    in a given list.  For example, [ fold plus [1;2;3;4] ] intuitively
    means [1+2+3+4].  To make this precise, we also need a "starting
    element" that serves as the initial second input to [f].  So, for
    example,

       fold plus [1;2;3;4] 0

    yields

       1 + (2 + (3 + (4 + 0))).

    Some more examples: *)

Check (fold andb).
(* ===> fold andb : list bool -> bool -> bool *)

Example fold_example1 :
  fold mult [1;2;3;4] 1 = 24.
Proof. reflexivity. Qed.

Example fold_example2 :
  fold andb [true;true;false;true] true = false.
Proof. reflexivity. Qed.

Example fold_example3 :
  fold app  [[1];[];[2;3];[4]] [] = [1;2;3;4].
Proof. reflexivity. Qed.

(** **** Exercise: 1 star, advanced (fold_types_different)

    Observe that the type of [fold] is parameterized by _two_ type
    variables, [X] and [Y], and the parameter [f] is a binary operator
    that takes an [X] and a [Y] and returns a [Y].  Can you think of a
    situation where it would be useful for [X] and [Y] to be
    different? *)

(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_fold_types_different : option (nat*string) := None.
(** [] *)

(* ================================================================= *)
(** ** Functions That Construct Functions *)

(** Most of the higher-order functions we have talked about so
    far take functions as arguments.  Let's look at some examples that
    involve _returning_ functions as the results of other functions.
    To begin, here is a function that takes a value [x] (drawn from
    some type [X]) and returns a function from [nat] to [X] that
    yields [x] whenever it is called, ignoring its [nat] argument. *)

Definition constfun {X: Type} (x: X) : nat->X :=
  fun (k:nat) => x.

Definition ftrue := constfun true.

Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.

Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

(** In fact, the multiple-argument functions we have already
    seen are also examples of passing functions as data.  To see why,
    recall the type of [plus]. *)

Check plus.
(* ==> nat -> nat -> nat *)

(** Each [->] in this expression is actually a _binary_ operator
    on types.  This operator is _right-associative_, so the type of
    [plus] is really a shorthand for [nat -> (nat -> nat)] -- i.e., it
    can be read as saying that "[plus] is a one-argument function that
    takes a [nat] and returns a one-argument function that takes
    another [nat] and returns a [nat]."  In the examples above, we
    have always applied [plus] to both of its arguments at once, but
    if we like we can supply just the first.  This is called _partial
    application_. *)

Definition plus3 := plus 3.
Check plus3.

Example test_plus3 :    plus3 4 = 7.
Proof. reflexivity.  Qed.
Example test_plus3' :   doit3times plus3 0 = 9.
Proof. reflexivity.  Qed.
Example test_plus3'' :  doit3times (plus 3) 0 = 9.
Proof. reflexivity.  Qed.

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

Module Exercises.

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

    Many common functions on lists can be implemented in terms of
    [fold].  For example, here is an alternative definition of [length]: *)

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.

Example test_fold_length1 : fold_length [4;7;0] = 3.
Proof. reflexivity. Qed.

(** Prove the correctness of [fold_length].  (Hint: It may help to
    know that [reflexivity] simplifies expressions a bit more
    aggressively than [simpl] does -- i.e., you may find yourself in a
    situation where [simpl] does nothing but [reflexivity] solves the
    goal.) *)

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

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

    We can also define [map] in terms of [fold].  Finish [fold_map]
    below. *)

(*Definition fold_map {X Y: Type} (f: X -> Y) (l: list X) : list Y
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.*)

(** Write down a theorem [fold_map_correct] in Coq stating that
   [fold_map] is correct, and prove it.  (Hint: again, remember that
   [reflexivity] simplifies expressions a bit more aggressively than
   [simpl].) *)

(* FILL IN HERE *)

(*###################### INÍCIO LISTA 5 #################*)

(*Resolução da lista 5 de MFO - Polimorfismo*)
(*Todas as questões resolvidas que precisem de auxiliares são importadas manualmente*)
(*Se der, depois passar para a ListaPoly.v.*)

(*Lista 5 - questão 1:*) (*Isso?*)
(*Criar um map através do fold, sem recursão. Aqui usando fun (de função anonima) e tal*)
Definition fold_map {X Y: Type} (f: X -> Y) (l: list X) : list Y :=
  fold (fun x lista => f x :: lista) l nil.

Compute fold_map (fun x => false) [0;1;2].
(*Entra uma lista numérica x, com o mapeamento seus elementos saem bool false em uma lista Y.*)

Example test_fold_map : fold_map (mult 2) [1; 2; 3] = [2; 4; 6].
Proof. reflexivity. Qed.

(*Lista 5 - questão 2*)
Theorem fold_map_correct : forall X Y (f: X -> Y) (l: list X),
  fold_map f l = map f l.
Proof.
  intros X Y f l. induction l as [ | h t IH].
  - simpl. reflexivity.
  - simpl. rewrite <- IH. reflexivity.
  Qed.

(*As três abaixos são com uso do Tatics.v, não sei se precisa importar algo sla*)
(*Ou tentar resolver naquela ListaPoly.v*)
(*Lista 5 - questão 3*) (*Não entendi como fazer, usando plus_n_Sm ou double do induction talvez*)
Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  intros n m IH. (*?*)
  Admitted.

(*LIsta 5 - questão 4*) (*??*)
Theorem combine_split' : forall X Y (l : list (X * Y)) l1 l2,
  split l = (l1, l2) ->
  combine l1 l2 = l.
Proof.
  intros X Y l. induction l as [|h t IH1].
  - intros l1 l2 H. simpl in H. injection H as H1 H2.
    Abort.

(*LIsta 5 - questão 5*) (*??*)
Theorem split_combine' : forall X Y (l1 : list X) (l2 : list Y) (l : list (X*Y)),
  length l1 = length l2 -> combine l1 l2 = l -> split l = (l1, l2).
Proof.
  intros X Y l1 l2 l. generalize dependent l1. generalize dependent l2.
  induction l as [| h t IHl].
  - intros l1 l2 H1 H2. destruct l1 as [| h1 t1].
    Abort.
(*###################### FINAL LISTA 5 #################*)

(* Do not modify the following line: *)
Definition manual_grade_for_fold_map : option (nat*string) := None.
(** [] *)

(** **** Exercise: 2 stars, advanced (currying)

    In Coq, a function [f : A -> B -> C] really has the type [A
    -> (B -> C)].  That is, if you give [f] a value of type [A], it
    will give you function [f' : B -> C].  If you then give [f'] a
    value of type [B], it will return a value of type [C].  This
    allows for partial application, as in [plus3].  Processing a list
    of arguments with functions that return functions is called
    _currying_, in honor of the logician Haskell Curry.

    Conversely, we can reinterpret the type [A -> B -> C] as [(A *
    B) -> C].  This is called _uncurrying_.  With an uncurried binary
    function, both arguments must be given at once as a pair; there is
    no partial application. *)

(** We can define currying as follows: *)

Definition prod_curry {X Y Z : Type}
  (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

(** As an exercise, define its inverse, [prod_uncurry].  Then prove
    the theorems below to show that the two are inverses. *)

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

(** As a (trivial) example of the usefulness of currying, we can use it
    to shorten one of the examples that we saw above: *)

Example test_map1': map (plus 3) [2;0;2] = [5;3;5].
Proof. reflexivity.  Qed.

(** Thought exercise: before running the following commands, can you
    calculate the types of [prod_curry] and [prod_uncurry]? *)

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type)
                        (f : X -> Y -> Z)
                        x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem curry_uncurry : forall (X Y Z : Type)
                        (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, advanced (nth_error_informal)

    Recall the definition of the [nth_error] function:

   Fixpoint nth_error {X : Type} (l : list X) (n : nat) : option X :=
     match l with
     | [] => None
     | a :: l' => if n =? O then Some a else nth_error l' (pred n)
     end.

   Write an informal proof of the following theorem:

   forall X n l, length l = n -> @nth_error X l n = None
*)
(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_informal_proof : option (nat*string) := None.
(** [] *)

(** The following exercises explore an alternative way of defining
    natural numbers, using the so-called _Church numerals_, named
    after mathematician Alonzo Church.  We can represent a natural
    number [n] as a function that takes a function [f] as a parameter
    and returns [f] iterated [n] times. *)

Module Church.
Definition cnat := forall X : Type, (X -> X) -> X -> X.

(** Let's see how to write some numbers with this notation. Iterating
    a function once should be the same as just applying it.  Thus: *)

Definition one : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f x.

(** Similarly, [two] should apply [f] twice to its argument: *)

Definition two : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f x).

(** Defining [zero] is somewhat trickier: how can we "apply a function
    zero times"?  The answer is actually simple: just return the
    argument untouched. *)

Definition zero : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => x.

(** More generally, a number [n] can be written as [fun X f x => f (f
    ... (f x) ...)], with [n] occurrences of [f].  Notice in
    particular how the [doit3times] function we've defined previously
    is actually just the Church representation of [3]. *)

Definition three : cnat := @doit3times.

(** Complete the definitions of the following functions. Make sure
    that the corresponding unit tests pass by proving them with
    [reflexivity]. *)

(** **** Exercise: 1 star, advanced (church_succ)  *)

(** Successor of a natural number: given a Church numeral [n],
    the successor [succ n] is a function that iterates its
    argument once more than [n]. *)
Definition succ (n : cnat) : cnat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example succ_1 : succ zero = one.
Proof. (* FILL IN HERE *) Admitted.

Example succ_2 : succ one = two.
Proof. (* FILL IN HERE *) Admitted.

Example succ_3 : succ two = three.
Proof. (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 1 star, advanced (church_plus)  *)

(** Addition of two natural numbers: *)
Definition plus (n m : cnat) : cnat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example plus_1 : plus zero one = one.
Proof. (* FILL IN HERE *) Admitted.

Example plus_2 : plus two three = plus three two.
Proof. (* FILL IN HERE *) Admitted.

Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
Proof. (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 2 stars, advanced (church_mult)  *)

(** Multiplication: *)
Definition mult (n m : cnat) : cnat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example mult_1 : mult one one = one.
Proof. (* FILL IN HERE *) Admitted.

Example mult_2 : mult zero (plus three three) = zero.
Proof. (* FILL IN HERE *) Admitted.

Example mult_3 : mult two three = plus three three.
Proof. (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 2 stars, advanced (church_exp)  *)

(** Exponentiation: *)

(** (_Hint_: Polymorphism plays a crucial role here.  However,
    choosing the right type to iterate over can be tricky.  If you hit
    a "Universe inconsistency" error, try iterating over a different
    type.  Iterating over [cnat] itself is usually problematic.) *)

Definition exp (n m : cnat) : cnat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example exp_1 : exp two two = plus two two.
Proof. (* FILL IN HERE *) Admitted.

Example exp_2 : exp three zero = one.
Proof. (* FILL IN HERE *) Admitted.

Example exp_3 : exp three two = plus (mult two (mult two two)) one.
Proof. (* FILL IN HERE *) Admitted.

(** [] *)

End Church.

End Exercises.

(* Wed Jan 9 12:02:44 EST 2019 *)


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

Local Open Scope nattrans_scope.

(** The opposite of a natural transformation N : F -> F' is a nattrans N^op : F'^op -> F^op. It has the same arrow family as the original natural transformation. *)
Section Opposite_NatTrans.
  Context {C D : Category} {F F' : (C –≻ D)%functor} (N : (F –≻ F')%nattrans).

  Program Definition Opposite_NatTrans : F'^op –≻ F^op :=
    {|
      Trans := Trans N;
      Trans_com := fun c c' h => (Trans_com_sym N h);
      Trans_com_sym := fun c c' h => (Trans_com N h)
    |}.

End Opposite_NatTrans.

Notation "N '^op'" := (Opposite_NatTrans N) : nattrans_scope.

(** Composition of opposite natural transformations is just the same as the opposite natural transformation of the composition. *)
Section Compose_NOP.
  Context {C D : Category} {F F' F'' : (C –≻ D)%functor} (N : F –≻ F') (N' : F' –≻ F'').

  Theorem NatTrans_compose_Op : ((N' ∘ N)^op = N^op ∘ (N'^op))%nattrans.
  Proof.
    apply NatTrans_eq_simplify.
    trivial.
  Qed.

End Compose_NOP.

(** Opposite of NatTrans_id is just NatTrans_id of the opposite functor *)
Section NatTrans_id_Op.
  Context {C D : Category} (F : (C –≻ D)%functor).

  Theorem NatTrans_id_Op : ((NatTrans_id F)^op)%nattrans = NatTrans_id (F^op)%functor.
  Proof.
    apply NatTrans_eq_simplify.
    trivial.
  Qed.

End NatTrans_id_Op.

(** Horizontal composition of natural transformations:

Let C, D and E be categories, F: C -> D G : C -> D, F' : D -> E and G' : D -> E be functors and N : F -> G and N' : F' -> G' be natural transformations. Then, the horizontal composition of N and N', denoted by N ∘_h N' : F' ∘ F -> G' ∘ G is defined as follows:

 *)
Program Definition NatTrans_hor_comp {C D E : Category} {F G : (C –≻ D)%functor}
        {F' G' : (D –≻ E)%functor} (tr : F –≻ G) (tr' : F' –≻ G')
  : (F' ∘ F) –≻ (G' ∘ G) :=
{|
  Trans := fun c : Obj => ((G' _a (Trans tr c)) ∘ (Trans tr' (F _o c)))%morphism
|}.

Next Obligation. (* Trans_com*)
Proof.
  rewrite assoc.
  rewrite Trans_com.
  rewrite assoc_sym.
  rewrite <- F_compose.
  rewrite Trans_com.
  rewrite F_compose.
  auto.
Qed.

Next Obligation. (* Trans_com*)
Proof.
  symmetry.
  apply NatTrans_hor_comp_obligation_1.
Qed.

(**
Graphically:
#

    C      C             C              C
    |  N   |             |              |
  F | ===> | G           |              |
    |      |             |              |
    ∨      ∨             |   N' ∘_h N   |
    D      D        F'∘F | ===========> |G'∘G
    |  N'  |             |              |
 F' | ===> | G'          |              |
    |      |             |              |
    ∨      ∨             ∨              ∨
    E      E             E              E

#
*)

Notation "N ∘_h N'" := (NatTrans_hor_comp N' N) : nattrans_scope.

(** Horizontal composition of NatTrans_ids is just the NatTrans_id of the composition of underlying functors. *)
Section Hor_Compose_ids.
  Context {C D E : Category} (F : (C –≻ D)%functor) (G : (D –≻ E)%functor).

  Theorem NatTrans_hor_comp_ids : ((NatTrans_id G) ∘_h (NatTrans_id F))%nattrans = NatTrans_id  (G ∘ F).
  Proof.
    apply NatTrans_eq_simplify.
    cbn.
    extensionality c.
    rewrite F_id; simpl_ids; trivial.
  Qed.

End Hor_Compose_ids.

(** Horizontal composition of opposite of two natural transformations is just the opposite of the horizontal composition of those two natural transformations. *)
Section Hor_Compose_NOP.
  Context {C D E : Category} {F G : (C –≻ D)%functor} {F' G' : (D –≻ E)%functor}
          (N : F –≻ G) (N' : F' –≻ G').

  Theorem NatTrans_hor_comp_Op : ((N' ∘_h N)^op = N'^op ∘_h N^op)%nattrans.
  Proof.
    apply NatTrans_eq_simplify.
    cbn.
    extensionality c.
    rewrite Trans_com.
    trivial.
  Qed.

End Hor_Compose_NOP.

Section NatTransCompID.
  Context {C D : Category} (F : (C –≻ D)%functor).

  (** Natural transformation from a functor to itself composed with id on the right. *)
  Program Definition NatTrans_to_compose_id : F –≻ ((Functor_id D) ∘ F) :=
    {|
      Trans := fun c => id
    |}.

  (** Natural transformation to a functor from itself composed with id on the right. *)
  Program Definition NatTrans_from_compose_id : ((Functor_id _) ∘ F) –≻ F :=
    {|
      Trans := fun c => id
    |}.

  (** Natural transformation from a functor to itself composed with id on the left. *)
  Program Definition NatTrans_to_id_compose : F –≻ (F ∘ (Functor_id _)) :=
    {|
      Trans := fun c => id
    |}.

  (** Natural transformation to a functor from itself composed with id on the left. *)
  Program Definition NatTrans_from_id_compose : (F ∘ (Functor_id _)) –≻ F :=
    {|
      Trans := fun c => id
    |}.

End NatTransCompID.

Section NatTransAssoc.
  Context {C1 C2 C3 C4 : Category}
          (F : (C1 –≻ C2)%functor)
          (G : (C2 –≻ C3)%functor)
          (H : (C3 –≻ C4)%functor)
  .

  (** Natural transformation corresponding to associativity of functor composition *)
  Program Definition NatTrans_Functor_assoc
    : ((H ∘ G) ∘ F) –≻ (H ∘ (G ∘ F)) :=
    {|
      Trans := fun c => id
    |}.

  (** Natural transformation corresponding to the symmetric form of associativity of functor composition *)
  Program Definition NatTrans_Functor_assoc_sym
    : (H ∘ (G ∘ F)) –≻ ((H ∘ G) ∘ F) :=
    {|
      Trans := fun c => id
    |}.

End NatTransAssoc.

(**
The following theorem states that the two natural transformations of the diagram in the middle are equal.
#

    F                       G ∘ F                      G
 C —————––>D   D —————————–—————————————————–—–—–> E   D —–————–> E
     ||           ||                           ||          ||
     ||N1         ||                           ||          ||N2
     ||           ||                           ||          ||
     \/           ||                           ||          \/
     F'           ||                           ||          G'
 C ————–—–>D      ||(N4 ∘ N2) ∘_h (N3 ∘ N1)    ||      D ———–——–> E
     ||           ||                           ||          ||
     || N3        ||                           ||          ||N4
     ||           ||  (N4 ∘_h N3) ∘ (N2 ∘_h N1)||          ||
     \/           ||                           ||          \/
     F''          \/                           \/          G''
 C ————–—–> D  D ——–—————————————————————————–——–> E   D————–——–> E
                            G'' ∘ F''

#
*)
Section NatTrans_comp_hor_comp.
  Context {C D E  : Category}
          {F F' F'' : (C –≻ D)%functor}
          {G G' G'' : (D –≻ E)%functor}
          (N1 : F –≻ F')
          (N2 : G –≻ G')
          (N3 : F' –≻ F'')
          (N4 : G' –≻ G'')
  .

  Theorem NatTrans_comp_hor_comp : ((N4 ∘_h N3) ∘ (N2 ∘_h N1) = (N4 ∘ N2) ∘_h (N3 ∘ N1))%nattrans.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality c.
    cbn.
    rewrite F_compose.
    repeat rewrite assoc.
    match goal with
      [|- (?A ∘ ?B = ?A ∘ ?C)%morphism] =>
      let H := fresh in
      cut (B = C); [intros H; rewrite H; trivial|]
    end.
    repeat rewrite assoc_sym.
    match goal with
      [|- (?A ∘ ?B = ?C ∘ ?B)%morphism] =>
      let H := fresh in
      cut (A = C); [intros H; rewrite H; trivial|]
    end.
    apply Trans_com.
  Qed.

End NatTrans_comp_hor_comp.

(*
(**
Given I : C ≃ D for categories C and D and F : D -> E, there is a natural transformation
from F ∘ (I ∘ I⁻¹) to F and back.
*)
Section IsoCat_NatTrans.
  Context {C D : Category} (I : (C ≃≃ D ::> Cat)%isomorphism) {E : Category} (F : (D –≻ E)%functor).

  Local Obligation Tactic := idtac.

  Program Definition IsoCat_NatTrans :
    (F ∘ ((iso_morphism I) ∘ (I⁻¹)%morphism)) –≻ F
    :=
      {|
        Trans :=
          fun c =>
            match eq_sym (f_equal (fun x => (x _o)%object c) (right_inverse I)) in _ = y return
                  ((F _o y) –≻ (F _o c))%object%morphism
            with
              eq_refl => id
            end
      |}
  .

  Next Obligation.
  Proof.
    intros c c' h; cbn.
    match goal with
      [|- (match ?e with _ => _ end ∘ ?A)%morphism = (?B ∘ match ?e' with _ => _ end)%morphism] =>
      generalize e; generalize e';
      set (U := A); set (V := B)
    end.
    intros H H'.
    cut (JMeq U V); [intros HUV|].
    {
      apply JMeq_eq.
      destruct H.
      set (z' := ((iso_morphism I) _o ((inverse_morphism I) _o c'))%object) in *.
      clearbody U.
      clearbody z'.
      destruct H'.
      auto.
    }
    {
      unfold U, V; clear.
      match goal with
        [|- JMeq (F @_a ?A ?B ?C)%morphism (F _a ?D)%morphism] =>
        set (V := C);
        set (M := A) in *;
        set (N := B) in *;
        set (U := D)
      end.
      cut (M = c); [intros Hc|].
      {
        cut (N = c'); [intros Hc'|].
        {
          cut (JMeq V U); [intros HVU|].
          {
            clearbody U V M N.
            destruct Hc.
            destruct Hc'.
            apply JMeq_eq in HVU.
            destruct HVU.
            trivial.
          }
          {
            unfold U, V, M, N; clear.
            change ((iso_morphism I) _o ((I⁻¹)%morphism _o c))%object
            with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c)%object.
            change ((iso_morphism I) _o ((I⁻¹)%morphism _o c'))%object
            with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c')%object.
            change ((iso_morphism I) _a (I⁻¹ _a h))%morphism with (((iso_morphism I) ∘ I⁻¹) _a h)%morphism.
            cbn_rewrite (right_inverse I).
            trivial.
          }
        }
        {
          unfold N; clear.
          change ((iso_morphism I) _o ((I⁻¹)%morphism _o c'))%object
          with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c')%object.
          cbn_rewrite (right_inverse I); trivial.
        }
      }
      {
        unfold M; clear.
        change ((iso_morphism I) _o ((I⁻¹)%morphism _o c))%object
        with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c)%object.
        cbn_rewrite (right_inverse I); trivial.
      }
    }
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply IsoCat_NatTrans_obligation_1.
  Qed.

  Program Definition IsoCat_NatTrans_back :
    F –≻ (F ∘ ((iso_morphism I) ∘ (I⁻¹)%morphism))
    :=
      {|
        Trans :=
          fun c =>
            match eq_sym (f_equal (fun x => (x _o)%object c) (right_inverse I)) in _ = y return
                  ((F _o c) –≻ (F _o y))%object%morphism
            with
              eq_refl => id
            end
      |}
  .

  Next Obligation.
  Proof.
    intros c c' h; cbn.
    match goal with
      [|- (match ?e with _ => _ end ∘ ?A)%morphism = (?B ∘ match ?e' with _ => _ end)%morphism] =>
      generalize e; generalize e';
      set (U := A); set (V := B)
    end.
    intros H H'.
    cut (JMeq U V); [intros HUV|].
    {
      apply JMeq_eq.
      destruct H'.
      set (z := ((iso_morphism I) _o ((inverse_morphism I) _o c))%object) in *.
      clearbody V.
      clearbody z.
      destruct H.
      auto.
    }
    {
      unfold U, V; clear.
      match goal with
        [|- JMeq (F _a ?D)%morphism (F @_a ?A ?B ?C)%morphism] =>
        set (V := C);
        set (M := A) in *;
        set (N := B) in *;
        set (U := D)
      end.
      cut (M = c); [intros Hc|].
      {
        cut (N = c'); [intros Hc'|].
        {
          cut (JMeq U V); [intros HUV|].
          {
            clearbody U V M N.
            destruct Hc.
            destruct Hc'.
            apply JMeq_eq in HUV.
            destruct HUV.
            trivial.
          }
          {
            unfold U, V, M, N; clear.
            change ((iso_morphism I) _o ((I⁻¹)%morphism _o c))%object
            with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c)%object.
            change ((iso_morphism I) _o ((I⁻¹)%morphism _o c'))%object
            with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c')%object.
            change ((iso_morphism I) _a (I⁻¹ _a h))%morphism with (((iso_morphism I) ∘ I⁻¹) _a h)%morphism.
            cbn_rewrite (right_inverse I).
            trivial.
          }
        }
        {
          unfold N; clear.
          change ((iso_morphism I) _o ((I⁻¹)%morphism _o c'))%object
          with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c')%object.
          cbn_rewrite (right_inverse I); trivial.
        }
      }
      {
        unfold M; clear.
        change ((iso_morphism I) _o ((I⁻¹)%morphism _o c))%object
        with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c)%object.
        cbn_rewrite (right_inverse I); trivial.
      }
    }
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply IsoCat_NatTrans_back_obligation_1.
  Qed.

End IsoCat_NatTrans.
*)


(*
  Some exercises come from Software Foundations Book1 CH1.
  Author : Brethland.
*)

Lemma andb_true_elim2: forall b c : bool, andb b c = true -> c = true.
Proof.
intros [].
- intros [].
  + intros H. rewrite <- H. reflexivity.
  + intros H. rewrite <- H. reflexivity.
- intros [].
  + intros H. rewrite <- H. reflexivity.
  + intros H. rewrite <- H. reflexivity.
Qed.

Fixpoint beq_n (n m : nat) : bool :=
  match n,m with
  | O, O => true
  | O , S m' => false
  | S n' , O => false
  | S n' , S m' => beq_n n' m'
  end.

Lemma zero_nbeq_plus_1: forall n : nat, beq_n O (1 + n) = false.
Proof.
intros [|n'].
- reflexivity.
- reflexivity.
Qed.

Fixpoint nat_divmod(n m quo rem: nat) : nat * nat :=
  match n with
  | O => (quo, rem)
  | S n' =>
    match rem with
    | O => nat_divmod n' m (S quo) m
    | S rem' => nat_divmod n' m quo rem'
    end
  end.

Definition nat_div (a b :nat) :nat :=
  match b with
  | O => b
  | S b' => fst (nat_divmod a b' 0 b')
  end.

Definition nat_mod (a b : nat) :nat :=
  match b with
  | O => b
  | S b' => b' - snd (nat_divmod a b' 0 b')
  end.

Lemma identity_fn_applied_twice :
  forall (f : bool -> bool) ,
  (forall x :bool, f x = x) ->
  forall (b :bool), f (f b) = b.
Proof.
  intros f.
  intros H.
  intros b.
  rewrite -> H.
  rewrite <- H.
  reflexivity.
Qed.

Lemma negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall x :bool, f x = negb x) ->
  forall (b :bool), f (f b) = b.
Proof.
  intros f.
  intros H.
  intros b.
  destruct b.
  - rewrite -> H. rewrite -> H. reflexivity.
  - rewrite -> H. rewrite -> H. reflexivity.
Qed.

Lemma andb_eq_orb :
  forall n m :bool,
  (andb n m = orb n m) -> n = m.
Proof.
  intros [] [].
  - reflexivity.
  - simpl. intros H. rewrite -> H. reflexivity.
  - simpl. intros H. rewrite -> H. reflexivity.
  - reflexivity.
Qed.

Inductive bin : Type :=
  | Z : bin
  | Twice : bin -> bin
  | Twice_and1: bin -> bin.

Fixpoint incr(n : bin) : bin :=
  match n with
  | Z => Twice_and1 Z
  | Twice n' => Twice_and1 n'
  | Twice_and1 n' => Twice (incr n')
  end.

Fixpoint bin_to_nat (n : bin) :nat :=
  match n with
  | Z => O
  | Twice n' => 2 * (bin_to_nat n')
  | Twice_and1 n' => 1 + 2 * (bin_to_nat n')
  end.

Example test_bin_incr1 : bin_to_nat (incr (Twice_and1 (Twice (Twice_and1 Z)))) =
  S (bin_to_nat (Twice_and1 (Twice (Twice_and1 Z)))).
Proof.
  simpl.
  reflexivity.
Qed.


Require Import List.
Require Import Arith.
Require Import Omega.
Require Import OptionExt.

Lemma list_dec : forall A (l:list A), (exists h, exists t, l = h::t) \/ l = nil.
intros. destruct l;[right; trivial| left; exists a; exists l]; trivial.
Save.

Lemma nth_error_ok : forall (A:Type) (l:list A) n, n < length l -> exists x, nth_error l n = Some x.
intros A l. induction l; intros.
elimtype False. generalize H. apply lt_n_O.
destruct (O_or_S n).
destruct s. subst n. simpl. apply IHl. simpl in H. apply lt_S_n. apply H.
subst n. simpl. exists a. trivial.
Save.

Lemma nth_error_length_2 : forall (A:Type) (l:list A) n x, nth_error l n = Some x -> n < length l.
intros. generalize l H. clear l H.
induction n; intros; destruct l; try discriminate; simpl.
auto with arith.
simpl in H. auto with arith.
Save.

Fixpoint tail (A:Type) (n:nat) (ops:list A) {struct n} : list A :=
  match n, ops with
  | 0, ops => ops
  | S n, _::ops => tail A n ops
  | S n, nil => nil
  end.
Implicit Arguments tail [A].

Lemma nth_error_tail : forall (A:Type) n (l l':list A) o, tail n l = o::l' -> nth_error l n = Some o.
intros A n.
induction n; intros; destruct l; try discriminate.
inversion H. subst o. trivial.
simpl in * |- *. eapply IHn. apply H.
Save.

Lemma tail_nth_error : forall (A:Type) n (l:list A) o, nth_error l n = Some o -> exists l', tail n l = o::l'.
intros A n.
induction n; intros; destruct l; try discriminate.
inversion H. subst o. exists l. trivial.
simpl in * |- *. apply IHn. apply H.
Save.
Implicit Arguments tail_nth_error [A].

Lemma tail_0 : forall (A:Type) (l:list A), tail 0 l = l.
trivial.
Save.
Implicit Arguments tail_0 [A].

Lemma tail_S : forall (A:Type) n (l:list A), n < length l -> exists a, tail n l = a :: tail (S n) l.
intros A n. induction n; intros.
destruct l. elimtype False. apply (lt_n_O 0 H).
simpl. exists a. trivial.
destruct l. elimtype False. apply (lt_n_O (S n) H).
simpl in H. assert (n < length l). auto with arith.
destruct (IHn l H0).
exists x. simpl. apply H1.
Save.
Implicit Arguments tail_S [A].

Lemma tail_minus : forall (A:Type) (l:list A) n' n, n' < n -> n < length l -> exists a, tail (n - S n') l = a::tail (n-n') l.
intros. replace (n-n') with (S (n - S n')).
apply tail_S. omega. omega.
Save.
Implicit Arguments tail_minus [A].

Lemma app_length : forall A (l1 l2:list A), length (l1 ++ l2) = length l1 + length l2.
intros. induction l1. trivial. simpl. rewrite IHl1. trivial.
Save.

Lemma rev_length : forall A (l:list A), length (rev l) = length l.
intros. induction l. trivial. simpl. rewrite app_length. rewrite IHl. simpl. omega.
Save.

Lemma map_length : forall (A B:Type) (l:list A) (f:A->B), length (map f l) = length l.
intros. induction l. trivial. simpl. rewrite IHl. trivial.
Save.

Lemma map_app : forall (A B:Type) (l1 l2:list A) (f:A->B), map f (l1 ++ l2) = map f l1 ++ map f l2.
intros. induction l1. trivial. simpl. rewrite IHl1. trivial.
Save.

Lemma map_rev : forall (A B:Type) (l:list A) (f:A->B), map f (rev l) = rev (map f l).
intros. induction l. trivial.
simpl. rewrite map_app. rewrite IHl. trivial.
Save.

Fixpoint list_update (A:Type) (l:list A) (n:nat) (v:A) {struct n} : option (list A) :=
  match n, l with
  | 0,   old_v::rest => Some (v::rest)
  | S n, v'::rest    => match list_update A rest n v with None => None | Some rest' => Some (v'::rest') end
  | _,   nil         => None
  end.
Implicit Arguments list_update [A].

Lemma list_update_nth_error : forall (A:Type) (l l':list A) n x,
  list_update l n x = Some l' -> nth_error l' n = Some x.
intros. generalize l l' H. clear l l' H.
induction n; intros; destruct l; inversion H.
 trivial.
 destruct (option_dec (list_update l n x)) as [[x' update_res]|update_res]; rewrite update_res in H1.
  inversion H1. simpl. eauto.
  discriminate.
Save.

Lemma list_update_length : forall (A:Type) (l l':list A) n v,
  list_update l n v = Some l' -> length l = length l'.
intros A l.
induction l; intros; destruct n; destruct l'; try discriminate; simpl in * |- *.
inversion H. trivial.
destruct (list_update l n v); discriminate.
destruct (option_dec (list_update l n v)) as [[x' update_res]|update_res]; rewrite update_res in H.
 inversion H. subst. rewrite (IHl _ _ _ update_res). reflexivity.
 discriminate.
Save.

Lemma list_update_lt_length : forall (A:Type) (l:list A) v n,
  n < length l -> exists l', list_update l n v = Some l'.
intros A l v.
induction l; intros; destruct n.
elimtype False. apply (lt_n_O _ H).
elimtype False. apply (lt_n_O _ H).
exists (v::l). trivial.
simpl in * |- *. destruct (IHl _ (lt_S_n _ _ H)). rewrite H0. exists (a::x). trivial.
Save.

Lemma list_update_lt_length_2 : forall (A:Type) (l l':list A) v n,
 list_update l n v = Some l' -> n < length l'.
intros A l.
induction l; intros; destruct n.
inversion H.
inversion H.
inversion H. simpl. auto with arith.
simpl in H. destruct (option_dec (list_update l n v)) as [[x' update_res]|update_res]; rewrite update_res in H.
 inversion H. simpl. eauto using lt_n_S.
 discriminate.
Save.

Lemma nth_error_length : forall A (l:list A) v n,
 nth_error l n = Some v -> n < length l.
intros A l v.
induction l; intros; destruct n; try discriminate; simpl in * |- *.
auto with arith.
apply lt_n_S. auto.
Save.

Lemma list_update_indep : forall (A:Type) (l l':list A) n n' v x,
  nth_error l n = Some x -> list_update l n' v = Some l' -> n <> n' ->
  nth_error l' n = Some x.
intros A l.
induction l; intros; destruct n; try discriminate.
 inversion H. subst. destruct n'.
  elimtype False. apply H1. trivial.
  simpl in H0. destruct (list_update l n' v); try discriminate.
  inversion H0. subst. trivial.
 simpl in H. destruct n'.
  inversion H0. simpl. assumption.
  simpl in H0. destruct (option_dec (list_update l n' v)) as [[x' update_res]|update_res]; rewrite update_res in H0.
   inversion H0. subst. simpl. intuition first[eauto|omega].
   discriminate.
Save.

Lemma is_nil : forall A (x:list A), {x=nil}+{x<>nil}.
intros. destruct x; [left;trivial|right; unfold not; intro; discriminate].
Save.
Implicit Arguments is_nil [A].

Definition list_informative : forall (A:Type) (l:list A), { a : A & { l' : list A | l = a::l' } }+{l = nil}.
intros. destruct l.
 right. reflexivity.
 left. exists a. exists l. reflexivity.
Defined.
Implicit Arguments list_informative [A].

Section holds_for_list.

Hypothesis A: Type.
Hypothesis P:A->Prop.

Inductive holds_for_list : list A -> Prop :=
| holds_for_nil : holds_for_list nil
| holds_for_cons : forall a t, P a -> holds_for_list t -> holds_for_list (a::t).

End holds_for_list.

Implicit Arguments holds_for_list [A].


From Coq Require Import Bool.Bool. Import BoolNotations.
From Coq Require Import Lists.List. Import ListNotations.
From Cypher Require Import Decidability.

(* ================================================================= *)
(** ** List-Based Maps *)

(** To encode typing environments (and, later on, states), we will
    need maps from identifiers to values. However, the function-based
    representation in the _Software Foundations_ version of Imp is not
    well suited for testing: we need to be able to access the domain
    of the map, fold over it, and test for equality; these are all
    awkward to define for Coq functions. Therefore, we introduce a
    simple list-based map representation that uses [id]s as the keys.

    The operations we need are:
       - [empty] : To create the empty map.
       - [get] : To look up the binding of an element, if any.
       - [set] : To update the binding of an element.
       - [dom] : To get the list of keys in the map. *)

(** The implementation of a map is a simple association list.  If a
    list contains multiple tuples with the same key, then the binding
    of the key in the map is the one that appears first in the list;
    that is, later bindings can be shadowed. *)

(** The implementation of a map is a simple association list.  If a
    list contains multiple tuples with the same key, then the binding
    of the key in the map is the one that appears first in the list;
    that is, later bindings can be shadowed. *)

Definition Map K V := list (K * V).

(** The [empty] map is the empty list. *)

Definition map_empty {K V} : Map K V := [].

(** To [get] the binding of an identifier [x], we just need to walk
    through the list and find the first [cons] cell where the key
    is equal to [x], if any. *)

Fixpoint map_get {K V} `{EqDec K} (m : Map K V) x : option V :=
    match m with
    | [] => None
    | (k, v) :: m' => if x = k ? then Some v else map_get m' x
    end.

(** To [set] the binding of an identifier, we just need to [cons]
    it at the front of the list. *)

Definition map_set {K V} (m : Map K V) (x : K) (v : V) : Map K V := (x, v) :: m.

(** Finally, the domain of a map is just the set of its keys. *)
Fixpoint map_dom {K V} (m : Map K V) : list K :=
    match m with
    | [] => []
    | (k', v) :: m' => k' :: map_dom m'
    end.

Fixpoint map_includes_aux {K V} `{EqDec K} `{EqDec V} (m m_included : Map K V) (dom : list K) : bool :=
    match m, m_included with
    | [], [] => true
    | _, [] => true
    | [], _ => false
    | _, _ => match dom with
              | [] => true
              | k :: dom' => if (map_get m k) =? (map_get m_included k) then
                map_includes_aux m m_included dom'
              else
                false
              end
    end.

Definition map_includes {K V} `{EqDec K} `{EqDec V} (m m_included : Map K V) : bool :=
    map_includes_aux m m_included (map_dom m_included).


(*******************************************************************)
(*  This is part of RelationAlgebra, it is distributed under the   *)
(*    terms of the GNU Lesser General Public License version 3     *)
(*              (see file LICENSE for more details)                *)
(*                                                                 *)
(*  Copyright 2012: Damien Pous. (CNRS, LIP - ENS Lyon, UMR 5668)  *)
(*******************************************************************)

(** * lattice: from preorders to Boolean lattices *)

(** We define here all structures ranging from preorders to Boolean
   lattice (e.g., sup-semilattices, inf-semilattices with bottom
   element, bounded lattices, etc...).  *)

Require Export common level.

Delimit Scope ra_terms with ra.
Open Scope ra_scope.
Open Scope ra_terms.

(** * Lattice operations *)

(** The following class packages all operations that can possibly
   come with a preorder: a supremum, a bottom element, a negation,
   etc... We use dummy values when working in structures lacking some
   operations.

   We use a "Class" rather than a "Structure" just to make the first
   argument of all the corresponding projections implicit. Instances
   of this class will be declared as Canonical structures rather than
   typeclasses instances, so that this first argument will actually be
   inferred by unification. (except in the abstract and unconstrained
   case, where typeclass resolution will be called since unification
   will keep the hole unconstrained) *)

Class ops := mk_ops {
  car: Type;                    (** carrier *)
  leq: relation car;            (** preorder *)
  weq: relation car;            (** underlying equality *)
  cup: car -> car -> car;       (** supremum *)
  cap: car -> car -> car;       (** infimum *)
  neg: car -> car;              (** Boolean negation *)
  bot: car;                     (** bottom element *)
  top: car                      (** top element *)
}.
Implicit Arguments car [].
Coercion car: ops >-> Sortclass.
Bind Scope ra_terms with car.

(** Hints for simpl *)
Arguments weq {ops} (x y)%ra / : simpl nomatch.
Arguments leq {ops} (x y)%ra / : simpl nomatch.
Arguments cup {ops} (x y)%ra / : simpl nomatch.
Arguments cap {ops} (x y)%ra / : simpl nomatch.
Arguments neg {ops} (x)%ra / : simpl nomatch.
Arguments bot {ops} / : simpl nomatch.
Arguments top {ops} / : simpl nomatch.

(** Notations *)
Infix "<=="  := leq (at level 79): ra_scope.
Infix "=="   := weq (at level 79): ra_scope.
Infix "\cup" := cup (left associativity, at level 50): ra_terms.
Infix "\cap" := cap (left associativity, at level 40): ra_terms.
Notation "! x" := (neg x) (right associativity, at level 20): ra_terms.

(** * Lattice laws (axioms) *)

(** [laws l X] provides the laws corresponding to the various
   operations of [X], provided these operations belong to the level
   [l]. For instance, the specification of the supremum ([cup]) is
   available only if the level contains [CUP].

   Note that [leq] is always require to be a preorder, and [weq] is
   always required to be the kernel of that preorder.

   Also note that some axioms ([leq_bx_], [leq_x_t_]) are present
   unless some operations are present in [l]. They end with an
   underscore, they are actually derivable from the other axioms when
   the additional operations belong to [l]. They are reformulated
   without the escaping disjunction below, under the same name but
   without the ending underscore (see [leq_bx], [leq_x_t] below).

   The field name [cupcap_] also ends with an underscore, this is
   because it's statement is an inequality, for which the converse
   inequality is derivable. It is thus later reformulated as an
   equality (see lemma [cupcap] below).

   Unlike for operations ([ops]), laws are actually inferred by
   typeclass resolution. *)

Class laws (l: level) (X: ops) := {
  leq_PreOrder:> PreOrder leq;
  weq_spec            : forall x y , x==y <-> x<==y /\ y<==x;
  cup_spec {Hl:CUP<<l}: forall x y z, x \cup y <== z <-> x <== z /\ y <== z;
  cap_spec {Hl:CAP<<l}: forall x y z, z <== x \cap y <-> z <== x /\ z <== y;
  leq_bx_  {Hl:BOT<<l}: NEG+CAP<<l \/ forall x, bot <== x;
  leq_xt_  {Hl:TOP<<l}: NEG+CUP<<l \/ forall x, x <== top;
  cupcap_  {Hl:DL <<l}: forall x y z, (x\cup y) \cap (x\cup z) <== x \cup (y \cap z);
  capneg   {Hl:NEG+CAP+BOT<<l}: forall x, x \cap !x == bot;
  cupneg   {Hl:NEG+CUP+TOP<<l}: forall x, x \cup !x == top
}.

(** * Properties of the preorder ([<==]) and it kernel ([==]) *)

Lemma antisym `{laws}: forall x y, x<==y -> y<==x -> x==y.
Proof. intros. apply weq_spec; split; assumption. Qed.

Lemma from_below `{laws}: forall x y, (forall z, z<==x <-> z<==y) -> x==y.
Proof. intros x y E. apply antisym; apply E; reflexivity. Qed.

Lemma from_above `{laws}: forall x y, (forall z, x<==z <-> y<==z) -> x==y.
Proof. intros x y E. apply antisym; apply E; reflexivity. Qed.

(** Trivial hints *)
Hint Extern 0 (_ <== _) => reflexivity.
Hint Extern 0 (_ == _) => reflexivity.

(** Instances to be used by the setoid_rewrite machinery *)
Instance weq_Equivalence `{laws}: Equivalence weq.
Proof.
  constructor.
   intro. now rewrite weq_spec.
   intros ? ?. rewrite 2weq_spec. tauto.
   intros x y z. rewrite 3weq_spec. intuition; etransitivity; eassumption.
Qed.

Instance weq_leq `{laws}: subrelation weq leq.
Proof. intros x y E. apply weq_spec in E as [? ?]. assumption. Qed.

Instance weq_geq `{laws}: subrelation weq (flip leq).
Proof. intros x y E. apply weq_spec in E as [? ?]. assumption. Qed.

Instance leq_weq_iff `{laws}: Proper (weq ==> weq ==> iff) leq.
Proof.
  intros x y E x' y' E'. split; intro L.
  now rewrite <-E, <-E'.
  now rewrite E, E'.
Qed.

(** Utility lemmas, to deduce that a function preserves [weq] once we
   proved that it preserves [leq], these are extremely useful in
   practice *)

Lemma op_leq_weq_1 {h k X Y} {HX: laws h X} {HY: laws k Y} {f: X -> Y}
  {Hf: Proper (leq ==> leq) f}: Proper (weq ==> weq) f.
Proof. intros x y. rewrite 2weq_spec. intro E; split; apply Hf; apply E. Qed.

Lemma op_leq_weq_2 {h k l X Y Z} {HX: laws h X} {HY: laws k Y} {HZ: laws l Z} {f: X -> Y -> Z}
  {Hf: Proper (leq ==> leq ==> leq) f}: Proper (weq ==> weq ==> weq) f.
Proof.
  intros x y E x' y' E'. rewrite weq_spec in E. rewrite weq_spec in E'.
  apply antisym; apply Hf; (apply E || apply E').
Qed.

(** Additional hints, to speedup typeclass resolution  *)

Instance leq_Reflexive `{laws}: Reflexive leq |1.
Proof. eauto with typeclass_instances. Qed.
Instance leq_Transitive `{laws}: Transitive leq |1.
Proof. eauto with typeclass_instances. Qed.

Instance weq_Reflexive `{laws}: Reflexive weq |1.
Proof. eauto with typeclass_instances. Qed.
Instance weq_Transitive `{laws}: Transitive weq |1.
Proof. eauto with typeclass_instances. Qed.
Instance weq_Symmetric `{laws}: Symmetric weq |1.
Proof. eauto with typeclass_instances. Qed.

(** We declare most projections as Opaque for typeclass resolution:
   this saves a lot of compilation time *)
(* NOTE: declaring [weq] as opaque for typeclasses also saves some time,
   but this is problematic with the [Prop] instances, for which we often
   need [weq=iff] to be used by typeclass resolution *)
Typeclasses Opaque (* weq *) leq cup cap neg bot top.

(** * Basic properties of [\cup], [\cap], [bot], and [top] *)

Lemma leq_cupx `{laws} `{CUP<<l}: forall x y z, x<==z -> y<==z -> x \cup y <== z.
Proof. intros. apply cup_spec. split; assumption. Qed.

Lemma leq_xcup `{laws} `{CUP<<l}: forall x y z, z<==x \/ z<==y -> z <== x \cup y.
Proof.
  intros x y z. assert (C:= cup_spec x y (x\cup y)).
  intros [E|E]; rewrite E; apply C; reflexivity.
Qed.

Lemma leq_xcap `{laws} `{CAP<<l}: forall x y z, z<==x -> z<==y -> z <== x \cap y.
Proof. intros. apply cap_spec. split; assumption. Qed.

Lemma leq_capx `{laws} `{CAP<<l}: forall x y z, x<==z \/ y<==z -> x \cap y <== z.
Proof.
  intros x y z. assert (C:= cap_spec x y (x\cap y)).
  intros [E|E]; rewrite <- E; apply C; reflexivity.
Qed.

Lemma leq_bx `{L: laws} {Hl:BOT<<l}: forall x, bot <== x.
Proof.
  destruct leq_bx_ as [Hl'|H]. 2: apply H.
  intro x. rewrite <-(capneg x). apply leq_capx. left. reflexivity.
Qed.

Lemma leq_xb_iff `{L: laws} {Hl:BOT<<l}: forall x, x <== bot <-> x == bot.
Proof.
  split; intro. apply antisym. assumption. apply leq_bx.
  now apply weq_leq.
Qed.

Lemma leq_xt `{L: laws} {Hl:TOP<<l}: forall x, x <== top.
Proof.
  destruct leq_xt_ as [Hl'|H]. 2: apply H.
  intro x. rewrite <-(cupneg x). apply leq_xcup. left. reflexivity.
Qed.

Lemma leq_tx_iff `{L: laws} {Hl:TOP<<l}: forall x, top <== x <-> x == top.
Proof.
  split; intro. apply antisym. apply leq_xt. assumption.
  now apply weq_leq.
Qed.

(** * Subtyping / weakening *)

(** laws that hold at any level [h] hold for all level [k << h]  *)
Lemma lower_lattice_laws {h k} {X} {H: laws h X} {le: k<<h}: laws k X.
Proof.
  constructor; try solve [ apply H | intro; apply H; eauto using lower_trans ].
   intro. right. eapply @leq_bx. apply H. eauto using lower_trans.
   intro. right. eapply @leq_xt. apply H. eauto using lower_trans.
Qed.

(** * Solving (in)equations in non distributive lattices *)

(** simple tactic to solve lattice (in)equations,
   using a basic focused proof search algorithm *)
Ltac lattice :=
  let rec async := (* idtac "async"; *) solve
    [ apply leq_cupx; async
    | apply leq_xcap; async
    | apply leq_bx
    | apply leq_xt
    | sync_l false || sync_r false ]
  with sync_l b := (* idtac "sync_l"; *) solve
    [ reflexivity
    | assumption
    | apply leq_capx; ((left; sync_l true) || (right; sync_l true))
    | match b with true => async end ]
  with sync_r b := (* idtac "sync_r"; *) solve
    [ reflexivity
    | assumption
    | apply leq_xcup; ((left; sync_r true) || (right; sync_r true))
    | match b with true => async end ]
  in
  (try apply antisym); async || fail "not a lattice theorem".

(** extension of the above tactic so that it also tries to exploit
    hypotheses in a more agressive way *)
Ltac hlattice :=
  repeat
    match goal with
      | H: _ == _ |- _ => apply weq_spec in H as [? ?]
      | H: _ \cup _ <== _ |- _ => apply cup_spec in H as [? ?]
      | H: _ <== _ \cap _ |- _ => apply cap_spec in H as [? ?]
    end; lattice.

(** * Reasoning by duality *)

(** dual lattice operations: we reverse the preorder, and swap cup
   with cap, and resp bot with top) *)
Definition dual (X: ops) := {|
  leq := flip leq;
  weq := weq;
  cup := cap;
  cap := cup;
  neg := neg;
  bot := top;
  top := bot |}.

Lemma capcup_ `{laws} `{DL<<l}: forall x y z, x \cap (y \cup z) <== (x\cap y) \cup (x\cap z).
Proof.
  intros. rewrite <- cupcap_. apply leq_xcap. lattice.
  transitivity (z\cup x\cap y). 2: lattice.
  rewrite <- cupcap_. lattice.
Qed.

Ltac inverse_lower l Hl :=
  revert Hl; clear; destruct l; unfold lower, merge; simpl; rewrite ?landb_spec; tauto.

(** laws on a given set of operations can be transferred to the dual set of operations *)
Lemma dual_laws l (X: ops): laws (level.dual l) X -> laws l (dual X).
Proof.
  intro H. constructor; try (destruct l; apply H).
  constructor. apply H. intros x y z H1 H2. revert H2 H1. simpl. apply H.
  intros x y. simpl. rewrite weq_spec. tauto.
  intro. simpl. eapply @capcup_. apply H. inverse_lower l Hl.
  intro. simpl. eapply @cupneg. apply H. inverse_lower l Hl.
  intro. simpl. eapply @capneg. apply H. inverse_lower l Hl.
Qed.

(** this gives us a tactic to prove properties by lattice duality *)
Lemma dualize {h} {P: ops -> Prop} (L: forall l X, laws l X -> h<<l -> P X)
  {l X} {H: laws l X} {Hl:level.dual h<<l}: P (dual X).
Proof.
  apply L with (level.dual l). apply dual_laws.
  destruct l; apply H.
  revert Hl. rewrite 2lower_spec. destruct l; destruct h; simpl. tauto.
Qed.

Ltac dual x := apply (dualize x).

(** * [(\cup,bot)] forms a commutative, idempotent monoid *)

Lemma cupA `{laws} `{CUP<<l}: forall x y z, x \cup (y \cup z) == (x \cup y) \cup z.
Proof. intros. lattice. Qed.
Lemma cupC `{laws} `{CUP<<l}: forall x y, x \cup y == y \cup x.
Proof. intros. lattice. Qed.
Lemma cupI `{laws} `{CUP<<l}: forall x, x \cup x == x.
Proof. intros. lattice. Qed.
Lemma cupbx `{laws} `{CUP+BOT<<l}: forall x, bot \cup x == x.
Proof. intros. lattice. Qed.
Lemma cupxb `{laws} `{CUP+BOT<<l}: forall x, x \cup bot == x.
Proof. intros. lattice. Qed.

Lemma cuptx `{laws} `{CUP+TOP<<l}: forall x, top \cup x == top.
Proof. intros. lattice. Qed.
Lemma cupxt `{laws} `{CUP+TOP<<l}: forall x, x \cup top == top.
Proof. intros. lattice. Qed.

Lemma leq_cup_l `{laws} `{CUP<<l} x y: x <== x \cup y.
Proof. lattice. Qed.
Lemma leq_cup_r `{laws} `{CUP<<l} x y: y <== x \cup y.
Proof. lattice. Qed.

Instance cup_leq `{laws} `{CUP<<l}: Proper (leq ==> leq ==> leq) cup.
Proof. intros x x' Hx y y' Hy. lattice. Qed.

Instance cup_weq `{laws} `{CUP<<l}: Proper (weq ==> weq ==> weq) cup.
Proof. apply op_leq_weq_2. Qed.

(** distribution of [\cup] over [\cap] *)
Lemma cupcap `{laws} `{DL<<l}: forall x y z, x \cup (y \cap z) == (x\cup y) \cap (x\cup z).
Proof. intros. apply antisym. lattice. apply cupcap_. Qed.

(** characterisation of the preorder by the semilattice operations *)
Lemma leq_iff_cup `{laws} `{CUP<<l} (x y: X): x<==y <-> x\cup y==y.
Proof. split. intro. hlattice. intro E. rewrite <- E. lattice. Qed.

(* this lemma is used twice... *)
Lemma comm4 `{laws} `{CUP<<l} (a b c d: X): a\cup b\cup c\cup d == (a\cup c)\cup(b\cup d).
Proof. lattice. Qed.

(** * [(\cap,top)] forms a commutative, idempotent monoid (by duality) *)

Lemma capA `{laws} `{CAP<<l}: forall x y z, x \cap (y \cap z) == (x \cap y) \cap z.
Proof. dual @cupA. Qed.
Lemma capC `{laws} `{CAP<<l}: forall x y, x \cap y == y \cap x.
Proof. dual @cupC. Qed.
Lemma capI `{laws} `{CAP<<l}: forall x, x \cap x == x.
Proof. dual @cupI. Qed.
Lemma captx `{laws} `{CAP+TOP<<l}: forall x, top \cap x == x.
Proof. dual @cupbx. Qed.
Lemma capxt `{laws} `{CAP+TOP<<l}: forall x, x \cap top == x.
Proof. dual @cupxb. Qed.

Lemma capbx `{laws} `{CAP+BOT<<l}: forall x, bot \cap x == bot.
Proof. dual @cuptx. Qed.
Lemma capxb `{laws} `{CAP+BOT<<l}: forall x, x \cap bot == bot.
Proof. dual @cupxt. Qed.

Lemma leq_cap_l `{laws} `{CAP<<l} x y: x \cap y <== x.
Proof. lattice. Qed.
Lemma leq_cap_r `{laws} `{CAP<<l} x y: x \cap y <== y.
Proof. lattice. Qed.

Instance cap_leq `{laws} `{CAP<<l}: Proper (leq ==> leq ==> leq) cap.
Proof. intros x x' Hx y y' Hy. lattice. Qed.

Instance cap_weq `{laws} `{CAP<<l}: Proper (weq ==> weq ==> weq) cap.
Proof. apply op_leq_weq_2. Qed.

Lemma leq_iff_cap `{laws} `{CAP<<l} (x y: X): x<==y <-> x\cap y==x.
Proof. split. intro. hlattice. intro E. rewrite <- E. lattice. Qed.

Lemma capcup `{laws} `{DL<<l}: forall x y z, x \cap (y \cup z) == (x\cap y) \cup (x\cap z).
Proof. dual @cupcap. Qed.

Lemma cupcap' `{laws} `{DL<<l}: forall x y z, (y \cap z) \cup x == (y\cup x) \cap (z\cup x).
Proof. intros. now rewrite cupC, cupcap, 2(cupC x). Qed.

Lemma capcup' `{laws} `{DL<<l}: forall x y z, (y \cup z) \cap x == (y\cap x) \cup (z\cap x).
Proof. dual @cupcap'. Qed.

(** * Properties of negation *)

Lemma neg_unique' `{laws} `{BL<<l} (x y: X): y \cap x <== bot -> y <== !x.
Proof.
  intros E. rewrite <-(capxt y). rewrite <-(cupneg x).
  rewrite capcup. rewrite E. lattice.
Qed.

Lemma neg_unique `{laws} `{BL<<l} (x y: X):
  top <== y \cup x -> y \cap x <== bot -> y == !x.
Proof.
  intros Ht Hb. apply antisym.
  now apply neg_unique'.
  revert Ht. dual @neg_unique'.
Qed.

Instance neg_leq `{laws} `{BL<<l}: Proper (leq --> leq) neg.
Proof.
  intros x y E. apply neg_unique'.
  rewrite <-E, capC. now rewrite capneg.
Qed.

Instance neg_weq `{laws} `{BL<<l}: Proper (weq ==> weq) neg.
Proof. intros x y. rewrite 2weq_spec. intro E; split; apply neg_leq, E. Qed.

Lemma negneg `{laws} `{BL<<l} (x: X): !!x == x.
Proof. symmetry. apply neg_unique. now rewrite cupneg. now rewrite capneg. Qed.

Lemma negbot `{laws} `{BL<<l}: !bot == top.
Proof. symmetry. apply neg_unique; lattice. Qed.

Lemma negtop `{laws} `{BL<<l}: !top == bot.
Proof. dual @negbot. Qed.

Lemma negcap' `{laws} `{BL<<l} (x y: X): !x \cup !y <== !(x\cap y).
Proof. apply leq_cupx; apply neg_leq; lattice. Qed.

Lemma negcup `{laws} `{BL<<l} (x y: X): !(x\cup y) == !x \cap !y.
Proof.
  apply antisym. dual @negcap'.
  rewrite <- (negneg x) at 2.
  rewrite <- (negneg y) at 2.
  now rewrite negcap', negneg.
Qed.

Lemma negcap `{laws} `{BL<<l} (x y: X): !(x\cap y) == !x \cup !y.
Proof. dual @negcup. Qed.

(** switching negations *)
Lemma neg_leq_iff `{laws} `{BL<<l} (x y: X): !x <== !y <-> y <== x.
Proof. split. intro E. apply neg_leq in E. now rewrite 2negneg in E. apply neg_leq. Qed.
Lemma neg_leq_iff' `{laws} `{BL<<l} (x y: X): x <== !y <-> y <== !x.
Proof. now rewrite <- neg_leq_iff, negneg. Qed.
Lemma neg_leq_iff'' `{laws} `{BL<<l} (x y: X): !x <== y <-> !y <== x.
Proof. now rewrite <- neg_leq_iff, negneg. Qed.

Lemma neg_weq_iff `{laws} `{BL<<l} (x y: X): !x == !y <-> y == x.
Proof. now rewrite 2weq_spec, 2neg_leq_iff. Qed.
Lemma neg_weq_iff' `{laws} `{BL<<l} (x y: X): x == !y <-> !x == y.
Proof. now rewrite <-neg_weq_iff, negneg. Qed.
Lemma neg_weq_iff'' `{laws} `{BL<<l} (x y: X): !x == y <-> x == !y.
Proof. now rewrite <-neg_weq_iff, negneg. Qed.

Ltac neg_switch := first [
  rewrite neg_leq_iff |
  rewrite neg_leq_iff' |
  rewrite neg_leq_iff'' |
  rewrite <-neg_leq_iff |
  rewrite neg_weq_iff |
  rewrite neg_weq_iff' |
  rewrite neg_weq_iff'' |
  rewrite <-neg_weq_iff ].

Lemma leq_cap_neg `{laws} `{BL<<l} (x y: X): y <== x <-> y \cap !x <== bot.
Proof.
  split. intro E. now rewrite E, capneg.
  intro E. now rewrite (neg_unique' _ _ E), negneg.
Qed.

Lemma leq_cap_neg' `{laws} `{BL<<l} (x y: X): y \cap x <== bot <-> y <== !x.
Proof. rewrite <-(negneg x) at 1. symmetry. apply leq_cap_neg. Qed.

Lemma leq_cup_neg `{laws} `{BL<<l} (x y: X): x <== y <-> top <== y \cup !x.
Proof. dual @leq_cap_neg. Qed.

Lemma leq_cup_neg' `{laws} `{BL<<l} (x y: X): top <== y \cup x -> !x <== y.
Proof. dual @leq_cap_neg'. Qed.

(** * Morphisms *)

(** an [l]-morphism betwen to sets of operations are defined as
   expected: the function is requried to preserve only the operations
   listed in [l] *)

Class morphism l {X Y: ops} (f: X -> Y) := {
  fn_leq: Proper (leq ==> leq) f;
  fn_weq: Proper (weq ==> weq) f;
  fn_cup {Hl:CUP<<l}: forall x y, f (x \cup y) == f x \cup f y;
  fn_cap {Hl:CAP<<l}: forall x y, f (x \cap y) == f x \cap f y;
  fn_bot {Hl:BOT<<l}: f bot == bot;
  fn_top {Hl:TOP<<l}: f top == top;
  fn_neg {Hl:NEG<<l}: forall x, f (!x) == ! f x
}.

(** generating a structure by injective embedding *)

Lemma laws_of_injective_morphism {h l X Y} {L: laws h Y} {Hl: l<<h} f:
  @morphism l X Y f ->
  (forall x y, f x <== f y -> x <== y) ->
  (forall x y, f x == f y -> x == y) ->
  laws l X.
Proof.
  intros Hf Hleq Hweq. apply (@lower_lattice_laws _ _ _ L) in Hl. clear L.
  assert (Hleq_iff: forall x y, f x <== f y <-> x <== y).
   split. apply Hleq. apply fn_leq.
  assert (Hweq_iff: forall x y, f x == f y <-> x == y).
   split. apply Hweq. apply fn_weq.
  constructor. constructor.
   intro. apply Hleq. reflexivity.
   intros x y z. rewrite <-3Hleq_iff. apply Hl.
   intros. now rewrite <-Hweq_iff, weq_spec, 2Hleq_iff.
   intros. rewrite <-3Hleq_iff, fn_cup. apply cup_spec.
   intros. rewrite <-3Hleq_iff, fn_cap. apply cap_spec.
   right. intros. apply Hleq. rewrite fn_bot. apply leq_bx.
   right. intros. apply Hleq. rewrite fn_top. apply leq_xt.
   intros. apply Hleq. rewrite fn_cup, fn_cap, 2fn_cup, fn_cap. apply cupcap_.
   intros. rewrite <-Hweq_iff. rewrite fn_cap, fn_neg, fn_bot. apply capneg.
   intros. rewrite <-Hweq_iff. rewrite fn_cup, fn_neg, fn_top. apply cupneg.
Qed.

(** * Pointwise extension of a structure *)

Definition pw0 {Y X} (f: X) (y: Y) := f.
Definition pw1 {Y X} (f: X -> X) (u: Y -> X) (y: Y) := f (u y).
Definition pw2 {Y X} (f: X -> X -> X) (u v: Y -> X) (y: Y) := f (u y) (v y).

Arguments pw0 {Y X} _ _ /.
Arguments pw1 {Y X} _ _ _ /.
Arguments pw2 {Y X} _ _ _ _ /.

(** As explained above, we use canonical structures for operations inference *)
Canonical Structure pw_ops (X: ops) Y: ops := {|
  car := Y -> X;
  leq := pwr leq;
  weq := pwr weq;
  cup := pw2 cup;
  cap := pw2 cap;
  neg := pw1 neg;
  bot := pw0 bot;
  top := pw0 top
|}.

(** In contrast, we use typeclass resolution for laws inference.
 Note the level polymorphism in the instance below: laws of level [l]
 on [X] yield laws of the same level [l] on [Y -> X]. *)
Instance pw_laws `{laws} Y: laws l (pw_ops X Y).
Proof.
  constructor; simpl; intros. constructor.
   intros f x. reflexivity.
   intros f g h ? ? x. now transitivity (g x).
   setoid_rewrite weq_spec. firstorder.
   setoid_rewrite cup_spec. firstorder.
   setoid_rewrite cap_spec. firstorder.
   right; intros; apply leq_bx.
   right; intros; apply leq_xt.
   apply cupcap_.
   apply capneg.
   apply cupneg.
Qed.

(** trick to factorise code in various tactics: make the choice
   between [leq] or [weq] first-class *)

Definition leq_or_weq (b: bool) := if b then @leq else @weq.
Arguments leq_or_weq _ {_} (_ _)%ra.
Notation "x <=[ b ]= y"  := (leq_or_weq b x y) (at level 79): ra_scope.

Lemma leq_or_weq_weq `{laws} b: Proper (weq ==> weq ==> iff) (leq_or_weq b).
Proof. unfold leq_or_weq; case b; eauto with typeclass_instances. Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Rbase.
Require Import Rfunctions.
Require Import Rseries.
Require Import PartSum.
Require Import Omega.
Local Open Scope R_scope.

Set Implicit Arguments.

Section Sigma.

  Variable f : nat -> R.

  Definition sigma (low high:nat) : R :=
    sum_f_R0 (fun k:nat => f (low + k)) (high - low).

  Theorem sigma_split :
    forall low high k:nat,
      (low <= k)%nat ->
      (k < high)%nat -> sigma low high = sigma low k + sigma (S k) high.
  Proof.
    intros; induction  k as [| k Hreck].
    cut (low = 0%nat).
    intro; rewrite H1; unfold sigma; rewrite <- minus_n_n;
      rewrite <- minus_n_O; simpl; replace (high - 1)%nat with (pred high).
    apply (decomp_sum (fun k:nat => f k)).
    assumption.
    apply pred_of_minus.
    inversion H; reflexivity.
    cut ((low <= k)%nat \/ low = S k).
    intro; elim H1; intro.
    replace (sigma low (S k)) with (sigma low k + f (S k)).
    rewrite Rplus_assoc;
      replace (f (S k) + sigma (S (S k)) high) with (sigma (S k) high).
    apply Hreck.
    assumption.
    apply lt_trans with (S k); [ apply lt_n_Sn | assumption ].
    unfold sigma; replace (high - S (S k))%nat with (pred (high - S k)).
    pattern (S k) at 3; replace (S k) with (S k + 0)%nat;
      [ idtac | ring ].
    replace (sum_f_R0 (fun k0:nat => f (S (S k) + k0)) (pred (high - S k))) with
    (sum_f_R0 (fun k0:nat => f (S k + S k0)) (pred (high - S k))).
    apply (decomp_sum (fun i:nat => f (S k + i))).
    apply lt_minus_O_lt; assumption.
    apply sum_eq; intros; replace (S k + S i)%nat with (S (S k) + i)%nat.
    reflexivity.
    ring.
    replace (high - S (S k))%nat with (high - S k - 1)%nat.
    apply pred_of_minus.
    omega.
    unfold sigma; replace (S k - low)%nat with (S (k - low)).
    pattern (S k) at 1; replace (S k) with (low + S (k - low))%nat.
    symmetry ; apply (tech5 (fun i:nat => f (low + i))).
    omega.
    omega.
    rewrite <- H2; unfold sigma; rewrite <- minus_n_n; simpl;
      replace (high - S low)%nat with (pred (high - low)).
    replace (sum_f_R0 (fun k0:nat => f (S (low + k0))) (pred (high - low))) with
    (sum_f_R0 (fun k0:nat => f (low + S k0)) (pred (high - low))).
    apply (decomp_sum (fun k0:nat => f (low + k0))).
    apply lt_minus_O_lt.
    apply le_lt_trans with (S k); [ rewrite H2; apply le_n | assumption ].
    apply sum_eq; intros; replace (S (low + i)) with (low + S i)%nat.
    reflexivity.
    ring.
    omega.
    inversion H; [ right; reflexivity | left; assumption ].
  Qed.

  Theorem sigma_diff :
    forall low high k:nat,
      (low <= k)%nat ->
      (k < high)%nat -> sigma low high - sigma low k = sigma (S k) high.
  Proof.
    intros low high k H1 H2; symmetry ; rewrite (sigma_split H1 H2); ring.
  Qed.

  Theorem sigma_diff_neg :
    forall low high k:nat,
      (low <= k)%nat ->
      (k < high)%nat -> sigma low k - sigma low high = - sigma (S k) high.
  Proof.
    intros low high k H1 H2; rewrite (sigma_split H1 H2); ring.
  Qed.

  Theorem sigma_first :
    forall low high:nat,
      (low < high)%nat -> sigma low high = f low + sigma (S low) high.
  Proof.
    intros low high H1; generalize (lt_le_S low high H1); intro H2;
      generalize (lt_le_weak low high H1); intro H3;
        replace (f low) with (sigma low low).
    apply sigma_split.
    apply le_n.
    assumption.
    unfold sigma; rewrite <- minus_n_n.
    simpl.
    replace (low + 0)%nat with low; [ reflexivity | ring ].
  Qed.

  Theorem sigma_last :
    forall low high:nat,
      (low < high)%nat -> sigma low high = f high + sigma low (pred high).
  Proof.
    intros low high H1; generalize (lt_le_S low high H1); intro H2;
      generalize (lt_le_weak low high H1); intro H3;
        replace (f high) with (sigma high high).
    rewrite Rplus_comm; cut (high = S (pred high)).
    intro; pattern high at 3; rewrite H.
    apply sigma_split.
    apply le_S_n; rewrite <- H; apply lt_le_S; assumption.
    apply lt_pred_n_n; apply le_lt_trans with low; [ apply le_O_n | assumption ].
    apply S_pred with 0%nat; apply le_lt_trans with low;
      [ apply le_O_n | assumption ].
    unfold sigma; rewrite <- minus_n_n; simpl;
      replace (high + 0)%nat with high; [ reflexivity | ring ].
  Qed.

  Theorem sigma_eq_arg : forall low:nat, sigma low low = f low.
  Proof.
    intro; unfold sigma; rewrite <- minus_n_n.
    simpl; replace (low + 0)%nat with low; [ reflexivity | ring ].
  Qed.

End Sigma.


Require Import Data.Graph.Inductive.Graph.
Require Import Lists.List.

Section Weighted.
Context {a : Type} {b : Type} { gr : Type -> Type -> Type} {Hgraph : Graph.Graph gr} {Hlaw : Graph.LawfulGraph gr}
 {Hnum: GHC.Num.Num b} {Heq: Base.Eq_ b} {HOrd: Base.Ord b} {Hreal: @GHC.Real.Real b Hnum Heq HOrd}.

Definition WeIn (g: gr a b) (u v : Node) (w: b) : Prop :=
  In (u,v,w) (labEdges g).

(*More specific properties for weighted graphs*)
Class LawfulWGraph := {
  (*The context for 'match' - NOTE: doesn't play well with multiple edges between nodes, see about this*)
  Wmatch_context: forall g (v: Node) i x l o g',
    match_ v g = (Some (i, x, l, o), g') -> v = x /\
    (forall y w, In (w, y) i <-> WeIn g y v w) /\
    (forall y w, In (w, y) o <-> WeIn g v y w);
  (*The rest of the graph for a match*)
  Wmatch_remain_some: forall g (v: Node) c g',
    match_ v g = (Some c, g') ->
    (forall u, vIn g' u = true <-> vIn g u = true /\ u <> v) /\
    (forall x y w, WeIn g' x y w <-> WeIn g x y w  /\ x <> v /\ y <> v);
  (*matchAny gives a match_ for some vertex in the graph*)
  WmatchAny_def: forall {a b: Type} (g: gr a b),
    isEmpty g = false ->
    exists v i l o g', matchAny g = ((i, v, l, o), g') /\ vIn g v = true /\
    match_ v g = (Some (i, v, l, o), g')
}.

End Weighted.