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

(* REMINDER: Please do not put solutions to the exercises in
   publicly accessible places.  Thank you!! *)
Add LoadPath "/Users/Harry/Documents/Fall 2016/CSC 495/Software Foundations - Code".
Require Export Lists.

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

Inductive boollist : Type :=
  | bool_nil : boollist
  | bool_cons : bool -> boollist -> 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 : list X
  | cons : X -> list X -> 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 things of type [X]. *)

(** With this definition, when we use the constructors [nil] and
    [cons] to build lists, we need to tell Coq the type of the
    elements in the lists we are building -- that is, [nil] and [cons]
    are now _polymorphic constructors_.  Observe the types of these
    constructors: *)

Check nil.
(* ===> nil : forall X : Type, list X *)
Check cons.
(* ===> 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, [forall] is
    usually typeset as the usual mathematical "upside down A," but
    you'll see the spelled-out "forall" in a few places, as in the
    above comments.  This is just a quirk of typesetting: there is no
    difference in meaning.) *)

(** The "[forall X]" in these types can be read as an additional
    argument to the constructors that determines the expected types of
    the arguments that follow.  When [nil] and [cons] are used, these
    arguments are supplied in the same way as the others.  For
    example, the list containing [2] and [1] is written like this: *)

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 its list argument: *)

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.

Module MumbleGrumble.

(** **** Exercise: 2 stars (mumble_grumble)  *)
(** Consider the following two inductively defined types. *)

Inductive mumble : Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.

Inductive grumble (X:Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

(** Which of the following are well-typed elements of [grumble X] for
    some type [X]?
      - [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]

1/ Not well defined d first argument must be a type not a constructor
2/ Well defined: grumble mumble
3/ Well defined: grumble bool
4/ Well defined: grumble bool with true
5/ Well defined: grumble mumble nat
6/ Not well defined: mumble not bool
7/ Not well defined: c is mumble
*)
(** [] *)

End MumbleGrumble.

(* ----------------------------------------------------------------- *)
(** *** 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 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 we 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 the "implicit argument"
    [_], 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 implicit arguments, the [count] 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 argument synthesis to write this: *)

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

(* ----------------------------------------------------------------- *)
(** *** 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
    [_].) *)

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

(** 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.  For example: *)

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 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' : list'
  | cons' : X -> list' -> 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.

(** 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 [@]. *)

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, optional (poly_exercises)  *)
(** Here are a few simple exercises, just like ones in the [Lists]
    chapter, for practice with polymorphism.  Complete the proofs below. *)

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
(* FILL IN HERE *) Admitted.

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  (* FILL IN HERE *) Admitted.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (more_poly_exercises)  *)
(** Here are some slightly more interesting ones... *)

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** 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 -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

(** 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, 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, 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].

    Uncomment the material below and fill in the definition of
    [split].  Make sure it passes the given unit test. *)

Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y) :=
  match l with
  |[] => ([], [])
  |(x,y):: xySplit =>
         match split xySplit with
          |(xSplit, ySplit) => (x::xSplit, y::ySplit)
        end
  end.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof.
  reflexivity.
Qed.
(** [] *)

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

(** One last polymorphic type for now: _polymorphic options_,
    which generalize [natoption] from the previous chapter: *)

Inductive option (X:Type) : Type :=
  | Some : X -> option X
  | None : option X.

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

(** 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 beq_nat n O then Some a else nth_error l' (pred n)
  end.

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, 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 :=
  (* FILL IN HERE *) admit.

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

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]. *)

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

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

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

(** 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 => beq_nat (length l) 1)
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity.  Qed.

(** **** Exercise: 2 stars (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. *)
SearchAbout nat.
SearchAbout and.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun gt7 => andb (leb 7 gt7) (evenb gt7)) l.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
Proof. reflexivity.  Qed.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
Proof. reflexivity.  Qed.
(** [] *)

(** **** Exercise: 3 stars (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. *)
SearchAbout bool.

Definition partition {X : Type}
                     (test : X -> bool)
                     (l : list X)
                   : list X * list X :=
((filter test l), (filter (fun l => negb (test l))l)).

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity.  Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. reflexivity.  Qed.

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

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

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 (map_rev)  *)
(** Show that [map] and [rev] commute.  You may need to define an
    auxiliary lemma. *)
SearchAbout rev.
SearchAbout app.

Lemma map_rev_app_distr : forall (X Y : Type) (f : X -> Y) (l1 l2 : list X),
 map f (l1 ++ l2) = (map f l1 ++ map f l2).
Proof.
  intros X Y f l1 l2.
  induction l1.
    - reflexivity.
    - simpl. rewrite <-IHl1. reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros X Y f l.
  induction l.
    - reflexivity.
    - simpl. rewrite <-IHl. rewrite -> map_rev_app_distr. reflexivity.
Qed.

(** **** Exercise: 2 stars, 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) :=
  match l with
  |[] => []
  |x::y => f x ++ flat_map f y
end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof. reflexivity. Qed.

(** Lists are not the only inductive type that we can write a
    [map] function for.  Here is the definition of [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, 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. *)

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?

Answer: Y could be defined as a string and fed in steps for an algorithmn. X could represent
      the order that these steps need to be completed in.

    For example: X as nth term and Y as string
    X (string Y)
    1 (Establish a basecase)

*)

(* ================================================================= *)
(** ** 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 (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]. *)

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
  intros X l.
  induction l.
  - reflexivity.
  - simpl. rewrite <- IHl. reflexivity.
