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

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

Require Export Lists.

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

(** 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 gone back to writing [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 (or "generic")
    versions of all the list-processing functions that we wrote
    before.  Here is [length], for example: *)

(** *** *)

Fixpoint length (X:Type) (l:list X) : nat :=
  match l with
  | nil      => 0
  | cons h t => S (length X t)
  end.

(** Note that the uses of [nil] and [cons] in [match] patterns
    do not require any type annotations: Coq already knows that the list
    [l] contains elements of type [X], so there's no reason to include
    [X] in the pattern.  (More precisely, the type [X] is a parameter
    of the whole definition of [list], not of the individual
    constructors.  We'll come back to this point later.)

    As with [nil] and [cons], we can use [length] by applying it first
    to a type and then to its list argument: *)

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

(** To use our length with other kinds of lists, we simply
    instantiate it with an appropriate type parameter: *)

Example test_length2 :
    length bool (cons bool true (nil bool)) = 1.
Proof. reflexivity.  Qed.

(** *** *)
(** Let's close this subsection 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 X h (app X t l2)
  end.

Fixpoint snoc (X:Type) (l:list X) (v:X) : (list X) :=
  match l with
  | nil      => cons X v (nil X)
  | cons h t => cons X h (snoc X t v)
  end.

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

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

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

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

[] *)

(*  Check d (b a 5). *)
  Check d mumble (b a 5).
  Check d bool (b a 5).
  Check e bool true.
  Check e mumble (b c 0).
(*  Check e bool (b c 0).*)
  Check c.

(** **** Exercise: 2 stars (baz_num_elts) *)
(** Consider the following inductive definition: *)

Inductive baz : Type :=
   | x : baz -> baz
   | y : baz -> bool -> baz.

(** How _many_ elements does the type [baz] have?
[] *)

Theorem no_baz : baz -> False.
Proof.
  intro b; induction b.

  assumption.

  assumption.
Qed.

End MumbleBaz.

(* ###################################################### *)
(** *** Type Annotation Inference *)

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

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

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

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

(** It has exactly the same type type as [app].  Coq was able to
    use a process called _type inference_ to deduce what the types of
    [X], [l1], and [l2] 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 [l1] with [nil] and [cons] means it must be a [list]; 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.  You should try to find a balance in your own code between
    too many type annotations (so many that they 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 *)

(** Whenever 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 [length] function
    above must pass along the type [X].  But just like providing
    explicit type annotations everywhere, this is heavy and verbose.
    Since the second argument to [length] is a list of [X]s, 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 figure out for yourself what
    type 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 -- and,
    indeed, the two procedures rely on the same underlying mechanisms.
    Instead of simply omitting the types of some arguments to a
    function, like
      app' X l1 l2 : list X :=
    we can also replace the types with [_], like
      app' (X : _) (l1 l2 : _) : list X :=
    which tells Coq to attempt to infer the missing information, just
    as with argument synthesis.

    Using implicit arguments, the [length] function can be written
    like this: *)

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

(** In this instance, we don't save much by writing [_] instead of
    [X].  But in many cases the difference can be significant.  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 *)

(** If fact, we can go further.  To avoid having to sprinkle [_]'s
    throughout our programs, we can tell 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.
    *)

Arguments nil {X}.
Arguments cons {X} _ _.  (* use underscore for argument position that has no name *)
Arguments length {X} l.
Arguments app {X} l1 l2.
Arguments rev {X} l.
Arguments snoc {X} l v.

(* note: no _ arguments required... *)
Definition list123'' := cons 1 (cons 2 (cons 3 nil)).
Check (length list123'').

(** *** *)

(** Alternatively, we can declare an argument to be implicit while
    defining the function itself, by surrounding the argument in curly
    braces.  For example: *)

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

(** (Note that we didn't even have to provide a type argument to
    the recursive call to [length'']; indeed, it is invalid to provide
    one.)  We will use this style whenever possible, although we will
    continue to use use explicit [Argument] declarations for
    [Inductive] constructors. *)

(** *** *)

(** 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 this time, even though
    we've globally declared it to be [Implicit].  For example, suppose we
    write this: *)

(* Definition mynil := nil.  *)

(** If we uncomment this definition, Coq will give 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].

Check ([3 + 4] ++ nil).

(* ###################################################### *)
(** *** Exercises: Polymorphic Lists *)

(** **** Exercise: 2 stars, optional (poly_exercises) *)
(** Here are a few simple exercises, just like ones in the [Lists]
    chapter, for practice with polymorphism.  Fill in the definitions
    and complete the proofs below. *)

Fixpoint repeat {X : Type} (n : X) (count : nat) : list X :=
  match count with
    | O => []
    | S count => n :: repeat n count
  end.

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

Theorem nil_app : forall X:Type, forall l:list X,
  app [] l = l.
Proof.
  reflexivity.
Qed.

Theorem rev_snoc : forall X : Type,
                     forall v : X,
                     forall s : list X,
  rev (snoc s v) = v :: (rev s).
Proof.
  intros; induction s.
  reflexivity.
  simpl; rewrite IHs.
  reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  induction l; simpl; intros.
  reflexivity.
  rewrite rev_snoc.
  rewrite IHl.
  reflexivity.
Qed.

Theorem snoc_with_append : forall X : Type,
                         forall l1 l2 : list X,
                         forall v : X,
  snoc (l1 ++ l2) v = l1 ++ (snoc l2 v).
Proof.
induction l1; simpl; intros.
reflexivity.
rewrite IHl1.
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_ (or _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 pair _types_: *)

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

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

(** *** *)
(** A note of caution: 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; [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 many functional programming languages,
    it is called [zip].  We call it [combine] for consistency with
    Coq's standard library. *)
(** Note that the pair notation can be used both in expressions and in
    patterns... *)

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
        Eval compute in (combine [1;2] [false;false;true;true]).
      print?   []
*)

Eval compute in (combine [1;2] [false;false;true;true]).

(** **** Exercise: 2 stars (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
    programing languages, this function is called [unzip].

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

Fixpoint split
           {X Y : Type} (l : list (X*Y))
           : (list X) * (list Y) :=
  match l with
    | [] => ([], [])
    | (x,y) :: l => match split l with
                      | (xs,ys) => (x::xs, y::ys)
                    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_.
    The type declaration generalizes the one for [natoption] in 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 [index] function so that it works
    with any type of lists. *)

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

Example test_index1 :    index 0 [4;5;6;7]  = Some 4.
Proof. reflexivity.  Qed.
Example test_index2 :    index  1 [[1];[2]]  = Some [2].
Proof. reflexivity.  Qed.
Example test_index3 :    index  2 [true]  = None.
Proof. reflexivity.  Qed.

(** **** Exercise: 1 star, optional (hd_opt_poly) *)
(** Complete the definition of a polymorphic version of the
    [hd_opt] function from the last chapter. Be sure that it
    passes the unit tests below. *)

Definition hd_opt {X : Type} (l : list X)  : option X :=
  match l with
    | nil => None
    | x :: _ => Some x
  end.

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

Check @hd_opt.

Example test_hd_opt1 :  hd_opt [1;2] = Some 1.
Proof. reflexivity. Qed.

Example test_hd_opt2 :   hd_opt  [[1];[2]]  = Some [1].
Proof. reflexivity. Qed.

(** [] *)

(* ###################################################### *)
(** * Functions as Data *)
(* ###################################################### *)
(** ** Higher-Order Functions *)

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

    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.

(* ###################################################### *)
(** ** Partial Application *)

(** 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 is the same as saying that Coq primitively
    supports only one-argument functions -- do you see why?)  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.

(* ###################################################### *)
(** ** Digression: Currying *)

(** **** 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 :=
  match p with
    | (x,y) => f x y
  end.

(** (Thought exercise: before running these 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.
  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.
  destruct p; reflexivity.
Qed.

(** [] *)

(* ###################################################### *)
(** ** Filter *)

(** Here is a useful higher-order function, which takes a list
    of [X]s and a _predicate_ on [X] (a function from [X] to [bool])
    and "filters" 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 a little annoying 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. It is also possible to
    construct a function "on the fly" without declaring it at the top
    level or giving it a name; this is analogous to the notation we've
    been using for writing down constant lists, natural numbers, and
    so on. *)

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

(** Here is the motivating example from before, 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 blt_nat.
SearchAbout nat.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun n => andb (evenb n) (ble_nat 7 n)) 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.
*)

Definition partition {X : Type} (test : X -> bool) (l : list X)
                     : list X * list X :=
  (filter test l, filter (fun n => negb (test n)) l).
(*
  match l with
    | nil => []
    | x :: xs => match partition test xs with
                   | (p,n) => if test x
                              then (x :: p, n)
                              else (p, x :: n)
                 end
  end.
*)

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 (plus 3) [2;0;2] = [5;3;5].
Proof. reflexivity.  Qed.

(** The element types of the input and output lists need not be
    the same ([map] takes _two_ type arguments, [X] and [Y]).  This
    version of [map] 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.

(** ** Map for options *)
(** **** Exercise: 3 stars (map_rev) *)
(** Show that [map] and [rev] commute.  You may need to define an
    auxiliary lemma. *)

Lemma map_snoc :
  forall (X Y: Type) (f : X -> Y) x l,
    map f (snoc l x) = snoc (map f l) (f x).
Proof.
  induction l; simpl; intros; congruence.
Qed.

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

(** [] *)

(** **** Exercise: 2 stars (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 :: xs => app (f x) (flat_map f xs)
  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))).
    Here are 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?

when transforming a list into something else

*)

(* ###################################################### *)
(** ** Functions For Constructing Functions *)

(** Most of the higher-order functions we have talked about so
    far take functions as _arguments_.  Now let's look at some
    examples involving _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.

(** *** *)
(** Similarly, but a bit more interestingly, here is a function
    that takes a function [f] from numbers to some type [X], a number
    [k], and a value [x], and constructs a function that behaves
    exactly like [f] except that, when called with the argument [k],
    it returns [x]. *)

Definition override {X: Type} (f: nat->X) (k:nat) (x:X) : nat->X:=
  fun (k':nat) => if beq_nat k k' then x else f k'.

(** For example, we can apply [override] twice to obtain a
    function from numbers to booleans that returns [false] on [1] and
    [3] and returns [true] on all other arguments. *)

Definition fmostlytrue := override (override ftrue 1 false) 3 false.

(** *** *)

Example override_example1 : fmostlytrue 0 = true.
Proof. reflexivity. Qed.

Example override_example2 : fmostlytrue 1 = false.
Proof. reflexivity. Qed.

Example override_example3 : fmostlytrue 2 = true.
Proof. reflexivity. Qed.

Example override_example4 : fmostlytrue 3 = false.
Proof. reflexivity. Qed.

(** *** *)

(** **** Exercise: 1 star (override_example) *)
(** Before starting to work on the following proof, make sure you
    understand exactly what the theorem is saying and can paraphrase
    it in your own words.  The proof itself is straightforward. *)

Theorem override_example : forall (b:bool),
  (override (constfun b) 3 true) 2 = b.
Proof.
  intro b; unfold override; simpl.
  reflexivity.
Qed.
(** [] *)

(** We'll use function overriding heavily in parts of the rest of the
    course, and we will end up needing to know quite a bit about its
    properties.  To prove these properties, though, we need to know
    about a few more of Coq's tactics; developing these is the main
    topic of the next chapter.  For now, though, let's introduce just
    one very useful tactic that will also help us with proving
    properties of some of the other functions we have introduced in
    this chapter. *)

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

(* ###################################################### *)
(** * The [unfold] Tactic *)

(** Sometimes, a proof will get stuck because Coq doesn't
    automatically expand a function call into its definition.  (This
    is a feature, not a bug: if Coq automatically expanded everything
    possible, our proof goals would quickly become enormous -- hard to
    read and slow for Coq to manipulate!) *)

Theorem unfold_example_bad : forall m n,
  3 + n = m ->
  plus3 n + 1 = m + 1.
Proof.
  intros m n H.
(* At this point, we'd like to do [rewrite -> H], since
     [plus3 n] is definitionally equal to [3 + n].  However,
     Coq doesn't automatically expand [plus3 n] to its
     definition. *)
  Abort.

(** The [unfold] tactic can be used to explicitly replace a
    defined name by the right-hand side of its definition.  *)

Theorem unfold_example : forall m n,
  3 + n = m ->
  plus3 n + 1 = m + 1.
Proof.
  intros m n H.
  unfold plus3.
  rewrite -> H.
  reflexivity.  Qed.

(** Now we can prove a first property of [override]: If we
    override a function at some argument [k] and then look up [k], we
    get back the overridden value. *)

Theorem override_eq : forall {X:Type} x k (f:nat->X),
  (override f k x) k = x.
Proof.
  intros X x k f.
  unfold override.
  rewrite <- beq_nat_refl.
  reflexivity.  Qed.

(** This proof was straightforward, but note that it requires
    [unfold] to expand the definition of [override]. *)

(** **** Exercise: 2 stars (override_neq) *)
Theorem override_neq : forall (X:Type) x1 x2 k1 k2 (f : nat->X),
  f k1 = x1 ->
  beq_nat k2 k1 = false ->
  (override f k2 x2) k1 = x1.
Proof.
  unfold override.
  intros.
  rewrite H0.
  rewrite H.
  reflexivity.
Qed.
(** [] *)

(** As the inverse of [unfold], Coq also provides a tactic
    [fold], which can be used to "unexpand" a definition.  It is used
    much less often. *)

(* ##################################################### *)
(** * Additional 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.
  unfold fold_length.
  induction l; simpl; intros; congruence.
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 ys => f x :: ys) l [].

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

Theorem fold_map_correct :
  forall {X Y:Type} (f : X -> Y) (l : list X),
    fold_map f l = map f l.
Proof.
  unfold fold_map; induction l; simpl; intros; congruence.
Qed.

(** [] *)

(* $Date: 2013-09-26 14:40:26 -0400 (Thu, 26 Sep 2013) $ *)


Require Import init.

Require Export analysis_norm.
Require Import norm_continuous.
Require Import analysis_series.
Require Import order_minmax.

(* begin hide *)
Section NormMult.

Context {U} `{
    UP : Plus U,
    UZ : Zero U,
    UN : Neg U,
    UM : Mult U,
    UO : One U,
    UD : Div U,
    @PlusComm U UP,
    @PlusAssoc U UP,
    @PlusLid U UP UZ,
    @PlusRid U UP UZ,
    @PlusLinv U UP UZ UN,
    @PlusRinv U UP UZ UN,
    @MultComm U UM,
    @MultAssoc U UM,
    @Ldist U UP UM,
    @Rdist U UP UM,
    @MultLid U UM UO,
    @MultRid U UM UO,
    @MultLinv U UZ UM UO UD,
    @MultRinv U UZ UM UO UD,
    NotTrivial U,

    SM : ScalarMult real U,
    @ScalarComp real U real_mult SM,
    @ScalarId real U real_one SM,
    @ScalarLdist real U UP SM,
    @ScalarRdist real U real_plus UP SM,
    @ScalarLMult real U UM SM,
    @ScalarRMult real U UM SM,

    UA : AbsoluteValue U,
    @AbsDefinite U UA UZ,
    @AbsNeg U UA UN,
    @AbsTriangle U UA UP,
    @AbsPositive U UA,
    @AbsCauchySchwarz U UA UM,
    @AbsMult U UA UM,
    @AbsScalar U UA SM
}.

Existing Instance abs_metric.
(* end hide *)
Theorem mult_bilinear : bilinear mult.
Proof.
    repeat split.
    -   apply scalar_lmult.
    -   apply scalar_rmult.
    -   apply rdist.
    -   apply ldist.
Qed.

Theorem seq_lim_mult : ∀ xf yf (x y : U), seq_lim xf x → seq_lim yf y →
    seq_lim (λ n, xf n * yf n) (x * y).
Proof.
    intros xf yf x y.
    apply seq_lim_bilinear.
    -   exact mult_bilinear.
    -   unfold cauchy_schwarz.
        apply abs_cs.
Qed.

Theorem continuous_mult : ∀ x (f g : U → U),
    continuous_at f x → continuous_at g x → continuous_at (λ a, f a * g a) x.
Proof.
    intros x f g.
    apply continuous_bilinear.
    -   exact mult_bilinear.
    -   unfold cauchy_schwarz.
        apply abs_cs.
Qed.

Theorem seq_lim_constant : ∀ a x xf, seq_lim xf x →
    seq_lim (λ n, a * xf n) (a * x).
Proof.
    intros a x xf xf_x.
    pose (af (n : nat) := a).
    assert ((λ n, a * xf n) = (λ n, af n * xf n)) as f_eq by reflexivity.
    rewrite f_eq.
    apply seq_lim_mult.
    2: exact xf_x.
    apply constant_seq_lim.
Qed.

Theorem seq_lim_div : ∀ a af, seq_lim af a →
    0 ≠ a → seq_lim (λ n, /(af n)) (/a).
Proof.
    intros a af a_lim a_neq.
    rewrite metric_seq_lim in *.
    intros ε ε_pos.
    assert (0 < |a|) as a_pos.
    {
        split.
        -   apply abs_pos.
        -   intro contr.
            rewrite abs_def in contr.
            contradiction.
    }
    assert (0 < |a|/2) as a2_pos.
    {
        apply half_pos.
        exact a_pos.
    }
    pose proof (a_lim _ a2_pos) as [N1 a_pos'].
    assert (∃ D, 0 < D ∧ ∀ n, N1 ≤ n → D < |af n|) as [D [D_pos af_pos]].
    {
        exists (|a|/2).
        split.
        1: exact a2_pos.
        intros n n_gt.
        specialize (a_pos' n n_gt).
        cbn in a_pos'.
        apply (le_lt_trans (abs_reverse_tri _ _)) in a_pos'.
        rewrite abs_minus in a_pos'.
        apply (le_lt_trans (abs_le_neg _)) in a_pos'.
        rewrite neg_plus, neg_neg in a_pos'.
        apply lt_plus_llmove in a_pos'.
        rewrite neg_neg in a_pos'.
        apply lt_plus_rrmove in a_pos'.
        rewrite <- (plus_half (|a|)) in a_pos' at 1.
        rewrite plus_rrinv in a_pos'.
        exact a_pos'.
    }
    clear a_pos'.
    pose proof (lt_mult (lt_mult ε_pos a_pos) D_pos) as ε'_pos.
    specialize (a_lim _ ε'_pos) as [N2 a_lim].
    exists (max N1 N2).
    intros n n_gt.
    specialize (a_lim n (trans (rmax _ _) n_gt)).
    specialize (af_pos n (trans (lmax _ _) n_gt)).
    cbn in *.
    pose proof (trans D_pos af_pos) as afn_pos.
    assert (zero ≠ af n) as afn_nz.
    {
        intro contr.
        rewrite <- contr in afn_pos.
        rewrite abs_zero in afn_pos.
        destruct afn_pos; contradiction.
    }
    apply lt_div_pos in af_pos; try assumption.
    rewrite abs_div in af_pos by exact afn_nz.
    apply lt_mult_rrmove_pos in a_lim.
    2: exact D_pos.
    destruct af_pos as [af_pos C0]; clear C0.
    apply le_lmult_pos with (|af n - a|) in af_pos.
    2: apply abs_pos.
    rewrite abs_minus in a_lim.
    pose proof (le_lt_trans af_pos a_lim) as eq.
    apply lt_mult_rrmove_pos in eq.
    2: exact a_pos.
    rewrite abs_div in eq by exact a_neq.
    do 2 rewrite <- abs_mult in eq.
    do 2 rewrite rdist in eq.
    do 2 rewrite mult_lneg in eq.
    rewrite (mult_comm a), <- mult_assoc in eq.
    rewrite mult_lrinv in eq by exact afn_nz.
    rewrite mult_rrinv in eq by exact a_neq.
    exact eq.
Qed.

Theorem seq_lim_zero_mult : ∀ an bn, seq_norm_bounded an → seq_lim bn 0 →
    seq_lim (λ n, an n * bn n) 0.
Proof.
    intros an bn [M M_bound] bn_zero.
    classic_case (0 = M) as [M_z|M_nz].
    {
        subst M.
        assert ((λ n, an n * bn n) = (λ n, 0)) as eq.
        {
            apply functional_ext.
            intros n.
            specialize (M_bound n).
            apply (antisym (abs_pos _)) in M_bound.
            rewrite abs_def in M_bound.
            rewrite <- M_bound.
            apply mult_lanni.
        }
        rewrite eq.
        apply constant_seq_lim.
    }
    assert (0 < M) as M_pos.
    {
        split; [>|exact M_nz].
        apply (trans2 (M_bound 0)).
        apply abs_pos.
    }
    rewrite metric_seq_lim in *.
    intros ε ε_pos.
    pose proof (div_pos M_pos) as M'_pos.
    pose proof (lt_mult ε_pos M'_pos) as ε'_pos.
    specialize (bn_zero _ ε'_pos) as [N bn_zero].
    exists N.
    intros n n_geq.
    specialize (bn_zero n n_geq).
    cbn in *.
    rewrite plus_lid in *.
    rewrite abs_neg in *.
    rewrite abs_mult.
    specialize (M_bound n).
    apply le_rmult_pos with (|bn n|) in M_bound; [>|apply abs_pos].
    apply (le_lt_trans M_bound).
    rewrite lt_mult_llmove_pos by exact M_pos.
    rewrite mult_comm.
    exact bn_zero.
Qed.

Theorem seq_lim_zero_mult2 : ∀ an bn x, seq_lim an x → seq_lim bn 0 →
    seq_lim (λ n, an n * bn n) 0.
Proof.
    intros an bn x anx bn0.
    apply seq_lim_zero_mult; [>|exact bn0].
    apply converges_bounded.
    exists x.
    exact anx.
Qed.
(* begin hide *)
End NormMult.
(* end hide *)


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

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

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

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

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint half (half_arg0 : natural) : natural
           := match half_arg0 with
              | Zero => Zero
              | Succ Zero => Zero
              | Succ (Succ n) => Succ (half n)
              end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Lemma lem3: forall l, append l Nil = l.
Proof.
induction l.
  - simpl. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem2: forall l1 l2 n, Succ (len (append l1 l2)) = len (append l1 (Cons n l2)).
Proof.
induction l1.
- intros. simpl. rewrite <- IHl1. reflexivity.
- intros. reflexivity.
Qed.

Lemma lem: forall l1 l2, len (append l1 l2) = len (append l2 l1).
Proof. induction l1.
  - intros. simpl. rewrite IHl1. rewrite <- lem2. reflexivity.
  - intros. simpl. rewrite lem3. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (half (len (append x y))) (half (len (append y x))).
Proof.
intros.  f_equal. lfind.
Admitted.


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

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> lst .

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

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

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

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

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

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (append (rev x) y)) (append (rev y) x).
Proof.
   induction x.
   - intros. simpl. rewrite append_nil. reflexivity.
   - intros. simpl. rewrite append_assoc. rewrite IHx. simpl.
     lfind. Admitted.


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

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

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

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint even (even_arg0 : natural) : bool
           := match even_arg0 with
              | Zero => true
              | Succ n => negb (even n)
              end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Lemma lem: forall l1 l2 n, negb (even (len (append l1 l2))) = even (len (append l1 (Cons n l2))).
Proof.
induction l1.
  - intros. simpl. rewrite (IHl1 l2 n0). reflexivity.
  - intros. simpl. reflexivity.
Qed.

Lemma lem3: forall l, append l Nil = l.
Proof.
induction l.
  - simpl. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (even (len (append x y))) (even (len (append y x))).
Proof.
induction x.
  - intros. simpl. lfind. Admitted.


(** congtr.v *)

Require Import Coq.Classes.Equivalence.

(* Group I. *)

Axiom Point: Type.

Axiom Line: Type.

Axiom EqL: Line -> Line -> Prop.

Axiom EqL_Equiv: Equivalence EqL.

Axiom Incid: Point -> Line -> Prop.

Axiom Incid_morphism: forall P l m,
    Incid P l -> EqL l m -> Incid P m.

Axiom Incid_dec: forall P l,
    Incid P l \/ ~Incid P l.

Axiom eq_dec_pointsH: forall A B: Point,
    A = B \/ A <> B.

(* Postulate I.1 *)
Axiom line_existence: forall A B,
    A <> B -> exists l, Incid A l /\ Incid B l.

(* Postulate I.2 *)
Axiom line_uniqueness: forall A B l m,
    A <> B ->
    Incid A l -> Incid B l ->
    Incid A m -> Incid B m ->
    EqL l m.

(* Postulate I.3 *)
Axiom two_points_on_line: forall l,
    { A: Point & { B | Incid B l /\ Incid A l /\ A <> B } }.

Definition ColH A B C :=
  exists l, Incid A l /\ Incid B l /\ Incid C l.

(* Postulate I.4 *)
Axiom l0: Line.
Axiom P0: Point.
Axiom lower_dim: ~ Incid P0 l0.

(* Group II. *)

Axiom BetH: Point -> Point -> Point -> Prop.

Axiom between_diff: forall A B C,
    BetH A B C -> A <> C.

(* Postulate II.1, collinearity *)
Axiom between_col: forall A B C,
    BetH A B C -> ColH A B C.

(* Postulate II.1, commucommutativity *)
Axiom between_comm: forall A B C,
    BetH A B C -> BetH C B A.

(* Postulate II.2 *)
Axiom between_out: forall A B,
    A <> B -> exists C, BetH A B C.

(* Postulate II.3 *)
Axiom between_only_one: forall A B C,
    BetH A B C -> ~BetH B C A.

Definition cut l A B :=
  ~Incid A l /\ ~Incid B l /\ exists I, Incid I l /\ BetH A I B.

(* Postulate II.4 *)
Axiom pasch: forall A B C l,
    ~ColH A B C -> ~Incid C l -> cut l A B -> cut l A C \/ cut l B C.

(* Group III. *)

Axiom CongH: Point -> Point -> Point -> Point -> Prop.

Axiom conf_permr: forall A B C D,
    CongH A B C D -> CongH A B D C.

Definition outH P A B :=
  BetH P A B \/ BetH P B A \/ (P <> A /\ A = B).

(* Postulate III.1 *)
Axiom cong_existence:
  forall A B A' P l,
    A <> B -> A' <> P -> Incid A' l -> Incid P l ->
    exists B', Incid B' l /\ outH A' P B' /\ CongH A' B' A B.

(* Postulate III.2 *)
Axiom cong_pseudo_transitivity:
  forall A B C D E F,
    CongH A B C D -> CongH A B E F -> CongH C D E F.

Definition disjoint A B C D :=
  ~exists P, BetH A P B /\ BetH C P D.

(* Postulate III.3 *)
Axiom addition: forall A B C A' B' C',
    ColH A B C -> ColH A' B' C' ->
    disjoint A B B C -> disjoint A' B' B' C' ->
    CongH A B A' B' -> CongH B C B' C' ->
    CongH A C A' C'.

Axiom CongaH: Point -> Point -> Point -> Point -> Point -> Point -> Prop.

Axiom conga_refl: forall A B C,
    ~ColH A B C -> CongaH A B C A B C.

Axiom conga_comm: forall A B C,
    ~ColH A B C -> CongaH A B C C B A.

Axiom congaH_permlr: forall A B C D E F,
    CongaH A B C D E F -> CongaH C B A F E D.

Definition same_side A B l := exists P, cut l A P /\ cut l B P.

Definition same_side' A B X Y :=
  X <> Y /\ forall l, Incid X l -> Incid Y l -> same_side A B l.

Axiom congaH_outH_congaH: forall A B C D E F A' C' D' F',
    CongaH A B C D E F ->
    outH B A A' -> outH B C C' ->
    outH E D D' -> outH E F F' ->
    CongaH A' B C' D' E F'.

Axiom cong_4_existence: forall A B C O X P,
    ~ColH P O X -> ~ColH A B C ->
    exists Y, CongaH A B C X O Y /\ same_side' P Y O X.

Axiom cong_4_uniqueness: forall A B C O P X Y Y',
    ~ColH P O X -> ~ColH A B C ->
    CongaH A B C X O Y -> CongaH A B C X O Y' ->
    same_side' P Y O X -> same_side' P Y' O X ->
    outH O Y Y'.

(* Postulate III.5 *)
Axiom cong_5: forall A B C A' B' C',
    ~ColH A B C -> ~ColH A' B' C' ->
    CongH A B A' B' -> CongH A C A' C' ->
    CongaH B A C B' A' C' ->
    CongaH A B C A' B' C'.

(* Congruence of triangles *)

Definition Cong_3 A B C A' B' C' :=
  CongH A B A' B' /\ CongH B C B' C' /\ CongH C A C' A'.

Proposition sas_congr: forall A B C A' B' C',
    CongH A B A' B' -> CongaH A B C A' B' C' -> CongH B C B' C' ->
    Cong_3 A B C A' B' C'.
Proof.
  intros A B C A' B' C' Hab Hang Hbc. unfold Cong_3.
  split. apply Hab.
  split. apply Hbc.
  apply (addition )


Require Import init.

Require Export list_base.
Require Export list_in.
Require Export list_nat.
Require Export list_fold.
Require Import nat.

Require Import relation.

Set Implicit Arguments.

Definition list_permutation {U} (l1 l2 : list U) :=
    ∀ x, list_count l1 x = list_count l2 x.

Theorem list_perm_nil {U} : list_permutation (U := U) [] [].
Proof.
    intros x.
    cbn.
    reflexivity.
Qed.

Theorem list_perm_skip {U} : ∀ (x : U) l l', list_permutation l l' →
    list_permutation (x ꞉ l) (x ꞉ l').
Proof.
    intros x l1 l2 eq.
    intros a.
    cbn.
    apply lplus.
    apply eq.
Qed.

Theorem list_perm_swap {U} : ∀ (x y : U) l, list_permutation (y ꞉ x ꞉ l) (x ꞉ y ꞉ l).
Proof.
    intros x y l n.
    do 4 rewrite list_count_add.
    do 2 rewrite plus_assoc.
    apply rplus.
    apply plus_comm.
Qed.

Theorem list_perm_trans {U} {l l' l'' : list U} :
    list_permutation l l' → list_permutation l' l'' →
    list_permutation l l''.
Proof.
    intros eq1 eq2 n.
    rewrite eq1.
    apply eq2.
Qed.

Theorem list_perm_refl {U} : ∀ l : list U, list_permutation l l.
Proof.
    intros l x.
    reflexivity.
Qed.

Theorem list_perm_sym {U} : ∀ al bl : list U,
    list_permutation al bl → list_permutation bl al.
Proof.
    intros al bl eq.
    intros n.
    symmetry.
    apply eq.
Qed.

Theorem list_perm_trans2 {U} (l l' l'' : list U) :
    list_permutation l' l'' → list_permutation l l' →
    list_permutation l l''.
Proof.
    intros eq1 eq2.
    apply (list_perm_trans eq2 eq1).
Qed.

Theorem list_perm_nil_eq {U} : ∀ l : list U,
    list_permutation list_end l → list_end = l.
Proof.
    intros l l_eq.
    destruct l as [|a l]; [>reflexivity|].
    specialize (l_eq a).
    rewrite list_count_add_eq in l_eq.
    inversion l_eq.
Qed.

Theorem list_perm_lpart {U} : ∀ (al bl cl : list U),
    list_permutation al bl → list_permutation (al + cl) (bl + cl).
Proof.
    intros al bl cl eq n.
    do 2 rewrite list_count_conc.
    apply rplus.
    apply eq.
Qed.

Theorem list_perm_conc {U} : ∀ al bl : list U,
    list_permutation (al + bl) (bl + al).
Proof.
    intros al bl n.
    do 2 rewrite list_count_conc.
    apply plus_comm.
Qed.

Theorem list_perm_rpart {U} : ∀ (al bl cl : list U),
    list_permutation bl cl → list_permutation (al + bl) (al + cl).
Proof.
    intros al bl cl eq n.
    do 2 rewrite list_count_conc.
    apply lplus.
    apply eq.
Qed.

Theorem list_perm_split {U} : ∀ l1 l2 (x : U),
    list_permutation (l1 + x ꞉ l2) (x ꞉ (l1 + l2)).
Proof.
    intros l1 l2 a x.
    rewrite list_count_add.
    do 2 rewrite list_count_conc.
    rewrite list_count_add.
    do 2 rewrite plus_assoc.
    apply rplus.
    apply plus_comm.
Qed.

Theorem list_perm_add_eq {U} : ∀ (a : U) l1 l2,
    list_permutation (a ꞉ l1) (a ꞉ l2) → list_permutation l1 l2.
Proof.
    intros a l1 l2 eq x.
    specialize (eq x).
    cbn in eq.
    apply plus_lcancel in eq.
    exact eq.
Qed.

Theorem list_perm_conc_lcancel {U} : ∀ (l1 l2 l3 : list U),
    list_permutation (l1 + l2) (l1 + l3) → list_permutation l2 l3.
Proof.
    intros a l1 l2 eq x.
    specialize (eq x).
    cbn in eq.
    do 2 rewrite list_count_conc in eq.
    apply plus_lcancel in eq.
    exact eq.
Qed.

Theorem list_perm_conc_rcancel {U} : ∀ (l1 l2 l3 : list U),
    list_permutation (l2 + l1) (l3 + l1) → list_permutation l2 l3.
Proof.
    intros a l1 l2 eq x.
    specialize (eq x).
    cbn in eq.
    do 2 rewrite list_count_conc in eq.
    apply plus_rcancel in eq.
    exact eq.
Qed.

Theorem list_in_unique_perm {U} : ∀ al bl : list U,
    list_unique al → list_unique bl → (∀ x, in_list al x ↔ in_list bl x) →
    list_permutation al bl.
Proof.
    intros al bl al_uni bl_uni x_in n.
    classic_case (in_list al n) as [n_in|n_nin].
    -   pose proof n_in as n_in'.
        apply x_in in n_in.
        rewrite (list_count_in_unique _ _ al_uni n_in').
        rewrite (list_count_in_unique _ _ bl_uni n_in).
        reflexivity.
    -   pose proof n_nin as n_nin'.
        rewrite x_in in n_nin'.
        apply list_count_nin in n_nin, n_nin'.
        rewrite <- n_nin, <- n_nin'.
        reflexivity.
Qed.

Theorem list_perm_in {U} : ∀ al bl : list U,
    list_permutation al bl → (∀ x, in_list al x ↔ in_list bl x).
Proof.
    intros al bl eq x.
    specialize (eq x).
    split; intros x_in.
    -   rewrite list_count_in in x_in.
        rewrite eq in x_in.
        rewrite <- list_count_in in x_in.
        exact x_in.
    -   rewrite list_count_in in x_in.
        rewrite <- eq in x_in.
        rewrite <- list_count_in in x_in.
        exact x_in.
Qed.

Theorem list_split_perm {U} : ∀ l (a : U), in_list l a → ∃ l',
    list_permutation l (a ꞉ l').
Proof.
    intros l a a_in.
    pose proof (in_list_split a_in) as [l1 [l2 l_eq]].
    rewrite l_eq.
    exists (l1 + l2).
    apply list_perm_split.
Qed.

Theorem list_perm_single {U} : ∀ (x : U) l, list_permutation [x] l → l = [x].
Proof.
    intros x l l_perm.
    assert (in_list [x] x) as x_in by (left; reflexivity).
    apply (list_perm_in l_perm) in x_in.
    apply in_list_split in x_in as [l1 [l2 eq]]; subst l.
    pose proof (list_perm_split l1 l2 x) as eq.
    pose proof (list_perm_trans l_perm eq) as eq2.
    apply list_perm_add_eq in eq2.
    apply list_perm_nil_eq in eq2.
    destruct l1.
    -   rewrite list_conc_lid.
        rewrite list_conc_lid in eq2.
        destruct l2.
        +   reflexivity.
        +   inversion eq2.
    -   inversion eq2.
Qed.

Theorem list_perm_reverse {U} : ∀ l : list U,
    list_permutation l (list_reverse l).
Proof.
    intros l x.
    apply list_count_reverse.
Qed.


Require Export XR_Rmult_lt_0_compat.
Require Export XR_Rle.

Local Open Scope R_scope.

Lemma Rmult_le_pos : forall r1 r2,
  R0 <= r1 ->
  R0 <= r2 ->
  R0 <= r1 * r2.
Proof.
  intros x y hx hy.
  unfold "<=" in hx.
  destruct hx as [ hx | heq ].
  {
    unfold "<=" in hy.
    destruct hy as [ hy | heq ].
    {
      unfold "<=".
      left.
      apply Rmult_lt_0_compat.
      { exact hx. }
      { exact hy. }
    }
    {
      subst y.
      rewrite Rmult_0_r.
      unfold "<=".
      right.
      reflexivity.
    }
  }
  {
    subst x.
    rewrite Rmult_0_l.
    unfold "<=".
    right.
    reflexivity.
  }
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e521m1_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e369m25_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e165m25_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


(* -*- mode: coq; mode: visual-line -*- *)

(** * Spectra *)

Require Import HoTT.Basics HoTT.Types.
Require Import Pointed.

Local Open Scope nat_scope.
Local Open Scope path_scope.
Local Open Scope equiv_scope.
Local Open Scope pointed_scope.

(** ** Basic Definitions of Spectra *)

Record Prespectrum :=
  { deloop :> nat -> pType
    ; glue : forall n, deloop n ->* loops (deloop (n .+1)) }.

Class IsSpectrum (E : Prespectrum) :=
  is_equiv_glue : forall n, IsEquiv (glue E n).

Global Existing Instance is_equiv_glue.

Definition equiv_glue (E : Prespectrum) `{IsSpectrum E}
: forall n, E n <~>* loops (E n.+1)
  := fun n => Build_pEquiv _ _ (glue E n) _.

Record Spectrum :=
  { to_prespectrum :> Prespectrum
    ; to_is_spectrum : IsSpectrum to_prespectrum }.

Global Existing Instance to_is_spectrum.

(** ** Truncations of spectra *)

Definition strunc `{Univalence} (k : trunc_index) (E : Spectrum) : Spectrum.
Proof.
  simple refine (Build_Spectrum (Build_Prespectrum (fun n => pTr (trunc_index_inc k n) (E n)) _) _).
  - intros n.
    exact ((ptr_loops _ (E n.+1)) o*E (ptr_pequiv _ (equiv_glue E n))).
  - intros n. unfold glue.
    srapply isequiv_compose.
Defined.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e206m5_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e158m15_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e165m25_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e382m105_6limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e338m15_11limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


(** This file contains the examples from the paper:

MoSeL: A General, Extensible Modal Framework for Interactive Proofs in
Separation Logic
Robbert Krebbers, Jacques-Henri Jourdan, Ralf Jung, Joseph Tassarotti,
Jan-Oliver Kaiser, Amin Timany, Arthur Charguéraud, Derek Dreyer
ICFP 2018 *)
From iris.bi Require Import monpred.
From iris.proofmode Require Import tactics monpred.

Unset Mangle Names.

Lemma example_1 {PROP : bi} {A : Type} (P : PROP) (Φ Ψ : A → PROP) :
  P ∗ (∃ a, Φ a ∨ Ψ a) -∗ ∃ a, (P ∗ Φ a) ∨ (P ∗ Ψ a).
Proof.
  iIntros "[HP H]". Show.
  iDestruct "H" as (x) "[H1|H2]".
  - Show. iExists x. iLeft. iSplitL "HP"; iAssumption.
  - Show. iExists x. iRight. iSplitL "HP"; iAssumption.
Qed.
Lemma example {PROP : bi} {A : Type} (P : PROP) (Φ Ψ : A → PROP) :
P ∗ (∃ a, Φ a ∨ Ψ a) -∗ ∃ a, (P ∗ Φ a) ∨ (P ∗ Ψ a).
Proof.
  iIntros "[HP H]". Show.
  iFrame "HP". Show.
  iAssumption.
Qed.

Lemma example_2 {PROP : bi} {A : Type} (P : PROP) (Φ Ψ : A → PROP) :
  <affine> P ∗ (∃ a, Φ a ∨ Ψ a) -∗ ∃ a, Φ a ∨ (P ∗ Ψ a).
Proof.
  iIntros "[HP H]". iDestruct "H" as (x) "[H1|H2]".
  - iExists x. iLeft. Show. iAssumption.
  - iExists x. iRight. Show. iSplitL "HP"; iAssumption.
Qed.

Lemma example_3 {PROP : bi} {A : Type} (P : PROP) (Φ Ψ : A → PROP) :
  □ P ∗ (∃ a, Φ a ∨ Ψ a) -∗ ∃ a, Φ a ∨ (P ∗ P ∗ Ψ a).
Proof.
  iIntros "[#HP H]". Show. iDestruct "H" as (x) "[H1|H2]".
  - iExists x. iLeft. iAssumption.
  - iExists x. iRight. Show. iSplitR; [|iSplitR]; iAssumption.
Qed.
Lemma example_4 {PROP : bi} {A : Type} (P Q : PROP) : □ P ∧ □ Q -∗ □ (P ∗ Q).
Proof. iIntros "[#HP #HQ]". Show. iModIntro. iSplitL; iAssumption. Qed.

Lemma example_monpred {I PROP} (Φ Ψ : monPred I PROP) : Φ ∗ (Φ -∗ Ψ) ⊢ Ψ.
Proof. iIntros "[H1 H2]". Show. iApply "H2". iAssumption. Qed.

Lemma example_monpred_model {I PROP} (Φ Ψ : monPred I PROP) : Φ ∗ (Φ -∗ Ψ) ⊢ Ψ.
Proof. iStartProof PROP. Show. iIntros (i) "[H1 H2]". iApply "H2". iAssumption. Qed.

Lemma example_monpred_2 {I PROP} (Φ : monPred I PROP) (P Q : PROP) :
  ⎡ P -∗ Q ⎤ -∗ ⎡ □ P ⎤ -∗ <affine> Φ -∗ ⎡ P ∗ Q ⎤.
Proof. iIntros "H1 #H2 H3". Show. iFrame "H2". Show. iApply "H1". iAssumption. Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable rE_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable per_ : Universe -> Universe -> Universe -> Prop.
Variable cR_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defrectangle_1 : (forall A B C D : Universe, (rE_ A B C D -> (per_ D A B /\ (per_ A B C /\ (per_ B C D /\ (per_ C D A /\ cR_ A C B D)))))).
Variable defrectangle2_2 : (forall A B C D : Universe, ((per_ D A B /\ (per_ A B C /\ (per_ B C D /\ (per_ C D A /\ cR_ A C B D)))) -> rE_ A B C D)).
Variable defcross_3 : (forall A B C D : Universe, (exists X : Universe, (cR_ A B C D -> (betS_ A X B /\ betS_ C X D)))).
Variable defcross2_4 : (forall A B C D X : Universe, ((betS_ A X B /\ betS_ C X D) -> cR_ A B C D)).
Variable axiom_betweennesssymmetry_5 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).

Theorem lemma_rectanglerotate_6 : (forall A B C D : Universe, (rE_ A B C D -> rE_ B C D A)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import List.
Import ListNotations.

(** Basic table-top blocks manipulation demonstration. *)
Parameter (Block:Type).

(** First define a type to capture the language used to describe the
   world. These are the propositions that apply to our domain. *)
Module BlockProp.
Inductive BlockProp : Type :=
| on    : Block -> Block -> BlockProp
| table : Block -> BlockProp
| clear : Block -> BlockProp
| holds : BlockProp
| empty : BlockProp.
End BlockProp.

Require Import Sig.
Module BlockSig <: Sig.
Definition A := BlockProp.BlockProp.
End BlockSig.

(** Instantiate the linear logic connectives over our langauge. *)
Require Context.
Module BlocksWorld := Context.Context BlockSig.
Import BlocksWorld.

(** Define linear logic propositions for the terms of our language. *)
Definition on X Y : LinProp := Term (BlockProp.on X Y).
Definition table X : LinProp := Term (BlockProp.table X).
Definition clear X : LinProp := Term (BlockProp.clear X).
Definition holds : LinProp := Term BlockProp.holds.
Definition empty : LinProp := Term BlockProp.empty.

(** Define the actions our system is capable of. *)
Axiom newBlock : [empty] ⊢ holds.
Axiom put : forall X Y, [holds] ⊢ empty ⊗ clear X ⊗ (table X & clear Y ⊸ on X Y).
Axiom get : forall X Y,
  [empty, clear X] ⊢ holds ⊗ (table X ⊸ One & on X Y ⊸ clear Y).

(** An example table-top manipulation task. *)

(** Start with an empty gripper, and block [X] on top of block [Y]. We
    take block [X], put it on the table, then get block [Z] and put it
    on top of block [Y]. *)
Theorem test1 : forall X Y Z, [empty, clear X, on X Y] ⊢ on Z Y ⊗ ⊤.
Proof. intros.
  break_context_at 2.
  apply Cut with (B:=holds⊗(table X ⊸ One & on X Y ⊸ clear Y)).
  apply get.
  apply context_app_comm.
  apply Cut with (B:=holds⊗(on X Y ⊸ clear Y)).
  apply product_as_context.
  break_context_at 1.
  timesIntro; [|withElimR]; refl.
  apply product_app_as_context. simpl.
  match goal with
  |- [?A,?B,?C] ⊢ _ => permute_context [A,C,B]
  end.
  break_context_at 2.
  apply Cut with (B:=clear Y).
  break_context_at 1; apply context_app_comm.
  impliesElim; refl.
  apply Cut with (B:=empty ⊗ clear Z ⊗ (table Z & clear Y ⊸ on Z Y)).
  apply put. product_to_context.
  permute_context ([table Z & clear Y ⊸ on Z Y]++[clear Y, empty, clear Z]).
  apply Cut with (B:=clear Y ⊸ on Z Y).
  withElimR; refl.
  simpl.
  permute_context ([clear Y ⊸ on Z Y, clear Y]++[empty, clear Z]).
  apply Cut with (B:=on Z Y).
  break_context_at 1.
  impliesElim; refl.
  simpl.
  permute_context ([on Z Y] ++ [empty, clear Z]).
  timesIntro. refl. topIntro.
Qed.


(** **********************************************************

Anthony Bordg (May 2017)

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

(** **********************************************************

Contents :

        - Comma precategories [comma_precategory]

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

Require Import UniMath.Foundations.Sets.
Require Import UniMath.CategoryTheory.Categories.
Require Import UniMath.CategoryTheory.functor_categories.

(** * Comma precategories *)

Section comma_precategories.

Local Open Scope cat.

(* We require that the target category C below has homsets *)

Context {C : category}.
Context {D E : precategory}.
Variable S : D ⟶ C.
Variable T : E ⟶ C.

Local Open Scope type_scope.
Local Open Scope cat.

Definition comma_cat_ob : UU := ∑ ed : ob E × ob D, C⟦T (pr1 ed), S (pr2 ed)⟧.

Definition comma_cat_mor : comma_cat_ob -> comma_cat_ob -> UU :=
  λ abf : comma_cat_ob,
    (λ cdg : comma_cat_ob,
             ∑ kh : E⟦pr1 (pr1 abf), pr1 (pr1 cdg)⟧ × D⟦pr2 (pr1 abf), pr2 (pr1 cdg)⟧, pr2 (abf) · #S(pr2 kh) = #T(pr1 kh) · pr2 (cdg)).

Definition comma_cat_ob_mor : precategory_ob_mor := precategory_ob_mor_pair comma_cat_ob comma_cat_mor.

Definition comma_cat_id : ∏ edf : comma_cat_ob_mor, comma_cat_ob_mor ⟦ edf, edf ⟧.
Proof.
  intro edf. cbn.
  exists (dirprodpair (identity (pr1 (pr1 edf))) (identity (pr2 (pr1 edf)))). cbn.
  abstract (
    rewrite 2 functor_id;
    rewrite id_right;
    rewrite id_left;
    apply idpath
    ).
Defined.

Definition comma_cat_comp : ∏ uvf xyg zwh : comma_cat_ob, comma_cat_mor uvf xyg → comma_cat_mor xyg zwh → comma_cat_mor uvf zwh.
Proof.
  intros uvf xyg zwh ijp klq.
  exists (dirprodpair (pr1 (pr1 ijp) · pr1 (pr1 klq)) (pr2 (pr1 ijp) · pr2 (pr1 klq))). cbn.
  abstract (
    rewrite 2 functor_comp;
    rewrite assoc;
    rewrite (pr2 ijp);
    rewrite <- assoc;
    rewrite (pr2 klq);
    rewrite assoc;
    apply idpath
    ).
Defined.

Definition comma_cat_id_comp : precategory_id_comp comma_cat_ob_mor := dirprodpair comma_cat_id comma_cat_comp.

Definition comma_cat_data : precategory_data := tpair _ comma_cat_ob_mor comma_cat_id_comp.

Definition comma_cat_data_id_left :  ∏ (abf cdg : comma_cat_data) (hkp : abf --> cdg), identity abf · hkp = hkp .
Proof.
  intros abf cdg hkp.
  use total2_paths2_f.
  - use total2_paths2.
    + cbn. apply id_left.
    + cbn. apply id_left.
  - cbn. apply (homset_property C).
Qed.

Definition comma_cat_data_id_right :  ∏ (abf cdg : comma_cat_data) (hkp : abf --> cdg), hkp · identity cdg = hkp .
Proof.
  intros abf cdg hkp.
  use total2_paths2_f.
  - use total2_paths2.
    + cbn. apply id_right.
    + cbn. apply id_right.
  - cbn. apply (homset_property C).
Qed.

Definition comma_cat_data_assoc :
  ∏ (stf uvg xyh zwi : comma_cat_data) (jkp : stf --> uvg) (lmq : uvg --> xyh) (nor : xyh --> zwi), jkp · (lmq · nor) = (jkp · lmq) · nor .
Proof.
  intros stf uvg xyh zwi jkp lmq nor.
  use total2_paths2_f.
  - use total2_paths2.
    + cbn. apply assoc.
    + cbn. apply assoc.
  - apply (homset_property C).
Qed.

Definition is_precategory_comma_cat_data : is_precategory comma_cat_data :=
  mk_is_precategory comma_cat_data_id_left comma_cat_data_id_right comma_cat_data_assoc.

Definition comma_precategory : precategory := mk_precategory comma_cat_data is_precategory_comma_cat_data.

End comma_precategories.


Require Import Arith.
Require Import Ascii.
Require Import Bool.
Require Import Coq.Strings.Byte.

(* OPERATII ARITMETICE *)

(* TIP BOOL *)

Inductive TROOF :=
| ttroof : bool -> TROOF.

Coercion ttroof : bool >-> TROOF.

Notation " 'WIN' " := (ttroof true) (at level 50).
Notation " 'FAIL' " := (ttroof false) (at level 50).

Check WIN.
Check FAIL.
Check true.

(* TIP STRING *)

Require Import String.
Open Scope string_scope.

Inductive YARN :=
| yyarn : string -> YARN.

Coercion yyarn : string >-> YARN.

Check YARN.
Check string.
Check yyarn "Hello".
Check "Hello".

(* TIP INT *)

Inductive NUMBR :=
| nnum : nat -> NUMBR.

Coercion nnum : nat >-> NUMBR.

Check NUMBR.
Check 2.
Check nnum 2.

(* OPERATII ARITMETICE *)

Inductive AExp :=
| anum : nat -> AExp
(*| atroof : TROOF -> AExp*)
| ayarn : YARN -> AExp
| aplus :  AExp -> AExp -> AExp
| aminus :  AExp -> AExp -> AExp
| amul :  AExp -> AExp -> AExp
| aimp :  AExp -> AExp -> AExp
| amodul :  AExp -> AExp -> AExp.
(*| amax :  AExp -> AExp -> AExp
| amin :  AExp -> AExp -> AExp.*)

Coercion anum : nat >-> AExp.
(*Coercion atroof : TROOF >-> AExp.*)
Coercion ayarn : YARN >-> AExp.

Check anum 3.
Check (aplus (anum 2) (anum 2)). (* 2 + 2 *)

Notation " 'SUM' 'OF' A 'AN' B " := (aplus A B) (at level 50).
Notation " 'DIFF' 'OF' A 'AN' B " := (aminus A B) (at level 49).
Notation " 'PRODUKT' 'OF' A 'AN' B " := (amul A B) (at level 40).
Notation " 'QUOSHUNT' 'OF' A 'AN' B " := (aimp A B) (at level 39).
Notation " 'MOD' 'OF' A 'AN' B " := (amodul A B) (at level 38).
(*Notation " 'BIGGR' 'OF' A 'AN' B " := (amax A B) (at level 51).
Notation " 'SMALLR' 'OF' A 'AN' B " := (amin A B) (at level 52).*)
Notation " [ A ]  " := (ayarn A) (at level 50).

Check WIN.
Check ayarn.
Check ["Hello"].
Check anum 5.
Check DIFF OF 9 AN 4.

(* EXPRESII BOOLENE *)

Inductive BExp :=
| btrue : BExp
| bfalse : BExp
| band : BExp -> BExp -> BExp
| bor : BExp -> BExp -> BExp
| bnot : BExp -> BExp
| begal : AExp -> AExp -> BExp
| bdif : AExp -> AExp -> BExp
| blessthan : AExp -> AExp  -> BExp
| bgreaterthan : AExp -> AExp -> BExp
| blessthaneqto : AExp -> AExp -> BExp
| bgreaterthaneqto : AExp -> AExp -> BExp.

Notation " 'BOTH' 'OF' A 'AN' B " := (band A B) (at level 60).
Notation " 'EITHER' 'OF' A 'AN' B " := (bor A B) (at level 61).
Notation " 'NOT' A " := (bnot A) (at level 62).
Notation " 'BOTH' 'SAEM' A 'AN' B " := (begal A B) (at level 63).
Notation " 'DIFRINT' 'OF' A 'AN' B " := (bdif A B) (at level 64).
Notation " 'DIFRINT' 'IT' 'AN' 'SMALLR' 'OF' A 'AN' B " := (blessthan A B) (at level 65).
Notation " 'DIFRINT' 'IT' 'AN' 'BIGGR' 'OF' A 'AN' B " := (bgreaterthan A B) (at level 66).
Notation " 'BOTH' 'SAEM' 'IT' 'AN' 'SMALLR' 'OF' A 'AN' B " := (blessthaneqto A B) (at level 67).
Notation " 'BOTH' 'SAEM' 'IT' 'AN' 'BIGGR' 'OF' A 'AN' B " := (bgreaterthaneqto A B) (at level 68).

Check BOTH SAEM IT AN BIGGR OF 6 AN 8.

(* STATEMENTS

- definire variabile;
- atribuiri;
- concatenare pentru caractere;
- casts pentru anumite tipuri de variabile;
- comentarii;
- secvente de instructiuni;
- instructiuni conditionale cu una sau mai multe ramuri (if-else, case);
- instructiuni repetitive cu contor;
- functii si apeluri de functii

*)

Inductive Stmt :=
(*| definire_variabila_simplu : AExp -> Stmt*)
| definire_variabila_cu_o_valoare : YARN -> AExp -> Stmt
| atribuire : YARN -> AExp -> Stmt
(*| cast : AExp -> YARN -> Stmt
| comentarii : YARN -> Stmt
| concatenare_caractere : AExp -> AExp -> Stmt *)
| secventa : Stmt -> Stmt -> Stmt
| ifthenelse : BExp -> Stmt -> Stmt -> Stmt.
(*| case : AExp -> AExp -> Stmt -> AExp -> Stmt -> Stmt  -> Stmt
| while : BExp -> AExp -> Stmt -> Stmt.
| while_cu_operatie : AExp -> AExp -> BExp -> Stmt-> Stmt
| forr : AExp -> BExp ->AExp -> Stmt-> Stmt
| for_cu_operatie : AExp -> AExp -> BExp -> AExp -> Stmt-> Stmt
| definire_functie : YARN -> YARN -> YARN -> Stmt -> Stmt
| apel_functie : YARN -> AExp -> AExp -> Stmt.*)

(*
(*DEFINIRE FARA ATRIBUIRI*)
Check (definire_variabila_simplu ("H") ).
Notation " 'I' 'HAS' 'A' VAR " := (definire_variabila_simplu VAR) (at level 80).
Check I HAS A ["VAR"].

*)

(*DEFINIRE CU ATRIBUIRI*)
Check (definire_variabila_cu_o_valoare "H" 5 ).
Notation " 'I' 'HAS' 'A' A 'ITZ' B" := (definire_variabila_cu_o_valoare A B) (at level 81).
Check I HAS A "VAR" ITZ 4.

(*ATRIBUIRI*)

Notation " VAR 'R' B " := ( atribuire VAR B) (at level 82).
Check "VAR" R 3.

(*

(*CASTS*)
Check (cast (["H"]) ("TROOF") ).
Notation " 'MAEK' VAR 'A' B " := ( cast VAR B) (at level 83).
Notation " VAR 'IS' 'NOW' 'A' B  " := ( cast VAR B) (at level 83).
Check MAEK "VAR" A "TROOF".
Check "VAR" IS NOW A "B".

(*COMENTARII*)
Check (comentarii  ("TROOF") ).
Notation " 'BTW' B " := ( comentarii B) (at level 84).
Check BTW "B".

(* CONCATENARE CARACTERE *)
Check (concatenare_caractere ("T") ("hdjdsd")).
Notation " 'SMOOSH' VAR 'AN' B 'MKAY' " := ( concatenare_caractere VAR B) (at level 85).
Check SMOOSH "A" AN "BB" MKAY.

*)

(* SECVENTE *)
Notation "S1 , S2" := (secventa S1 S2) (at level 98, left associativity).

(*IF THEN ELSE*)
Notation "B 'OH' 'RLY?' 'YA' 'RLY' S1 'NO' 'WAI' S2 'OIC'" := (ifthenelse B S1 S2) (at level 97).

(*

(*CASE*)
Notation " AB 'WTF?' 'OMG' B1 S1 'GTFO' 'OMG' B2 S2 'GTFO' 'OMGWTF' S3 " := (case AB B1 S1 B2 S2 S3 ) (at level 98).
Check "COLOR" WTF?
  OMG "R"
    MAEK "VAR" A "TROOF"
   GTFO
   OMG "R"
    MAEK "VAR" A "NUMBR"
   GTFO
 OMGWTF
   "VAR" R 3.

(* while in care o variabila este incrementata *)
Notation " 'IM' 'IN' 'YR' 'WHILE' 'UPPIN' 'YR' VAR [ 'WILE' B ] S1 'IM' 'OUTTA' 'YR' 'WHILE' ":= (while VAR B S1) (at level 95).
Check IM IN YR WHILE UPPIN YR "VAR"[ WILE (BOTH SAEM IT AN BIGGR OF 6 AN 8) ]
  "VAR" IS NOW A "B"
IM OUTTA YR WHILE.

(* while in care o variabila este decrementata *)
Notation " 'IM' 'IN' 'YR' 'WHILE' 'NERFIN' 'YR' VAR [ 'WILE' B ] S1 'IM' 'OUTTA' 'YR' 'WHILE' ":= (while VAR B S1) (at level 95).
Check IM IN YR WHILE NERFIN YR "VAR"[ WILE (BOTH SAEM IT AN BIGGR OF 6 AN 8) ]
  "VAR" IS NOW A "B"
IM OUTTA YR WHILE.

(* while cu orice fel de operatie *)
Notation " 'IM' 'IN' 'YR' 'WHILE' OP 'YR' VAR [ 'WILE' B ] S1 'IM' 'OUTTA' 'YR' 'WHILE' ":= (while_cu_operatie OP VAR B S1) (at level 95).
Check IM IN YR WHILE (DIFF OF 9 AN 4) YR "VAR"[ WILE (BOTH SAEM IT AN BIGGR OF 6 AN 8) ]
  "VAR" IS NOW A "B"
IM OUTTA YR WHILE.

(* FOR in care o variabila este incrementata *)
  Notation " 'IM' 'IN' 'YR' 'FOR' 'UPPIN' 'YR' VAR [ 'TIL' B ] S1 'IM' 'OUTTA' 'YR' 'FOR' ":= (forr VAR B S1) (at level 95).
Check IM IN YR FOR UPPIN YR "VAR"[ TIL (BOTH SAEM IT AN BIGGR OF 6 AN 8) ]
  SUM OF "ALTVAR" AN 4
IM OUTTA YR FOR.

(* FOR in care o variabila este incrementata *)
  Notation " 'IM' 'IN' 'YR' 'FOR' 'NERFIN' 'YR' VAR [ 'TIL' B ] S1 'IM' 'OUTTA' 'YR' 'FOR' ":= (forr VAR B S1) (at level 95).
Check IM IN YR FOR NERFIN YR "VAR"[ TIL (BOTH SAEM IT AN BIGGR OF 6 AN 8) ]
  SUM OF "ALTVAR" AN 4
IM OUTTA YR FOR.

(* FOR cu orice fel de operatie *)
  Notation " 'IM' 'IN' 'YR' 'FOR' OP 'YR' VAR [ 'TIL' B ] S1 'IM' 'OUTTA' 'YR' 'FOR' ":= (for_cu_operatie OP VAR B S1) (at level 95).
Check IM IN YR FOR (DIFF OF 9 AN 4) YR "VAR"[ TIL (BOTH SAEM IT AN BIGGR OF 6 AN 8) ]
 SUM OF "ALTVAR" AN 4
IM OUTTA YR FOR.

(* DEFINITIE FUNCTII *)
Notation " 'HOW' 'IZ' 'I' NUME [ 'YR' PARAM1 [ 'AN' 'YR' PARAM2 ] ] S1 'IF' 'U' 'SAY' 'SO' " := (definire_functie NUME PARAM1 PARAM2 S1) (at level 97).
Check HOW IZ I "functiee" [YR "param" [ AN YR "param3" ] ]
   "VAR" IS NOW A "B"
  IF U SAY SO.

(* APEL FUNCTIE *)
Notation " 'I' 'IZ' NUME [ 'YR' PARAM1 [ 'AN' 'YR' PARAM2 ] ] 'MKAY' " := (apel_functie NUME PARAM1 PARAM2) (at level 98).
Check I IZ "functiee" [YR "param" [ AN YR "param3" ] ] MKAY.
Check I IZ "functiee" [YR "param" [ AN YR DIFF OF 9 AN 4 ] ] MKAY.

Check I HAS A ["VAR"] ITZ 4,
MAEK "VAR" A "TROOF",
"VAR" R 7,
IM IN YR WHILE (DIFF OF 9 AN 4) YR "VAR"[ WILE (BOTH SAEM IT AN BIGGR OF 6 AN 8) ]
  "VAR" IS NOW A "B"
IM OUTTA YR WHILE.

Compute DIFF OF 9 AN 4.

*)

(* OPERATII ARITMETICE *)

(* Environment *)

Definition Env := YARN -> nat.

Scheme Equality for YARN.
Check YARN_beq.

Definition env1 : Env :=
  fun x =>
    if (YARN_eq_dec x "VAR")
    then  10
    else 0.
Check env1.

Compute (env1 "VAR"). (* env1(sum) *)

Definition env2 : Env :=
  fun x =>
    if (YARN_eq_dec x "VAR")
    then  10
    else if (YARN_eq_dec x "N" )
         then 10
         else if (YARN_eq_dec x "I" )
              then 1
              else if (YARN_eq_dec x "SUM")
                   then 0
                   else 0.
Check env2.

Definition update (env : Env)
           (x : YARN) (v : nat) : Env :=
  fun y =>
    if (YARN_eq_dec y "VAR")
    then v
    else if (YARN_eq_dec y "N" )
         then v
         else if (YARN_eq_dec y "I" )
              then v
              else if (YARN_eq_dec y "SUM")
                   then v
                   else (env y).

Definition env0 := fun (var : YARN) => 0.
Compute (env0 "X").

Fixpoint aeval_fun (a : AExp) (env : Env): nat :=
  match a with
  | anum x =>  x
  | ayarn x => env x
  | aplus a1 a2 => (aeval_fun a1 env) + (aeval_fun a2 env)
  | aminus a1 a2 => (aeval_fun a1 env) - (aeval_fun a2 env)
  | amul a1 a2 => (aeval_fun a1 env) * (aeval_fun a2 env)
  | aimp a1 a2 => (aeval_fun a1 env) / (aeval_fun a2 env)
  | amodul a1 a2 => Nat.modulo (aeval_fun a1 env) (aeval_fun a2 env)
  end.

Compute aeval_fun (SUM OF 1 AN 7 ) env1.
Compute aeval_fun (DIFF OF 12 AN 7 ) env1.
Compute aeval_fun (PRODUKT OF 1 AN 7 ) env1.
Compute aeval_fun (QUOSHUNT OF "VAR" AN 5 ) env1. (* VAR =10 *)
Compute aeval_fun (MOD OF 14 AN 7 ) env1.
Compute aeval_fun (SUM OF 20 AN "ID" ) env1.

Fixpoint beval (b : BExp) (env : Env) : bool :=
  match b with
  | btrue => true
  | bfalse => false
  | band b1 b2 => andb (beval b1 env) (beval b2 env)
  | bor b1 b2 => orb (beval b1 env) (beval b2 env)
  | bnot b' => negb (beval b' env)
  | begal a1 a2 =>  Nat.eqb (aeval_fun a1 env) (aeval_fun a2 env)
  | bdif a1 a2 =>  Nat.ltb (aeval_fun a1 env) (aeval_fun a2 env) (* PROBLEME *)
  | blessthan a1 a2 => Nat.ltb (aeval_fun a1 env) (aeval_fun a2 env)
  | bgreaterthan a1 a2 => Nat.ltb (aeval_fun a2 env) (aeval_fun a1 env)
  | blessthaneqto a1 a2 => Nat.leb (aeval_fun a1 env) (aeval_fun a2 env)
  | bgreaterthaneqto a1 a2 => Nat.leb (aeval_fun a2 env) (aeval_fun a1 env)
  end.

Compute beval ( BOTH OF btrue AN bfalse ) env1.
Compute beval ( EITHER OF btrue AN bfalse ) env1.
Compute beval ( NOT bfalse ) env1.
Compute beval (BOTH SAEM "VAR" AN 10 )env1.
Compute beval (DIFRINT OF "VAR" AN 9 ) env1.
Compute beval (BOTH SAEM IT AN SMALLR OF "VAR" AN 9 ) env1.
Compute beval (BOTH SAEM IT AN BIGGR OF "VAR" AN 9 ) env1.
Compute beval (DIFRINT IT AN SMALLR OF 12 AN 9 ) env1.
Compute beval (BOTH SAEM IT AN BIGGR OF 19 AN 10 ) env1.

Fixpoint execute (s : Stmt) (env : Env) : Env :=
   match s with
      | definire_variabila_cu_o_valoare var aexp => update env var (aeval_fun aexp env)
      | atribuire var aexp => update env var (aeval_fun aexp env)
      | secventa S1 S2 => execute S2 (execute S1 env)
      | ifthenelse S1 S2 S3 => if (beval S1 env)
                            then (execute S2 env)
                            else (execute S3 env)
     (*| while cond aexp s' => if (beval cond env)
                                   then aeval_fun (s', (while cond s')) env aexp
                                   else env*)
  end.

Compute (execute (I HAS A "VAR" ITZ 4) env1) "VAR".
Compute (execute ("VAR" R 3) env1) "VAR" .
Compute (execute ("N" R 6) env2) "N" .
Compute ( execute
("N" R 10,
"I" R 1,
"SUM" R 0) env0 ) "VAR".

Definition init := (execute ("N" R 10,
                             "I" R 1,
                             "SUM" R 0) env2 ).
Compute init  "N".
Compute init "SUM".
Compute init "I".

Definition pgm :=
 "N" R 10,
 "I" R 1,
 "SUM" R 0,
BOTH SAEM IT AN SMALLR OF "VAR" AN 9
OH RLY?
YA RLY "SUM" R (SUM OF 1 AN "SUM")
NO WAI  "I" R (SUM OF 1 AN "I")
OIC.
Compute (execute pgm env0 ) "SUM".

(* Definition pgm :=
  n ::= 10 ;;
  i ::= 1 ;;
  sum ::= 0 ;;
  If (i <=' n)
          Then sum ::= sum +' i
          Else i ::= i +' 1
End.

Compute (execute pgm env0 ) sum. *)


Require Export HoTT.
Require Import HitTactics.

Module Export modulo.

Private Inductive Mod2 : Type0 :=
  | Z : Mod2
  | succ : Mod2 -> Mod2.

Axiom mod : Z = succ(succ Z).

Fixpoint Mod2_ind
  (P : Mod2 -> Type)
  (a : P Z)
  (s : forall (n : Mod2), P n -> P (succ n))
  (mod' : mod # a = s (succ Z) (s Z a))
  (x : Mod2)
  {struct x}
  : P x
  :=
    (match x return _ -> P x with
      | Z => fun _ => a
      | succ n => fun _ => s n ((Mod2_ind P a s mod') n)
    end) mod'.

Axiom Mod2_ind_beta_mod : forall
  (P : Mod2 -> Type)
  (a : P Z)
  (s : forall (n : Mod2), P n -> P (succ n))
  (mod' : mod # a = s (succ Z) (s Z a))
  , apD (Mod2_ind P a s mod') mod = mod'.

Fixpoint Mod2_rec
  (P : Type)
  (a : P)
  (s : P -> P)
  (mod' : a = s (s a))
  (x : Mod2)
  {struct x}
  : P
  :=
    (match x return _ -> P with
      | Z => fun _ => a
      | succ n => fun _ => s ((Mod2_rec P a s mod') n)
    end) mod'.

Axiom Mod2_rec_beta_mod : forall
  (P : Type)
  (a : P)
  (s : P -> P)
  (mod' : a = s (s a))
  , ap (Mod2_rec P a s mod') mod = mod'.

Instance: HitRecursion Mod2 := {
  indTy := _; recTy := _;
  H_inductor := Mod2_ind;
  H_recursor := Mod2_rec }.

End modulo.

Theorem modulo2 : forall n : Mod2, n = succ(succ n).
Proof.
intro n.
hinduction n.
- apply mod.
- intros n p.
  apply (ap succ p).
- simpl.
  etransitivity.
  eapply (@transport_paths_FlFr _ _ idmap (fun n => succ (succ n))).
  hott_simpl.
  apply ap_compose.
Defined.

Definition negate : Mod2 -> Mod2.
Proof.
hrecursion.
- apply Z.
- intros. apply (succ H).
- simpl. apply mod.
Defined.

Definition plus : Mod2 -> Mod2 -> Mod2.
Proof.
intros n m.
hrecursion m.
- exact n.
- apply succ.
- apply modulo2.
Defined.

Definition Bool_to_Mod2 : Bool -> Mod2.
Proof.
intro b.
destruct b.
+ apply (succ Z).
+ apply Z.
Defined.

Definition Mod2_to_Bool : Mod2 -> Bool.
Proof.
intro x.
hrecursion x.
- exact false.
- exact negb.
- simpl. reflexivity.
Defined.

Theorem eq1 : forall n : Bool, Mod2_to_Bool (Bool_to_Mod2 n) = n.
Proof.
intro b.
destruct b; compute; reflexivity.
Qed.

Theorem Bool_to_Mod2_negb : forall x : Bool,
  succ (Bool_to_Mod2 x) = Bool_to_Mod2 (negb x).
Proof.
intros.
destruct x; compute.
+ apply mod^.
+ apply reflexivity.
Defined.

Theorem eq2 : forall n : Mod2, Bool_to_Mod2 (Mod2_to_Bool n) = n.
Proof.
intro n.
hinduction n.
- reflexivity.
- intros n IHn.
  symmetry. etransitivity. apply (ap succ IHn^).
  etransitivity. apply Bool_to_Mod2_negb.
  hott_simpl.
- rewrite @HoTT.Types.Paths.transport_paths_FlFr.
  hott_simpl.
  rewrite ap_compose.
  enough (ap Mod2_to_Bool mod = idpath).
  + rewrite X. hott_simpl.
  + apply (Mod2_rec_beta_mod Bool false negb 1).
Defined.

Theorem adj :
  forall x : Mod2, eq1 (Mod2_to_Bool x) = ap Mod2_to_Bool (eq2 x).
Proof.
intro x.
apply hset_bool.
Defined.

Definition isomorphism : IsEquiv Mod2_to_Bool.
Proof.
apply (BuildIsEquiv Mod2 Bool Mod2_to_Bool Bool_to_Mod2 eq1 eq2 adj).
Qed.


Require Export Fibrations Equivalences.

(** For compatibility with Coq 8.2. *)
Unset Automatic Introduction.

(** The map on total spaces induced by a map of fibrations *)

Definition total_map {A B : Type} {P : A -> Type} {Q : B -> Type}
  (f : A -> B) (g : forall x:A, P x -> Q (f x)) :
  sigT P -> sigT Q.
Proof.
  intros A B P Q f g.
  intros [x y].
  exists (f x).
  exact (g x y).
Defined.

(** We first consider maps between fibrations over the same base
   space.  The theorem is that such a map induces an equivalence on
   total spaces if and only if it is an equivalence on all fibers. *)

Section FiberMap.

  Variable A : Type.
  Variables P Q : A -> Type.
  Variable g : forall x, P x -> Q x.

  Let tg := total_map (idmap A) g.

  (* There is a subtlety here that is easy to get confused about.  The
     type [sigT P] is *inductively generated* by elements of the form
     [(x ; y)].  This does *not* mean that every element of [total
     P] is *definitionally* equal to one of that form.  In particular,
     although it appears that [total_map f g] "acts as [f] on the base
     space," we cannot assert that *definitionally* except for
     arguments of the form [(x ; y)].  Hence we need the following
     lemma.  *)

  Let tg_is_fiberwise (z : sigT P) : pr1 z == pr1 (tg z).
    intros [x y].
    auto.
  Defined.

  (* Similarly, the following lemma says that the fiber component of
     [tg z] is obtained by applying the fiberwise function [f] to the
     fiber component of [z], modulo the previously defined path in the
     base.  *)

  Let tg_isg_onfibers (z : sigT P) :
    g _ (transport (tg_is_fiberwise z) (pr2 z)) == pr2 (tg z).
  Proof.
    intros [x y].
    auto.
  Defined.

  (* And the following lemma tells us that the same is true for its
     action on paths. *)

  Let tg_isfib_onpaths (z w : sigT P) (p : z == w) :
    (tg_is_fiberwise z @ base_path (map tg p) @ !tg_is_fiberwise w) == base_path p.
  Proof.
    path_induction.
    destruct x. simpl. auto.
  Defined.

  (* Now let's suppose the total function is an equivalence. *)

  Section TotalIsEquiv.

    Hypothesis tot_iseqv : is_equiv tg.

    Let tot_eqv : (sigT P) <~> (sigT Q) := (tg ; tot_iseqv).

    (* We want to show that each function [g x] is an equivalence, so we
       start by defining its inverse. *)

    Let ginv (x:A) (y: Q x) : P x.
    Proof.
      intros x y.
      (* The obvious thing to look at first is this. *)
      set (inv1 := pr2 ((tot_eqv^-1) (x ; y))).
      (* Unfortunately, this does not live in the fiber over [x], but
         rather in some other fiber.  We need to transport it along some
         path.  Our first guess at such a path might be this. *)
      apply (transport (base_path (inverse_is_section tot_eqv (x ; y)))).
      simpl.
      (* This type is not quite the type of [inv1] yet; it involves
         knowing something about the base component of an image under
         [tg].  This is what [tg_is_fiberwise] is for.   *)
      apply (transport (tg_is_fiberwise ((tot_eqv^-1) (x ; y)))).
      (* Now we are back to the type of [inv1]. *)
      assumption.
    Defined.

    (* Now we are ready to prove that [g x] is an equivalence. *)

    Theorem fiber_is_equiv (x:A) : is_equiv (g x).
    Proof.
      intros x.
      set (is_section := inverse_is_section tot_eqv).
      set (is_retraction := inverse_is_retraction tot_eqv).
      set (triangle := inverse_triangle tot_eqv).
      (* We have our putative inverse ready to hand. *)
      apply @hequiv_is_equiv with (g := ginv x).
      (* First we have to show it is a section of [f x]. *)
      intro y.
      path_via (transport (P := Q)
        (base_path (is_section (x ; y)))
        (pr2 (tot_eqv (tot_eqv^-1 (x ; y))))).
      path_via (transport
        (base_path (is_section (x ; y)))
        (g _ (transport (tg_is_fiberwise (tot_eqv^-1 (x ; y)))
          (pr2 (tot_eqv^-1 (x ; y)))))).
      apply trans_map.
      exact (fiber_path (is_section (existT _ x y))).
      (* And now that it is a retraction. *)
      intro y.
      path_via (transport (base_path (map tg (is_retraction (x ; y))))
      (transport (tg_is_fiberwise (tot_eqv^-1 (x ; (g x y))))
        (pr2 (tot_eqv^-1 (x ; (g x y)))))).
      unfold ginv.
      apply happly, map, map.
      apply opposite, triangle.
      path_via (transport
        (base_path (is_retraction (x ; y)))
        (pr2 (tot_eqv^-1 (x ; (g x y))))).
      path_via (transport
        ((tg_is_fiberwise (tot_eqv^-1 (x ; (g x y))))
          @ (base_path (map tg (is_retraction (x ; y)))))
        (pr2 ((tot_eqv^-1) (x ; (g x y))))).
      apply opposite, trans_concat.
      apply happly, map.
      (* Here is where we need [tg_isfib_onpaths], but it is easy to
         get confused because the second copy of [tg_is_fiberwise]
         appears to be missing.  The reason is that it would be
         instantiated at an element of the form [(x ; y)], in which
         case it happens to be an identity.  Thus, we can just add it
         back in. *)
      path_via (tg_is_fiberwise (tot_eqv^-1 (x ; (g x y))) @
        base_path (map tg (is_retraction (x ; y))) @
        !tg_is_fiberwise (x ; y)).
      exact (fiber_path (is_retraction (existT _ x y))).
    Defined.

    Definition fiber_equiv (x:A) : P x <~> Q x :=
      (g x ; fiber_is_equiv x).

  End TotalIsEquiv.

  (* Now let's suppose instead that the maps on fibers are equivalences. *)

  Section FiberIsEquiv.

    Hypothesis fiber_iseqv : forall x, is_equiv (g x).

    Let fiber_eqv x : P x <~> Q x := (g x ; fiber_iseqv x).

    Let total_inv : sigT Q -> sigT P.
    Proof.
      intros [x y].
      exists x.
      apply ((fiber_eqv x)^-1).
      assumption.
    Defined.

    Theorem total_is_equiv : is_equiv tg.
    Proof.
      eapply hequiv_is_equiv.
      instantiate (1 := total_inv).
      intros [x y].
      eapply total_path.
      instantiate (1 := idpath x).
      path_via (fiber_eqv x ((fiber_eqv x ^-1) y)).
      apply inverse_is_section.
      intros [x y].
      eapply total_path.
      instantiate (1 := idpath x).
      path_via (fiber_eqv x ^-1 (fiber_eqv x y)).
      apply inverse_is_retraction.
    Defined.

    Definition total_equiv : sigT P <~> sigT Q :=
      (tg ; total_is_equiv).

  End FiberIsEquiv.

End FiberMap.

Implicit Arguments fiber_equiv [A].
Implicit Arguments fiber_is_equiv [A].
Implicit Arguments total_equiv [A].
Implicit Arguments total_is_equiv [A].

(** Next we consider a fibration over one space and its pullback along
   a map from another base space.  The theorem is that if the map we
   pull back along is an equivalence, so is the induced map on total
   spaces. *)

Section PullbackMap.

  Variables A B : Type.
  Variable Q : B -> Type.
  Variable f : A <~> B.

  Let pbQ : A -> Type := Q o f.

  Let g (x:A) : pbQ x -> Q (f x) := idmap (Q (f x)).

  Let tg := total_map f g.

  Let tginv : sigT Q -> sigT pbQ.
  Proof.
    intros [x z].
    exists (f^-1 x).
    apply (transport (! inverse_is_section f x)).
    assumption.
  Defined.

  Theorem pullback_total_is_equiv : is_equiv tg.
  Proof.
    apply @hequiv_is_equiv with (g := tginv).
    intros [x z].
    apply total_path with (p := inverse_is_section f x).
    simpl.
    path_via (transport (! inverse_is_section f x @ inverse_is_section f x) z).
    apply opposite, trans_concat.
    path_via (transport (idpath x) z).
    apply @map with (f := fun p => transport p z).
    cancel_opposites.
    intros [x z].
    apply total_path with (p := inverse_is_retraction f x).
    simpl.
    path_via (transport (map f (inverse_is_retraction f x))
     (transport (!inverse_is_section f (f x)) z)).
    apply (map_trans Q).
    path_via (transport (!inverse_is_section f (f x) @ map f (inverse_is_retraction f x)) z).
    apply opposite, trans_concat.
    path_via (transport (idpath (f x)) z).
    assert (p : (!inverse_is_section f (f x) @ map f (inverse_is_retraction f x)) == idpath (f x)).
    moveright_onleft.
    cancel_units.
    apply inverse_triangle.
    exact (@map _ _ (!inverse_is_section f (f x) @ map f (inverse_is_retraction f x))
      (idpath (f x))
      (fun p => transport p z) p).
  Defined.

  Definition pullback_total_equiv : sigT pbQ <~> sigT Q :=
    existT _ tg pullback_total_is_equiv.

End PullbackMap.

Implicit Arguments pullback_total_is_equiv [A B].
Implicit Arguments pullback_total_equiv [A B].

(** Finally, we can put these together to prove that given a map of
   fibrations lying over an equivalence of base spaces, the induced
   map on total spaces is an equivalence if and only if the map on
   each fiber is an equivalence. *)

Section FibrationMap.

  Variables A B : Type.
  Variable P : A -> Type.
  Variable Q : B -> Type.

  Variable f : A <~> B.
  Variable g : forall x:A, P x -> Q (f x).

  Let tg := total_map f g.

  Let pbQ := Q o f.

  Let pbg (x : A) : P x -> pbQ x := g x.

  Theorem fibseq_fiber_is_equiv :
    is_equiv tg -> forall x, is_equiv (g x).
  Proof.
    intro H.
    set (pbmap_equiv := pullback_total_is_equiv Q f).
    apply fiber_is_equiv.
    apply @equiv_cancel_left with (C := sigT Q) (g := pullback_total_equiv Q f).
    apply @equiv_homotopic with (g := tg).
    intros [x y].
    auto.
    assumption.
  Defined.

  Definition fibseq_fiber_equiv :
    is_equiv tg -> forall x, P x <~> Q (f x) :=
      fun H x => (g x ; fibseq_fiber_is_equiv H x).

  (* Instead of proving directly that [tg] is an equivalence, we'll
  prove first that a different map from [sigT P] to [sigT Q] is an
  equivalence, then that [tg] is homotopic to that map. *)

  Let fibseq_a_totalequiv :
    (forall x, is_equiv (g x)) -> (sigT P <~> sigT Q).
  Proof.
    intro H.
    apply @equiv_compose with (B := sigT pbQ).
    exists (total_map (idmap A) pbg).
    apply @total_is_equiv.
    apply H.
    apply pullback_total_equiv.
  Defined.

  Theorem fibseq_total_is_equiv :
    (forall x, is_equiv (g x)) -> is_equiv tg.
  Proof.
    intro H.
    apply @equiv_homotopic with (g := fibseq_a_totalequiv H).
    intros [x y].
    auto.
    exact (pr2 (fibseq_a_totalequiv H)).
  Defined.

  Definition fibseq_total_equiv :
    (forall x, is_equiv (g x)) -> (sigT P <~> sigT Q) :=
    fun H => (tg ; fibseq_total_is_equiv H).

End FibrationMap.

Implicit Arguments fibseq_fiber_is_equiv [A B].
Implicit Arguments fibseq_fiber_equiv [A B].
Implicit Arguments fibseq_total_is_equiv [A B].
Implicit Arguments fibseq_total_equiv [A B].