Qed.
(** **** Exercise: 3 stars (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 :=
fold(fun x y =>f x::y) l[].

(** Write down a theorem [fold_map_correct] in Coq stating that
   [fold_map] is correct, and prove it. *)

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.
  - reflexivity.
  - simpl. rewrite <- IHl. reflexivity.
Qed.

(** **** 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 :=
  f (fst p) (snd p).

(** 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_map2: map (fun x => plus 3 x) [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.
  intros X Y Z f x y.
  - reflexivity.
Qed.

Theorem curry_uncurry : forall (X Y Z : Type)
                        (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
  intros X Y Z f p.
  induction p.
  - reflexivity.
Qed.

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

  _Theorem: For all lists [l] of type X where n is a position in the list,
          return n as the length of a list of it is long enough. Else return none and it's
          position in the list.

  _Proof: By induction on [l].

  _First, suppose [l = [n]] we must show that the length of [l] is n,
          which follows from the defention of [l] as a list of type X. Each term adds one to
          position n.

  _Next, suppose  [l = []] we must return an error to show the list is too much and lacks
        content. Here n will be assigned 0 to show there is an error at position 0
        indicating an empty list. n + null = []

      We can use an induction hypothesis the list [l] that follows from of definitions of
      nth_error as well as length and [++]. *)

(** **** Exercise: 4 stars, advanced (church_numerals)  *)
(** This exercise explores 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 nat := 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 : nat :=
  fun (X : Type) (f : X -> X) (x : X) => f x.

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

Definition two : nat :=
  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 : nat :=
  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 : nat := @doit3times.

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

(** Successor of a natural number: *)

Definition succ (n : nat) : nat :=
  fun (X : Type) (f : X -> X) (x : X) => (f (n X f x)).

Example succ_1 : succ zero = one.
  Proof. reflexivity. Qed.

Example succ_2 : succ one = two.
  Proof. reflexivity. Qed.

Example succ_3 : succ two = three.
  Proof. reflexivity. Qed.
(** Addition of two natural numbers: *)

Definition plus (n m : nat) : nat :=
  fun (X : Type) (f : X -> X) (x : X) =>  (n X f (m X f x)).

Example plus_1 : plus zero one = one.
  Proof. reflexivity. Qed.

Example plus_2 : plus two three = plus three two.
  Proof. reflexivity. Qed.

Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
  Proof. reflexivity. Qed.

(** Multiplication: *)

Definition mult (n m : nat) : nat :=
fun (X : Type) (f : X -> X) (x : X) => (n X ((m X) f) x).

Example mult_1 : mult one one = one.
  Proof. reflexivity. Qed.

Example mult_2 : mult zero (plus three three) = zero.
  Proof. reflexivity. Qed.

Example mult_3 : mult two three = plus three three.
  Proof. reflexivity. Qed.

(** 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: [nat] itself is usually problematic.) *)

Definition exp (n m : nat) : nat :=
fun (X : Type) (f : X -> X) (x : X) => (m (X->X) (n X) f x).

Example exp_1 : exp two two = plus two two.
  Proof. reflexivity. Qed.

Example exp_2 : exp three two = plus (mult two (mult two two)) one.
  Proof. reflexivity. Qed.

Example exp_3 : exp three zero = one.
  Proof. reflexivity. Qed.

End Church.
(** [] *)

End Exercises.

(** $Date: 2016-05-26 16:17:19 -0400 (Thu, 26 May 2016) $ *)


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype.
From fourcolor Require Import color.

(******************************************************************************)
(*   Chromograms are words representing congruence classes of regions with    *)
(* respect to Kempe inversions for a single edge color and color permutation. *)
(* The relevant topological information for each class consists of a set of   *)
(* non-intersecting chords linking perimeter edges, and the parity of the     *)
(* number of links for each chord. The word representation of these chords is *)
(* a Dyck word augmented with spaces (for perimeter edges that are not linked *)
(* because they are colored with the inversion color) and parities (on        *)
(* closing brackets), each chord being represented with a matching bracket    *)
(* pair.                                                                      *)
(*      chromogram := seq gram_symbol with each gram_symbol one of            *)
(*         Gskip :: no chord (edge has Color1).                               *)
(*         Gpush :: chord start (edge has Color2 or Color3).                  *)
(*         Gpop0 :: odd chord end (end edge has same color as start).         *)
(*         Gpop1 :: even chord end (start and end have different colors)      *)
(* For w : chromogram, lb : bitseq, b : bool and et : colseq, we define       *)
(*  matchg lb et w <=> et is a valid edge coloring trace that matches w in a  *)
(*                     context where there are size lb open chords (started   *)
(*                     but not ended) whose corresponding edge color parities *)
(*                     are rev lb (i.e., if lb is false :: _, then the start  *)
(*                     of last open chord had edge Color2).                   *)
(*  gram_balanced d b w <=> w is balanced in a context with d open chords and *)
(*                     has parity b (i.e., matches colorings with parity b).  *)
(*  Kempe_closed P <=> P : colseq -> Prop is closed under permutations and    *)
(*                     Kempe flips: if (P et) then et matches some chromogram *)
(*                     w in the empty context, such that P holds for all edge *)
(*                     colorings that are permutations of et or that match w. *)
(*  Kempe_coclosure P et <-> P meets all Kempe_closed predicates that hold    *)
(*                     for et.                                                *)
(* --> Being a ring trace in a planar plain cubic map is Kempe_closed; the    *)
(* relation between chromograms and graphs will be developped in kempe.v.     *)
(*   As for edge color traces, we also use partial chromograms, with the last *)
(* (redundant) symbol removed, in addition to complete ones. This is the form *)
(* actually used for the correctness proof of the reducibility check.         *)
(*     cgram d b w == the complete chromogram corresponding to w, i.e., w     *)
(*                    with its last symbol restored, in the context of a      *)
(*                    chromogram prefix with d open chords and parity b.      *)
(*       bit_stack == a simple datatype equivalent to bitseq, with            *)
(*                    constructors Bstack0, Bpush0, and Bpush1. This type     *)
(*                    coerces to bitseq.                                      *)
(* matchpg bs et w <=> the chromogram completion of w matches the trace       *)
(*                    completion of et, in the context of a prefix where the  *)
(*                    colors matching the start of open chords have parities  *)
(*                    rev (bitseq_of_stack bs), respectively.                 *)
(******************************************************************************)

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

Inductive gram_symbol := Gpush | Gskip | Gpop0 | Gpop1.

Definition eqgs s1 s2 :=
  match s1, s2 with
  | Gpush, Gpush => true
  | Gskip, Gskip => true
  | Gpop0, Gpop0 => true
  | Gpop1, Gpop1 => true
  | _, _ => false
  end.

Lemma eqgsP : Equality.axiom eqgs.
Proof. by do 2!case; constructor. Qed.

Canonical gram_symbol_eqMixin := EqMixin eqgsP.
Canonical gram_symbol_eqType := EqType gram_symbol gram_symbol_eqMixin.

Definition chromogram : predArgType := seq gram_symbol.
Canonical chromogram_eqType := [eqType of chromogram].

Fixpoint gram_balanced d b0 (w : chromogram) {struct w} :=
  match w, d with
  | [::], 0 => ~~ b0
  | Gpush :: w', _ => gram_balanced d.+1 b0 w'
  | Gskip :: w', _ => gram_balanced d (~~ b0) w'
  | Gpop0 :: w', d'.+1 => gram_balanced d' b0 w'
  | Gpop1 :: w', d'.+1 => gram_balanced d' (~~ b0) w'
  | _, _ => false
  end.

Fixpoint matchg (lb : bitseq) (et : colseq) (w : chromogram) {struct w} :=
  match w, et, lb with
  | [::], [::], [::] => true
  | s :: w', e :: et', _ =>
      match e, s, lb with
      | Color1, Gskip, _            => matchg lb et' w'
      | Color2, Gpush, _            => matchg (false :: lb) et' w'
      | Color2, Gpop0, false :: lb' => matchg lb' et' w'
      | Color2, Gpop1, true :: lb'  => matchg lb' et' w'
      | Color3, Gpush, _            => matchg (true :: lb) et' w'
      | Color3, Gpop0, true :: lb'  => matchg lb' et' w'
      | Color3, Gpop1, false :: lb' => matchg lb' et' w'
      | _, _, _ => false
      end
  | _, _, _ => false
  end.

Definition Kempe_closed (P : colseq -> Prop) :=
  forall et, P et ->
    [/\ forall g, P (permt g et)
      & exists2 w, matchg [::] et w
              & forall et', matchg [::] et' w -> P et'].

Definition Kempe_coclosure P et :=
  forall P', Kempe_closed P' -> P' et -> exists2 et', P et' & P' et'.

Lemma matchg_size et lb w : matchg lb et w -> size w = size et.
Proof.
elim: et lb w => [|e et IHet] lb [|s w] etMw //=; congr _.+1; case: s etMw.
- by case: e (IHet (cbit0 e :: lb) w).
- by case: e (IHet lb w).
- by case: e lb (IHet (behead lb) w); do 3!case=> //.
by case: e lb (IHet (behead lb) w); do 3!case=> //.
Qed.

Lemma matchg_memc0 et lb w : matchg lb et w -> (Color0 \in et) = false.
Proof.
elim: et lb w => [|e et IHet] lb [|s w] //=; case: s.
- by case: e (IHet (cbit0 e :: lb) w).
- by case: e (IHet lb w).
- by case: e lb (IHet (behead lb) w); do 3!case=> //.
by case: e lb (IHet (behead lb) w); do 3!case=> //.
Qed.

Section BalanceLemmas.

Let sumb : bitseq -> bool := foldr addb false.

Lemma matchg_balanced et w :
    matchg [::] et w ->
  cbit1 (sumt et) = false /\ gram_balanced 0 (cbit0 (sumt et)) w.
Proof.
set sb := [::]; rewrite -[cbit1 _]addFb -[cbit0 _]addFb -{3}[false]/(sumb sb).
rewrite -{1}[false]/(odd 0) -[0]/(size sb).
elim: et sb w => [|e et IHet] lb [|s w] //=; first by case: lb.
rewrite cbit0_addc cbit1_addc 2!addbA -addTb.
rewrite -(addbC (cbit0 e)) -(addbC (cbit1 e)) !addbA.
case: s {IHet}(IHet (cbit0 e :: lb) w) (IHet lb w) (IHet (behead lb) w);
  by case: e => //; case: lb => [|[|] lb] //=; rewrite ?negbK.
Qed.

Lemma balanced_inj w n1 n2 b1 b2 :
  gram_balanced n1 b1 w -> gram_balanced n2 b2 w -> n1 = n2 /\ b1 = b2.
Proof.
by elim: w n1 n2 b1 b2 => [|[|||] w IHw] [|n1] [|n2] [|] [|] //= bal1 bal2;
  case: (IHw _ _ _ _ bal1 bal2) => // /(congr1 succn)[<-].
Qed.

Lemma balanced_sumt0 w et :
  gram_balanced 0 false w -> matchg [::] et w -> sumt et = Color0.
Proof.
rewrite -(ccons_cbits (sumt et)) => balFw /matchg_balanced[-> bal0w].
by have [_ ->] := balanced_inj bal0w balFw.
Qed.

Lemma match_etrace et w : matchg [::] (etrace et) w = matchg [::] et w.
Proof.
set sb := [::]; rewrite -{2}[sb]/(map negb sb) /etrace /etrace_perm.
case (even_trace et); first by rewrite permt_id.
elim: et sb w => [|e et IHet] lb [|s w] //; first by case lb.
by case: e; case: s => //=; first [rewrite IHet | case: lb => [//|[]] /=].
Qed.

(* Algorithmic predicates, for chromogram paths. *)

Inductive bit_stack : Set :=
  | Bstack0
  | Bpush0 (bs : bit_stack)
  | Bpush1 (bs : bit_stack).

Fixpoint bitseq_of_stack (bs : bit_stack) : bitseq :=
  match bs with
  | Bstack0 => [::]
  | Bpush0 bs' => false :: bitseq_of_stack bs'
  | Bpush1 bs' => true :: bitseq_of_stack bs'
  end.

Definition stack_of_bitseq : bitseq -> bit_stack :=
  foldr (fun b => if b then Bpush1 else Bpush0) Bstack0.

Fixpoint cgram d b0 (w : chromogram) {struct w} : chromogram :=
  match w with
  | [::] =>
    [:: if d is 0 then Gskip else if b0 then Gpop1 else Gpop0]
  | s :: w' =>
    s ::  match s with
        | Gpush => cgram d.+1 b0 w'
        | Gskip => cgram d (~~ b0) w'
        | Gpop0 => cgram d.-1 b0 w'
        | Gpop1 => cgram d.-1 (~~ b0) w'
        end
  end.

Fixpoint matchpg (bs : bit_stack) (et : colseq) (w : chromogram) {struct w} :=
  match w, et with
  | [::], [::] => true
  | s :: w', e :: et' =>
      match e, s, bs with
      | Color1, Gskip, _          => matchpg bs et' w'
      | Color2, Gpush, _          => matchpg (Bpush0 bs) et' w'
      | Color2, Gpop0, Bpush0 bs' => matchpg bs' et' w'
      | Color2, Gpop1, Bpush1 bs' => matchpg bs' et' w'
      | Color3, Gpop0, Bpush1 bs' => matchpg bs' et' w'
      | Color3, Gpush, _          => matchpg (Bpush1 bs) et' w'
      | Color3, Gpop1, Bpush0 bs' => matchpg bs' et' w'
      | _, _, _ => false
      end
  | _, _ => false
  end.

Lemma matchg_cgram cw et :
  matchg [::] (ctrace et) cw -> cw = cgram 0 false (take (size cw).-1 cw).
Proof.
move=> etMcw; have [_] := matchg_balanced etMcw; rewrite sumt_ctrace /=.
case: cw etMcw 0 false => [|s w _] /=; first by case et.
elim: w s => [|s' w IHw] s d b0; first by case: s b0 d; do 3!case=> //.
by case: s => //= etMw; congr (_ :: _); apply: IHw; case: d etMw; case b0.
Qed.

Lemma matchg_pg et w : gram_balanced 0 false (cgram 0 false w) ->
  matchg [::] (ctrace et) (cgram 0 false w) = matchpg Bstack0 et w.
Proof.
set sb := [::]; rewrite -[Bstack0]/(stack_of_bitseq sb) /ctrace.
rewrite -(add0c (sumt et)) -[Color0]/(ccons (odd 0) (sumb sb)).
rewrite -(addFb (sumb sb)) -[0]/(size sb).
elim: et sb false w => [|e et IHet] lb b.
  case=> [|s w] /=; first by do 2!case: b lb => [] [|b lb] //.
  move: (size lb) => d _; rewrite addc0.
  by case: (ccons _ _) s w => // [] [] // [] //; case: lb => [|[]].
case=> [|s w]; rewrite ?rcons_cons /=.
  by case: lb => [|b' [|? ?]] // _; case: e => {IHet}//;
     case: et => //; case b; case b'.
by case: s; try (case: lb; [by [] | case=> lb /=]);
  case: e (IHet (cbit0 e :: lb)) => //= IHet0; do 1?[move/IHet | move/IHet0];
  case: (sumt et) (odd _) b (sumb lb) => [] [] [] [].
Qed.

Lemma matchpg_etrace et w :
  matchpg Bstack0 (etrace et) w = matchpg Bstack0 et w.
Proof.
rewrite /etrace /etrace_perm.
case: (even_trace et) => /=; first by rewrite permt_id.
rewrite -[Bstack0]/(stack_of_bitseq [::]) -{1}[[::]]/(map negb [::]).
elim: et [::] w => [|e et IHet] lb [|s w] //.
by case: e (IHet (cbit0 e :: lb) w); case: s => //=; case: lb => [|[]] //=.
Qed.

Lemma matchpg_size et bs w : matchpg bs et w -> size w = size et.
Proof.
elim: et bs w => [|e et IHet] bs [|s w] etMw //=; congr _.+1; case: s etMw.
- by case: e (IHet ((if cbit0 e then Bpush1 else Bpush0) bs) w).
- by case: e (IHet bs w).
- by case: e bs => [] [|bs|bs] // /IHet.
by case: e bs => [] [|bs|bs] // /IHet.
Qed.

Lemma matchpg_flip et :
  matchpg Bstack0 (permt Eperm132 et) =1 matchpg Bstack0 et.
Proof.
rewrite -[Bstack0]/(stack_of_bitseq [::]) -{1}[[::]]/(map negb [::]).
move; elim: et [::] => [|e et IHet] lb [|s w] //.
by case: e (IHet (cbit0 e :: lb) w); case: s => //=; case: lb => [|[]] //=.
Qed.

End BalanceLemmas.


Require Import Arith.
Require Import List.
Require Import ZArith.
Import ListNotations.

Inductive InputVar: Set :=
| input: nat -> InputVar.

Inductive WitnessVar: Set :=
| witness: nat -> WitnessVar.

Inductive ConstantVar: Set :=
| constrant: nat -> nat -> ConstantVar.

Definition Inputs := list InputVar.

Definition Witness := list WitnessVar.

Definition Constants := list ConstantVar.

(*
 * For a simple circuit:
 *     a + b - c = 0
 *     c * d - e = 0
 * we can build the following gates:
 *  ----------------------------------------------------------------
 *  |  advise  | advise  | advise  | selector(add) |  selector(mul) |
 *  ----------------------------------------------------------------
 *  |   a      |    b    |   c     |   1           |                |
 *  -----------------------------------------------------------------
 *  |   c      |    d    |   e     |   0           |   1            |
 *  ----------------------------------------------------------------
 *  with a implicit constraints:
 *         column[2][0] = column[0][1]
 *
 *)

Inductive Column :=
| INSTANCE: Inputs -> Column
| ADVISE: Witness -> Column
| FIXED: Constants -> Column.

Local Open Scope Z_scope.

Inductive Rotation :=
| CUR | NEXT | PREV.

Inductive ColumnCursor :=
| COLUMN_CURSOR: Column -> nat -> Rotation -> ColumnCursor.

Inductive Constraints :=
| APlus: Constraints -> Constraints -> Constraints
| AMinus:  Constraints -> Constraints -> Constraints
| AMul: Constraints -> Constraints -> Constraints
| CTOM: ColumnCursor  -> Constraints
| FTOM: ConstantVar -> Constraints.

Definition Lookup := list (InputVar * Z).

Inductive Assignment :=
| ASSIGNMENT: InputVar -> Z -> option Lookup -> Assignment.

Class Gate { T: Type} { F: Type} :=
  {
    col: list Column;
    cons: Constraints;
    ass: list Assignment
  }.


Require Import coqutil.Map.Interface.
Require Import bedrock2.Semantics.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import bedrock2.FE310CSemantics.
Require Import ZArith.
Require Import exportLogic.interface.

Module NaiveLang <: LanguageSig.
  Definition expr `{parameters} := mem -> Prop.
  Section NaiveLang.
  Context {p: parameters}.
  Definition impp (e1 e2 : mem -> Prop) : mem -> Prop := fun st => e1 st -> e2 st.
  Definition andp (e1 e2 : mem -> Prop) : mem -> Prop := fun st => e1 st /\ e2 st.
  Definition emp: mem -> Prop := bedrock2.Map.Separation.emp True.
  Definition sepcon := @bedrock2.Map.Separation.sep
          (@Interface.word.rep (@width (@semantics_parameters p))
             (@word (@semantics_parameters p)))
          (@Interface.word.rep (Zpos (xO (xO (xO xH))))
             (@byte (@semantics_parameters p))) (@mem (@semantics_parameters p)).
  Definition provable (e : mem -> Prop) := forall st, e st.
  End NaiveLang.
End NaiveLang.

Module NaiveRule.
  Include DerivedNames (NaiveLang).
  Section NaiveRule.
  Context `{parameters}.

  Lemma modus_ponens :
    forall x y : expr, provable (impp x y) -> provable x -> provable y.
  Proof. unfold provable, impp. auto. Qed.

  Lemma axiom1 : forall x y : expr, provable (impp x (impp y x)).
  Proof. unfold provable, impp. auto. Qed.

  Lemma axiom2 : forall x y z : expr,
      provable (impp (impp x (impp y z)) (impp (impp x y) (impp x z))).
  Proof. unfold provable, impp. auto. Qed.

  Lemma andp_intros :
    forall x y : expr, provable (impp x (impp y (andp x y))).
  Proof. unfold provable, impp, andp. auto. Qed.

  Lemma andp_elim1 : forall x y : expr, provable (impp (andp x y) x).
  Proof. unfold provable, impp, andp. tauto. Qed.

  Lemma andp_elim2 : forall x y : expr, provable (impp (andp x y) y).
  Proof. unfold provable, impp, andp. tauto. Qed.

  Lemma sepcon_comm: forall x y, provable (iffp (sepcon x y) (sepcon y x)).
  Proof.
    intros.
    pose proof sep_comm x y.
    exact H0.
  Qed.

  Lemma sepcon_assoc: forall x y z,
    provable (iffp (sepcon x (sepcon y z)) (sepcon (sepcon x y) z)).
  Proof.
    intros.
    pose proof sep_assoc x y z.
    hnf; intros.
    specialize (H0 st).
    unfold iffp, andp, impp.
    tauto.
  Qed.

  Lemma sepcon_mono : (forall x1 x2 y1 y2 : expr, provable (impp x1 x2) -> provable (impp y1 y2) -> provable (impp (sepcon x1 y1) (sepcon x2 y2))) .
  Proof.
    intros.
    apply Proper_sep_impl1; auto.
  Qed.

  Lemma sepcon_emp : (forall x : expr, provable (iffp (sepcon x emp) x)) .
  Proof.
    intros.
    apply sep_emp_True_r.
  Qed.

  End NaiveRule.
End NaiveRule.

Module T := LogicTheorem NaiveLang NaiveRule.
Import T.


Set Universe Polymorphism.

Require Import Trunc Hedberg Int.

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

Module Export Intervalerval.
  Private Inductive Interval : Type :=
  | zeroI : Interval
  | oneI : Interval.

  Axiom seg : zeroI = oneI.

  Definition Interval_ind
             (P: Interval -> Type)
             (b0: P zeroI)
             (b1: P oneI)
             (s : seg # b0 = b1)
  : forall i, P i
    := fun i => match i with
                | zeroI => b0
                | oneI => b1
                end.

   Axiom Interval_ind_seg : forall
             (P: Interval -> Type)
             (b0: P zeroI)
             (b1: P oneI)
             (s : seg # b0 = b1),
  apD (Interval_ind P b0 b1 s) seg = s.

End Intervalerval.

Section Interval_computation.

  Variable i : Interval.
  Variable P : Interval -> Type.
  Variable b0 : P zeroI.
  Variable b1 : P oneI.
  Variable s : seg # b0 = b1.

  Eval cbn in
      Interval_ind P b0 b1 s zeroI.

  Eval cbn in
      Interval_ind P b0 b1 s oneI.

End Interval_computation.

Definition Interval_IsContr : IsContr Interval.
Proof.
  unshelve econstructor.
  - exact zeroI.
  - unshelve refine (Interval_ind _ _ _ _).
    + exact (refl zeroI).
    + exact seg.
    + apply transport_paths_r.
Defined.

Definition transport_const {A B : Type} {x1 x2 : A} (p : x1 = x2) (y : B)
  : transport (fun x => B) p y = y.
Proof.
  destruct p.  exact (refl y).
Defined.

Definition Interval_funext (A : Type)  (B :A -> Type) (f g : forall a, B a):
       f == g -> f = g.
Proof.
  intro p.
  pose (pp := fun x => Interval_ind (fun _ => B x) (f x) (g x) (transport_const _ _ @ p x)).
  pose (q := (fun i x => pp x i) : Interval -> (forall x, B x)).
  exact (ap q seg).
Defined.

Module Export Squash.
  Private Inductive trunc (A : Type) : Type :=
  | tr : A -> trunc A.

  Arguments tr {_} _.

  Axiom trunc_hprop : forall A (a b : trunc A), a = b.

  Definition trunc_rec A B
             (f: A -> B)
             (hprop : IsHProp B)
  : trunc A -> B
    := fun a => match a with
                | tr a => f a
                end.

  Axiom trunc_rec_eq : forall A B
                              (f: A -> B)
                              (hprop : IsHProp B)
                              (a a': trunc A),
      ap (trunc_rec A B f hprop) (trunc_hprop A a a') =
      (IsHProp_to_IsIrr _ hprop _ _).

End Squash.

Definition trunc_ind A
           (P: trunc A -> Type)
           (f: forall a, P (tr a))
           (hprop : forall a, IsHProp (P a))
  : forall a, P a.
Proof.
  intro a. refine (trunc_rec A (P a) _ (hprop a) a).
  intro a'. exact ((trunc_hprop _ _ _) # (f a')).
Defined.

Module Export Circle.
  Private Inductive S1 : Type :=
  | base : S1.

  Axiom loop : base = base.

  Definition S1_ind (P : S1 -> Type)
             (b: P base)
             (l : loop # b = b)
  : forall x, P x
    := fun x => match x with
                | base => b
                end.

  Axiom S1_ind_eq : forall (P : S1 -> Type)
             (b: P base)
             (l : loop # b = b),
      apD (S1_ind P b l) loop = l.

  Definition S1_rec (B : Type)
             (b: B)
             (l : b = b)
  : S1 -> B
    := fun x => match x with
                | base => b
                end.

  Axiom S1_rec_eq : forall B
             (b: B)
             (l : b = b),
      ap (S1_rec B b l) loop = l.

End Circle.

Variable notS: Type.
Variable notSet : not (IsHSet notS).

Definition loop_not_refl : not (loop = refl base).
Proof.
  intro e.
  apply notSet. apply StreicherK_HSet. intros x p.
  pose (S1_rec_eq notS x  p). rewrite e in i. apply inverse. exact i.
Defined.

Module Export Suspension.

  Private Inductive Susp (A:Type) : Type :=
  | N : Susp A
  | S : Susp A.

  Axiom merid : forall A, A -> (N A) = (S A).

  Arguments N {_}.
  Arguments S {_}.
  Arguments merid {_} _.

  Definition Susp_rec A (B : Type)
             (n s: B)
             (m : A -> n = s)
  : Susp A -> B
    := fun x => match x with
                | N => n
                | S => s
                end.

  Axiom Susp_rec_eq : forall A (B : Type)
             (n s: B)
             (m : A -> n = s) a,
      ap (Susp_rec A B n s m) (merid a) = m a.

  Definition Susp_ind A (P : Susp A -> Type)
             (n : P N)
             (s : P S)
             (m : forall a, (merid a) # n = s)
  : forall x, P x
    := fun x => match x with
                | N => n
                | S => s
                end.

  Axiom Susp_ind_eq : forall A (P : Susp A -> Type)
             (n : P N)
             (s : P S)
             (m : forall a, (merid a) # n = s) a,
      apD (Susp_ind A P n s m) (merid a) = m a.

End Suspension.

Definition Susp_bool_S1 : Susp bool ≃ S1.
Proof.
  unshelve econstructor.
  - unshelve refine (Susp_rec bool S1 _ _ _).
    + exact base.
    + exact base.
    + intro b. destruct b.
      * exact (refl _).
      * exact loop.
  - unshelve refine (isequiv_adjointify _ _ _ _).
    + unshelve refine (S1_rec (Susp bool) _ _).
      * exact N.
      * exact (merid false @ (merid true)^).
    + unshelve refine (Susp_ind bool _ _ _ _); cbn.
      * reflexivity.
      * exact (merid true).
      * intro b; destruct b; cbn.
        ** rewrite (transport_paths_Fl (g := id) (merid true) (refl N)).
           rewrite ap_id.
           rewrite ap_compose. rewrite Susp_rec_eq.
           cbn. reflexivity.
        ** rewrite (transport_paths_Fl (g := id) (merid false) (refl N)).
           rewrite ap_id.
           rewrite ap_compose. rewrite Susp_rec_eq.
           rewrite S1_rec_eq. rewrite concat_V. rewrite concat_p1.
           rewrite <- concat_p_pp. rewrite concat_Vp.
           rewrite concat_p1. apply inv2.
    + unshelve refine (S1_ind _ _ _); cbn.
      * reflexivity.
      * rewrite (transport_paths_Fl (g := id) loop (refl base)).
        cbn. rewrite ap_id.
        rewrite ap_compose. rewrite S1_rec_eq.
        repeat rewrite ap_pp. rewrite ap_V.
        rewrite Susp_rec_eq. cbn. rewrite concat_p1.
        rewrite concat_V.
        rewrite inv2. rewrite Susp_rec_eq.
        rewrite <- concat_p_pp. cbn. apply concat_Vp.
Defined.

Definition IsEquiv_id {A : Type} : IsEquiv (fun x:A => x).
  unshelve econstructor.
  - exact id.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Defined.

Definition S1_code : S1 -> Type
  := S1_rec _ Int (path_universe succ_int).

(* Transporting in the codes fibration is the successor autoequivalence. *)

Definition transport_S1_code_loop (z : Int)
  : transport S1_code loop z = succ_int z.
Proof.
  refine ((transport_ap id S1_code loop z)^ @ _).
  unfold S1_code. rewrite S1_rec_eq.
  apply transport_path_universe.
Defined.

Definition transport_S1_code_loopV {funext:Funext} (z : Int)
  : transport S1_code loop^ z = pred_int z.
Proof.
  refine ((transport_ap id S1_code loop^ z) ^@ _).
  rewrite ap_V.
  unfold S1_code; rewrite S1_rec_eq.
  rewrite <- (path_universe_V (funext := funext) succ_int).
  apply transport_path_universe.
Defined.

(* Encode by transporting *)

Definition S1_encode (x:S1) : (base = x) -> S1_code x
  := fun p => p # zero.

(* Decode by iterating loop. *)

Definition S1_decode {funext:Funext}  (x:S1) : S1_code x -> (base = x).
Proof.
  revert x; refine (S1_ind (fun x => S1_code x -> base = x) (loopexp loop) _).
  apply funext; intros z; simpl in z.
  refine (transport_arrow _ _ _ @ _).
  refine (transport_paths_r loop _ @ _).
  rewrite (transport_S1_code_loopV (funext:=funext)).
  destruct z as [[|n] | | [|n]]; simpl.
  rewrite <- concat_p_pp. rewrite concat_Vp. apply concat_p1.
  repeat rewrite <- concat_p_pp. rewrite concat_Vp.
  rewrite concat_p1. reflexivity.
  apply concat_Vp. reflexivity.
  reflexivity.
Defined.

(* The nontrivial part of the proof that decode and encode are equivalences is showing that decoding followed by encoding is the identity on the fibers over [base]. *)

Definition S1_encode_loopexp {funext:Funext} (z:Int)
  : S1_encode base (loopexp loop z) = z.
Proof.
  destruct z as [n | | n]; unfold S1_encode.
  induction n; simpl in *.
  refine (moveR_transport_V _ loop _ _ _).
  apply inverse. apply transport_S1_code_loop.
  rewrite transport_pp.
  refine (moveR_transport_V _ loop _ _ _).
  refine (_ @ (transport_S1_code_loop _)^).
  assumption.
  reflexivity.
  induction n; simpl in *.
  apply transport_S1_code_loop.
  rewrite transport_pp.
  refine (moveR_transport_p _ loop _ _ _).
  refine (_ @ (transport_S1_code_loopV _)^).
  assumption.
  auto.
Defined.

(* Now we put it together. *)

Definition S1_encode_isequiv {funext:Funext} (x:S1) : IsEquiv (S1_encode x).
Proof.
  refine (isequiv_adjointify (S1_encode x) (S1_decode x) _ _).
  (* This side is trivial by path induction. *)
  intros []. cbn. reflexivity.

  (* Here we induct on [x:S1].  We just did the case when [x] is [base]. *)
  refine (S1_ind (fun x => forall x0 : S1_code x, S1_encode x (S1_decode x x0) = x0)
    S1_encode_loopexp _ _).
  (* What remains is easy since [Int] is known to be a set. *)
  apply funext. intros z. apply (hset_int (funext:=funext)).
  Unshelve. all : auto.
Defined.

Definition equiv_loopS1_int {funext:Funext} : (base = base) ≃ Int
:= BuildEquiv _ _ (S1_encode base) (S1_encode_isequiv (funext:=funext) base).

Module Export CylinderHIT.
  Private Inductive Cyl {X Y} (f: X -> Y) : Y -> Type :=
    | top : forall x, Cyl f (f x)
    | base : forall y, Cyl f y.

  Axiom cyl_eq : forall {X Y} {f: X -> Y}, (base f) ∘ f == (top f).

  Global Arguments top {X Y f} x.
  Global Arguments base {X Y f} y.

  Definition Cyl_ind {X Y} {f: X -> Y}
             (P: forall y, Cyl f y -> Type)
             (top': forall x, P (f x) (top x))
             (base': forall y, P y (base y))
             (cyl_eq' : forall x, (cyl_eq x) # (base' (f x)) = top' x)
  : forall y (w: Cyl f y), P y w
    := fun y w => match w with
                  | top x => top' x
                  | base x => base' x
                end.
End CylinderHIT.


Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Math018.

Coq < Require Import Arith.
[Loading ML file z_syntax_plugin.cmxs ... done]
[Loading ML file quote_plugin.cmxs ... done]
[Loading ML file newring_plugin.cmxs ... done]

Coq < Load CpdtTactics.

Coq < Goal forall x, (4 * x) = (2 * x) + (2 * x).
1 subgoal

  ============================
   forall x : nat, 4 * x = 2 * x + 2 * x

Unnamed_thm < crush.
No more subgoals.

Unnamed_thm < Qed.
crush.

Unnamed_thm is defined


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.ProofIrrelevance.

Require Export CatSem.CAT.functor.
Require Export CatSem.CAT.category_hom_transport.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

(** a useful lemma about "Leibniz Equality" for Functors *)
(** two Functors are equal if their data are (extensionally) equal *)

Section Functor_equal.

Variables obC obD: Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable C: Cat_struct morC.
Variable D: Cat_struct morD.

Lemma Functor_Leibniz_equal: forall F G:Functor C D,
   forall (H: forall c, G c = F c ),
   (forall a b (f: morC a b),
          hom_transport (#F f) (H a) (H b) = (#G f))
     -> F = G.
Proof.
  intros F G H H'.
  assert (H0: @Fobj _ _ _ _ _  _ G =
             @Fobj _ _ _ _ _ _ F).
  extensionality x. apply H.

  destruct F as [Fo Fm Fx].
  destruct G as [Go Gm Gx].
  simpl in H0.

  generalize dependent Gm.
  generalize dependent Fm.
  rewrite H0. simpl.
  intros Fm Fx Gm Gx H H1.

  assert (H2: Fm = Gm).
  extensionality a.
  extensionality b.
  extensionality f.
  set (h:= H1 a b f).
  rewrite <- h.
  apply eq_sym; apply hom_transport_id.

  generalize dependent Gx. rewrite <- H2.
  intro Gx.
  rewrite (proof_irrelevance _ Fx Gx).
  auto.
Qed.

(** Properties of Composition and Id wrt "Leibniz Eq"
      - left identity
      - right identity
      - associativity
*)

Section Functor_Leibniz_props.

Variable F: Functor C D.

Lemma IdFl: CompF (Id C) F = F.
Proof.
  assert (H: forall c, (CompF (Id C) F) c = F c);
  cat.

  assert (H': @Fobj _ _ _ _ _ _ (CompF (Id C) F) =
            @Fobj _ _ _ _ _ _ F).
  extensionality x.
  auto.

  apply (@Functor_Leibniz_equal
               (CompF (Id C) F) F H).
  intros a b f.
  assert (Ha := H a).
  assert (Hb := H b).
  generalize Ha; clear Ha.
  generalize Hb; clear Hb.
  unfold CompF. simpl.
  intros Hb Ha.
  rewrite hom_transport_id.
  auto.
Qed.

Lemma IdFr: CompF F (Id D) = F.
Proof.
  assert (H: forall c, (CompF F (Id D)) c = F c);
  cat.

  assert (H': @Fobj _ _ _ _ _ _  (CompF F (Id D)) =
            @Fobj _ _ _ _ _ _      F).
  extensionality x.
  auto.

  apply (@Functor_Leibniz_equal
              (CompF F (Id D)) F H).
  intros a b f.
  assert (Ha := H a).
  assert (Hb := H b).
  generalize Ha; clear Ha.
  generalize Hb; clear Hb.
  unfold CompF.
  simpl.
  intros Hb Ha.
  rewrite hom_transport_id.
  auto.
Qed.

End Functor_Leibniz_props.

End Functor_equal.

Section assoc.

Variables obC obD: Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable C: Cat_struct morC.
Variable D: Cat_struct morD.
(*Variables E E': Category.*)
Variables obE obE': Type.
Variable morE: obE -> obE -> Type.
Variable morE': obE' -> obE' -> Type.
Variable E: Cat_struct morE.
Variable E': Cat_struct morE'.
Variable F : Functor C D.
Variable G: Functor D E.
Variable H: Functor E E'.

Lemma CompFassoc: CompF (CompF F G) H = CompF F (CompF G H).
Proof.
  assert (H': forall c,
    (CompF F (CompF G H)) c =
    (CompF (CompF F G) H) c);
  auto.

  apply (@Functor_Leibniz_equal _ _
         _ _ _ _ _ _ H').
  intros a b f.
  unfold CompF.
  simpl.
  rewrite hom_transport_id.
  auto.
Qed.

End assoc.

(** what is the relation between eq_Functor and Leibniz equality ? *)

(** extensional heterogeneous equality of F and G implies
    Leibniz equality on objects of F and G *)

Section eq_Functor_imp_eq_Fobj.

Variables obC obD: Type.
Variable morC: obC -> obC -> Type.
Variable morD: obD -> obD -> Type.
Variable C : Cat_struct morC.
Variable D : Cat_struct morD.

Variables F G: Functor C D.

Hypothesis H:forall a b (f:morC a b),  #F f === #G f.

Lemma EXT_Functor_imp_ext_Leibniz_Fobj: @Fobj _ _ _ _ _ _ F =
                              @Fobj _ _ _ _ _ _ G.
Proof.
  assert (H': forall x, F x = G x).

  intros x.
  assert (H'' := H (id x)).
  assert (H''' := Equal_hom_src H'').
  auto.

  extensionality x.
  auto.
Qed.

End eq_Functor_imp_eq_Fobj.

Section CompF_Morphism.

Variable obC obD obE: Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable morE : obE -> obE -> Type.
Variable C: Cat_struct morC.
Variable D: Cat_struct morD.
Variable E: Cat_struct morE.

(** Composition of functors is a morphism with respect to
     EXTensional heterogeneous equality of functors *)

Lemma CompF_oid :
            Proper (@EXT_Functor _ _ _ _ C D ==>
                      @EXT_Functor _ _ _ _ D E ==>
                      @EXT_Functor _ _ _ _ C E)
   (@CompF _ _ C _ _ _ _ D E).
Proof.
  unfold Proper.
  repeat red.
  unfold EXT_Functor.
  intros F F' H G G' H1 a b f.
  unfold CompF.
  simpl.

  assert (H0: @Fobj _ _ _ _ _ _ F =
                   @Fobj _ _ _ _ _ _ F').
  apply EXT_Functor_imp_ext_Leibniz_Fobj.
       apply H.

       assert (Hf := H a b f).
       generalize dependent Hf.
       generalize (#F f).
       rewrite H0.
       intros f0 Hf0.
       assert (@Fobj _ _ _ _ _ _ G =
               @Fobj _ _ _ _ _ _ G').
         apply EXT_Functor_imp_ext_Leibniz_Fobj.
         apply H1.
       assert (f0 == #F' f).
         apply Equal_hom_imp_setoideq2.
         auto.

       apply F_equal_helper2;
       auto.
Qed.

End CompF_Morphism.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(* This contribution was updated for Coq V5.10 by the COQ workgroup.        *)
(* January 1995                                                             *)
(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*  utils.v                                                                 *)
(*                                                                          *)
(*  Contains miscellaneous useful definitions and theorems                  *)
(*  used in later proofs and definitions.                                   *)
(*                                                                          *)
(*                                                                          *)
(*  Jill Seaman                                                             *)
(*  Coq V5.8                                                                *)
(*  November  1993                                                          *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                                 utils.v                                  *)
(****************************************************************************)

Require Import syntax.

(********************************************************)
(*							*)
(*   vari_nat:						*)
(*       (m,n:nat)  (x m) = (x n)  --> m = n		*)
(*							*)
(*   valu: a deconstructor for type vari 		*)
(*							*)
(********************************************************)

Definition valu (v : vari) :=
  match v return nat with
  | x n => (* x n *)  n
  end.

Goal forall m n : nat, x m = x n :>vari -> m = n :>nat.
intros m n Q.
replace m with (valu (x m)).
rewrite Q.
simpl in |- *; reflexivity.
simpl in |- *; reflexivity.
Save vari_nat.

(********************************************************)
(*							*)
(*   subty_eq:						*)
(*	(s -> r) = (q -> t)  ---->  s = q /\ r = t	*)
(*							*)
(*   Rator_ty, Rand_ty:  Arrow type destructors giving  *)
(*   the types of the operator and operand respectively.*)
(*							*)
(********************************************************)

Definition Rator_ty (t : ty) :=
  match t with
  | nat_ty => t
  | bool_ty => t
  | arr t0 _ => t0
  end.
Definition Rand_ty (t : ty) :=
  match t with
  | nat_ty => t
  | bool_ty => t
  | arr _ t0 => t0
  end.
Goal
forall s1 t1 s2 t2 : ty,
arr s1 t1 = arr s2 t2 :>ty -> s1 = s2 :>ty /\ t1 = t2 :>ty.
intros s1 t1 s2 t2 Q.
split.
change (Rator_ty (arr s1 t1) = Rator_ty (arr s2 t2) :>ty) in |- *.
apply (f_equal Rator_ty). assumption.
change (Rand_ty (arr s1 t1) = Rand_ty (arr s2 t2) :>ty) in |- *.
apply (f_equal Rand_ty); assumption.
Save subty_eq.

(****************************************)
(* Type properties 			*)
(*     Proof that the type constructors	*)
(*     nat_ty, bool_ty, and arr_ty are	*)
(*     distinct				*)
(****************************************)

Definition is_nat (t : ty) :=
  match t with
  | nat_ty => True
  | bool_ty => False
  | arr _ _ => False
  end.
Definition is_bool (t : ty) :=
  match t with
  | nat_ty => False
  | bool_ty => True
  | arr _ _ => False
  end.
Definition is_arr (t : ty) :=
  match t with
  | nat_ty => False
  | bool_ty => False
  | arr _ _ => True
  end.

Goal nat_ty <> bool_ty :>ty.
red in |- *; intro H; change (is_nat bool_ty) in |- *; elim H; exact I.
Save nat_not_bool.

Goal forall t s : ty, nat_ty <> arr t s :>ty.
red in |- *; intros t s H; change (is_nat (arr t s)) in |- *; elim H; exact I.
Save nat_not_arr.

Goal forall t s : ty, bool_ty <> arr t s :>ty.
red in |- *; intros t s H; change (is_bool (arr t s)) in |- *; elim H;
 exact I.
Save bool_not_arr.

(********************************)
(*         			*)
(*  Xmidvar: 			*)
(*      x=v \/ ~x=v		*)
(*          			*)
(*    	Uses Xmidnat		*)
(*          			*)
(********************************)

	(*************************)
	(* Xmidnat   		 *)
	(*     m=n \/ ~m=n       *)
	(*************************)

	Goal forall m n : nat, m = n \/ m <> n.

	simple induction m.
	simple induction n.
	left; reflexivity.
	intros; right; apply O_S.
	intros y H n; elim n.
	right; red in |- *; intro; apply (O_S y); symmetry  in |- *; assumption.
	intros y0 I.
	elim (H y0); intro E.
	left; elim E; reflexivity.
	right; red in |- *; intro.
	apply E; apply eq_add_S; assumption.
	Save Xmidnat.

(****************)
(*   Xmidvar	*)
(****************)

Goal forall v w : vari, v = w \/ v <> w.

simple induction v.
simple induction w.
intro.
specialize (Xmidnat n n0).
simple induction 1.
intro eq; left; elim eq; reflexivity.
intro neq; right; red in |- *; intro; apply neq.
apply vari_nat; assumption.
Save Xmidvar.

(*****************************************)
(*					 *)
(*  If Properties                        *)
(*				 	 *)
(*  If_T:  (IF A B C) /\ A -> B          *)
(*  If_F:  (IF A B C) /\ not A -> C      *)
(*  T_If:  A /\ B -> (IF A B C)          *)
(*  F_If:  not A /\ C -> (IF A B C)      *)
(*					 *)
(*****************************************)

(*** If_T ***)
Goal forall A B C : Prop, (IF A then B else C) -> A -> B.
unfold IF_then_else in |- *; simple induction 1.
simple induction 1; intros; assumption.
simple induction 1; intros; absurd A; assumption.
Save If_T.

(*** If_F ***)
Goal forall A B C : Prop, (IF A then B else C) -> ~ A -> C.
unfold IF_then_else in |- *; simple induction 1.
simple induction 1; intros; absurd A; assumption.
simple induction 1; intros; assumption.
Save If_F.

(*** T_If ***)
Goal forall A B C : Prop, A -> B -> IF A then B else C.
unfold IF_then_else in |- *; intros.
left; split; assumption.
Save T_If.

(*** F_If ***)
Goal forall A B C : Prop, ~ A -> C -> IF A then B else C.
unfold IF_then_else in |- *; intros.
right; split; assumption.
Save F_If.

(********************************)
(* IfA_IfAIfA:  		*)
(*  IF A then B			*)
(*         else C  ---->	*)
(*  IF A then B 		*)
(*       else IF A then D	*)
(*  		   else C.	*)
(********************************)

Goal
forall A B C D : Prop,
(IF A then B else C) -> IF A then B else (IF A then D else C).

unfold IF_then_else in |- *; simple induction 1.
intro T; left; assumption.
intro F; right; elim F; intros; split.
assumption.
right; split; assumption.
Save IfA_IfAIfA.

(********************************)
(*  AABC_ABC			*)
(*    A\/(D/\C) --> (D->(A\/B))	*)
(*       --> (A \/ (B/\C))	*)
(********************************)

Goal forall A B C D : Prop, A \/ D /\ C -> (D -> A \/ B) -> A \/ B /\ C.

intros A B C D A1 A2.
elim A1.
intro; left; assumption.
simple induction 1; intros DH CH.
specialize A2 with (1 := DH); induction A2.
left; assumption.
right; split; assumption.
Save AABC_ABC.