(** * Perm: Basic Techniques for Comparisons and Permutations *)

(** Consider these algorithms and data structures:
    - sort a sequence of numbers
    - finite maps from numbers to (arbitrary-type) data
    - finite maps from any ordered type to (arbitrary-type) data
    - priority queues: finding/deleting the highest number in a set

    To prove the correctness of such programs, we need to reason about
    comparisons, and about whether two collections have the same
    contents.  In this chapter, we introduce some techniques for
    reasoning about:

    - less-than comparisons on natural numbers, and
    - permutations (rearrangements of lists).

    In later chapters, we'll apply these proof techniques to reasoning
    about algorithms and data structures. *)

Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.  (* for manual grading *)
From Coq Require Export Bool.Bool.
From Coq Require Export Arith.Arith.
From Coq Require Export Arith.EqNat.
From Coq Require Export Omega.
From Coq Require Export Lists.List.
Export ListNotations.
From Coq Require Export Permutation.

(* ################################################################# *)
(** * The Less-Than Order on the Natural Numbers *)

(** In our proofs about searching and sorting algorithms, we often
    have to reason about the less-than order on natural numbers.
    greater-than. Recall that the Coq standard library contains both
    propositional and Boolean less-than operators on natural numbers.
    We write [x < y] for the proposition that [x] is less than [y]: *)

Locate "_ < _". (* "x < y" := lt x y *)
Check lt : nat -> nat -> Prop.

(** And we write [x <? y] for the computation that returns [true] or
    [false] depending on whether [x] is less than [y]: *)

Locate "_ <? _". (* x <? y  := Nat.ltb x y *)
Check Nat.ltb : nat -> nat -> bool.

(** Operation [<] is a reflection of [<?], as discussed in
    [Logic] and [IndProp]. The [Nat] module has a
    theorem showing how they relate: *)

Check Nat.ltb_lt : forall n m : nat, (n <? m) = true <-> n < m.

(** The [Nat] module contains a synonym for [lt]. *)

Print Nat.lt. (* Nat.lt = lt *)

(** For unknown reasons, [Nat] does not define notations
    for [>?] or [>=?].  So we define them here: *)

Notation  "a >=? b" := (Nat.leb b a)
                          (at level 70) : nat_scope.
Notation  "a >? b"  := (Nat.ltb b a)
                         (at level 70) : nat_scope.

(* ================================================================= *)
(** ** The Omega Tactic *)

(** Reasoning about inequalities by hand can be a little painful. Luckily, Coq
    provides a tactic called [omega] that is quite helpful. *)

Theorem omega_example1:
 forall i j k,
    i < j ->
    ~ (k - 3 <= j) ->
   k > i.
Proof.
  intros.

(** The hard way to prove this is by hand. *)

  (* try to remember the name of the lemma about negation and [<=] *)
  Search (~ _ <= _ -> _).
  apply not_le in H0.
  (* try to remember the name of the transitivity lemma about [>] *)
  Search (_ > _ -> _ > _ -> _ > _).
  apply gt_trans with j.
  apply gt_trans with (k-3).
  (* Is [k] greater than [k-3]? On the integers, sure. But we're working
     with natural numbers, which truncate subtraction at zero. *)
Abort.

Theorem truncated_subtraction: ~ (forall k:nat, k > k - 3).
Proof.
  intros contra.
  (* [specialize] applies a hypothesis to an argument *)
  specialize (contra 0).
  simpl in contra.
  inversion contra.
Qed.

(** Since subtraction is truncated, does [omega_example1] actually hold?
    It does. Let's try again, the hard way, to find the proof. *)

Theorem omega_example1:
 forall i j k,
    i < j ->
    ~ (k - 3 <= j) ->
   k > i.
Proof. (* try again! *)
  intros.
  apply not_le in H0.
  unfold gt in H0.
  unfold gt.
  (* try to remember the name ... *)
  Search (_ < _ -> _ <= _ -> _ < _).
  apply lt_le_trans with j.
  apply H.
  apply le_trans with (k-3).
  Search (_ < _ -> _ <= _).
  apply lt_le_weak.
  auto.
  apply le_minus.
Qed.

(** That was tedious.  Here's a much easier way: *)

Theorem omega_example2:
 forall i j k,
    i < j ->
    ~ (k - 3 <= j) ->
   k > i.
Proof.
  intros.
  omega.
Qed.

(** Omega is a decision procedure invented in 1991 by William Pugh for
    integer linear programming (ILP). The [omega] tactic was made
    available by importing [Coq.omega.Omega], at the beginning of the
    file.  It is an implementation of Pugh's algorithm.  The tactic
    works with Coq types [Z] and [nat], and these operators: [<] [=] [>]
    [<=] [>=] [+] [-] [~], as well as multiplication by small integer
    literals (such as 0,1,2,3...), and some uses of [\/] and [/\].

    Omega does not "understand" other operators.  It treats
    expressions such as [a * b] and [f x y] as variables.  That is, it
    can prove [f x y > a * b -> f x y + 3 >= a * b], in the same way it
    would prove [u > v -> u + 3 >= v]. But it cannot reason about, e.g.,
    multiplication. *)

Theorem omega_example_3 : forall (f : nat -> nat -> nat) a b x y,
    f x y > a * b -> f x y + 3 >= a * b.
Proof.
  intros. omega.
Qed.

Theorem omega_example_4 : forall a b,
    a * b = b * a.
Proof.
  intros. Fail omega.
Abort.

(** The Omega algorithm is NP-complete, so we might expect that
    this tactic is exponential-time in the worst case.  Indeed,
    if you have [N] equations, it could take [2^N] time.
    But in the typical cases that result from reasoning about
    programs, [omega] is much faster than that. *)

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

(** Consider trying to sort a list of natural numbers.  As a small piece of
    a sorting algorithm, we might need to swap the first two elements of a list
    if they are out of order. *)

Definition maybe_swap (al: list nat) : list nat :=
  match al with
  | a :: b :: ar => if a >? b then b :: a :: ar else a :: b :: ar
  | _ => al
  end.

Example maybe_swap_123:
  maybe_swap [1; 2; 3] = [1; 2; 3].
Proof. reflexivity. Qed.

Example maybe_swap_321:
  maybe_swap [3; 2; 1] = [2; 3; 1].
Proof. reflexivity. Qed.

(** Applying [maybe_swap] twice should give the same result as applying it once.
    That is, [maybe_swap] is _idempotent_. *)

Theorem maybe_swap_idempotent: forall al,
    maybe_swap (maybe_swap al) = maybe_swap al.
Proof.
  intros [ | a [ | b al]]; simpl; try reflexivity.
  destruct (b <? a) eqn:Hb_lt_a; simpl.
  - destruct (a <? b) eqn:Ha_lt_b; simpl.
    + (** Now what?  We have a contradiction in the hypotheses: it
          cannot hold that [a] is less than [b] and [b] is less than
          [a].  Unfortunately, [omega] cannot immediately show that
          for us, because it reasons about comparisons in [Prop] not
          [bool]. *)
      Fail omega.
Abort.

(** Of course we could finish the proof by reasoning directly about
    inequalities in [bool].  But this situation is going to occur
    repeatedly in our study of sorting. *)

(** Let's set up some machinery to enable using [omega] on boolean
    tests. *)

(* ================================================================= *)
(** ** Reflection *)

(** The [reflect] type, defined in the standard library (and presented
    in [IndProp]), relates a proposition to a Boolean. That is,
    a value of type [reflect P b] contains a proof of [P] if [b] is
    [true], or a proof of [~ P] if [b] is [false]. *)

Print reflect.
(*
Inductive reflect (P : Prop) : bool -> Set :=
  | ReflectT :   P -> reflect P true
  | ReflectF : ~ P -> reflect P false
 *)

(** The standard library proves a theorem that says if [P] is provable
    whenever [b = true] is provable, then [P] reflects [b]. *)

Check iff_reflect : forall (P : Prop) (b : bool),
    P <-> b = true -> reflect P b.

(** Using that theorem, we can quickly prove that the propositional
    (in)equality operators are reflections of the Boolean
    operators. *)

Lemma eqb_reflect : forall x y, reflect (x = y) (x =? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.eqb_eq.
Qed.

Lemma ltb_reflect : forall x y, reflect (x < y) (x <? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.ltb_lt.
Qed.

Lemma leb_reflect : forall x y, reflect (x <= y) (x <=? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.leb_le.
Qed.

(** Here's an example of how you could use these lemmas.  Suppose you
    have this simple program, [(if a <? 5 then a else 2)], and you
    want to prove that it evaluates to a number smaller than 6.  You
    can use [ltb_reflect] "by hand": *)

Example reflect_example1: forall a,
    (if a <? 5 then a else 2) < 6.
Proof.
  intros a.
  (* The next two lines aren't strictly necessary, but they
     help make it clear what [destruct] does. *)
  assert (R: reflect (a < 5) (a <? 5)) by apply ltb_reflect.
  remember (a <? 5) as guard.
  destruct R as [H|H] eqn:HR.
  * (* ReflectT *) omega.
  * (* ReflectF *) omega.
Qed.

(** For the [ReflectT] constructor, the guard [a <? 5] must be equal
    to [true]. The [if] expression in the goal has already been
    simplified to take advantage of that fact. Also, for [ReflectT] to
    have been used, there must be evidence [H] that [a < 5] holds.
    From there, all that remains is to show [a < 5] entails [a < 6].
    The [omega] tactic, which is capable of automatically proving some
    theorems about inequalities, succeeds.

    For the [ReflectF] constructor, the guard [a <? 5] must be equal
    to [false]. So the [if] expression simplifies to [2 < 6], which is
    immediately provable by [omega]. *)

(** A less didactic version of the above proof wouldn't do the
    [assert] and [remember]: we can directly skip to [destruct]. *)

Example reflect_example1': forall a,
    (if a <? 5 then a else 2) < 6.
Proof.
  intros a. destruct (ltb_reflect a 5); omega.
Qed.

(** But even that proof is a little unsatisfactory. The original expression,
    [a <? 5], is not perfectly apparent from the expression [ltb_reflect a 5]
    that we pass to [destruct]. *)

(** It would be nice to be able to just say something like [destruct
    (a <? 5)] and get the reflection "for free."  That's what we'll
    engineer, next. *)

(* ================================================================= *)
(** ** A Tactic for Boolean Destruction *)

(** We're now going to build a tactic that you'll want to _use_, but
    you won't need to understand the details of how to _build_ it
    yourself.

    Let's put several of these [reflect] lemmas into a Hint database.
    We call it [bdestruct], because we'll use it in our
    boolean-destruction tactic: *)

Hint Resolve ltb_reflect leb_reflect eqb_reflect : bdestruct.

(** Here is the tactic, the body of which you do not need to
    understand.  Invoking [bdestruct] on Boolean expression [b] does
    the same kind of reasoning we did above: reflection and
    destruction.  It also attempts to simplify negations involving
    inequalities in hypotheses. *)

Ltac bdestruct X :=
  let H := fresh in let e := fresh "e" in
   evar (e: Prop);
   assert (H: reflect e X); subst e;
    [eauto with bdestruct
    | destruct H as [H|H];
       [ | try first [apply not_lt in H | apply not_le in H]]].

(** This tactic makes quick, easy-to-read work of our running example. *)

Example reflect_example2: forall a,
    (if a <? 5 then a else 2) < 6.
Proof.
  intros.
  bdestruct (a <? 5);  (* instead of: [destruct (ltb_reflect a 5)]. *)
  omega.
Qed.

(* ================================================================= *)
(** ** Finishing the [maybe_swap] Proof *)

(** Now that we have [bdestruct], we can finish the proof of [maybe_swap]'s
    idempotence. *)

Theorem maybe_swap_idempotent: forall al,
    maybe_swap (maybe_swap al) = maybe_swap al.
Proof.
  intros [ | a [ | b al]]; simpl; try reflexivity.
  bdestruct (a >? b); simpl.
  (** Note how [b < a] is a hypothesis, rather than [b <? a = true]. *)
  - bdestruct (b >? a); simpl.
    + (** [omega] can take care of the contradictory propositional inequalities. *)
      omega.
    + reflexivity.
  - bdestruct (a >? b); simpl.
    + omega.
    + reflexivity.
Qed.

(** When proving theorems about a program that uses Boolean
    comparisons, use [bdestruct] followed by [omega], rather than
    [destruct] followed by application of various theorems about
    Boolean operators. *)

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

(** Another useful fact about [maybe_swap] is that it doesn't add or
    remove elements from the list: it only reorders them.  That is,
    the output list is a permutation of the input.  List [al] is a
    _permutation_ of list [bl] if the elements of [al] can be
    reordered to get the list [bl].  Note that reordering does not
    permit adding or removing duplicate elements. *)

(** Coq's [Permutation] library has an inductive definition of
    permutations. *)

Print Permutation.

(*
 Inductive Permutation {A : Type} : list A -> list A -> Prop :=
    perm_nil : Permutation [] []
  | perm_skip : forall (x : A) (l l' : list A),
                Permutation l l' ->
                Permutation (x :: l) (x :: l')
  | perm_swap : forall (x y : A) (l : list A),
                Permutation (y :: x :: l) (x :: y :: l)
  | perm_trans : forall l l' l'' : list A,
                 Permutation l l' ->
                 Permutation l' l'' ->
                 Permutation l l''.
 *)

(** You might wonder, "is that really the right definition?"  And
    indeed, it's important that we get a right definition, because
    [Permutation] is going to be used in our specifications of
    searching and sorting algorithms.  If we have the wrong
    specification, then all our proofs of "correctness" will be
    useless.

    It's not obvious that this is indeed the right specification of
    permutations. (It happens to be, but that's not obvious.) To gain
    confidence that we have the right specification, let's use it
    prove some properties that permutations ought to have. *)

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

    Think of some desirable properties of the [Permutation] relation
    and write them down informally in English, or a mix of Coq and
    English.  Here are four to get you started:

     - 1. If [Permutation al bl], then [length al = length bl].
     - 2. If [Permutation al bl], then [Permutation bl al].
     - 3. [[1;1]] is NOT a permutation of [[1;2]].
     - 4. [[1;2;3;4]] IS a permutation of [[3;4;2;1]].

   YOUR TASK: Add three more properties. Write them here: *)

(** Now, let's examine all the theorems in the Coq library about
    permutations: *)

Search Permutation.  (* Browse through the results of this query! *)

(** Which of the properties that you wrote down above have already
    been proved as theorems by the Coq library developers?  Answer
    here:

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

(** Let's use the permutation theorems in the library to prove the
    following theorem. *)

Example butterfly: forall b u t e r f l y : nat,
  Permutation ([b;u;t;t;e;r]++[f;l;y]) ([f;l;u;t;t;e;r]++[b;y]).
Proof.
  intros.
  (** Let's group [[u;t;t;e;r]] together on both sides.  Tactic
      [change t with u] replaces [t] with [u].  Terms [t] and [u] must
      be _convertible_, here meaning that they evalute to the same
      term. *)
  change [b;u;t;t;e;r] with ([b]++[u;t;t;e;r]).
  change [f;l;u;t;t;e;r] with ([f;l]++[u;t;t;e;r]).

  (** We don't actually need to know the list elements in
      [[u;t;t;e;r]].  Let's forget about them and just remember them
      as a variable named [utter]. *)
  remember [u;t;t;e;r] as utter. clear Hequtter.

  (** Likewise, let's group [[f;l]] and remember it as a variable. *)
  change [f;l;y] with ([f;l]++[y]).
  remember [f;l] as fl. clear Heqfl.

  (** Next, let's cancel [fl] from both sides.  In order to do that,
      we need to bring it to the beginning of each list. For the right
      list, that follows easily from the associativity of [++].  *)
  replace ((fl ++ utter) ++ [b;y]) with (fl ++ utter ++ [b;y])
    by apply app_assoc.

  (** But for the left list, we can't just use associativity.
      Instead, we need to reason about permutations and use some
      library theorems. *)
  apply perm_trans with (fl ++ [y] ++ ([b] ++ utter)).
  - replace (fl ++ [y] ++ [b] ++ utter) with ((fl ++ [y]) ++ [b] ++ utter).
    + apply Permutation_app_comm.
    + rewrite <- app_assoc. reflexivity.

  - (** A library theorem will now help us cancel [fl]. *)
    apply Permutation_app_head.

  (** Next let's cancel [utter]. *)
    apply perm_trans with (utter ++ [y] ++ [b]).
    + replace ([y] ++ [b] ++ utter) with (([y] ++ [b]) ++ utter).
      * apply Permutation_app_comm.
      * rewrite app_assoc. reflexivity.
    + apply Permutation_app_head.

      (** Finally we're left with just [y] and [b]. *)
      apply perm_swap.
Qed.

(** That example illustrates a general method for proving permutations
    involving cons [::] and append [++]:

    - Identify some portion appearing in both sides.
    - Bring that portion to the front on each side using lemmas such
      as [Permutation_app_comm] and [perm_swap], with generous use of
      [perm_trans].
    - Use [Permutation_app_head] to cancel an appended head.  You can
      also use [perm_skip] to cancel a single element. *)

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

    Use the permutation rules in the library to prove the following
    theorem.  The following [Check] commands are a hint about useful
    lemmas.  You don't need all of them, and depending on your
    approach you will find lemmas to be more useful than others. Use
    [Search Permutation] to find others, if you like. *)

Check perm_skip.
Check perm_trans.
Check Permutation_refl.
Check Permutation_app_comm.
Check app_assoc.
Check app_nil_r.
Check app_comm_cons.

Example permut_example: forall (a b: list nat),
  Permutation (5 :: 6 :: a ++ b) ((5 :: b) ++ (6 :: a ++ [])).
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

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

    Prove that [[1;1]] is not a permutation of [[1;2]].
    Hints are given as [Check] commands. *)

Check Permutation_cons_inv.
Check Permutation_length_1_inv.

Example not_a_permutation:
  ~ Permutation [1;1] [1;2].
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Correctness of [maybe_swap] *)

(** Now we can prove that [maybe_swap] is a permutation: it reorders
    elements but does not add or remove any. *)

Theorem maybe_swap_perm: forall al,
  Permutation al (maybe_swap al).
Proof.
  (* WORKED IN CLASS *)
  unfold maybe_swap.
  destruct al as [ | a [ | b al]].
  - simpl. apply perm_nil.
  - apply Permutation_refl.
  - bdestruct (b <? a).
    + apply perm_swap.
    + apply Permutation_refl.
Qed.

(** And, we can prove that [maybe_swap] permutes elements such that
    the first is less than or equal to the second. *)

Definition first_le_second (al: list nat) : Prop :=
  match al with
  | a :: b :: _ => a <= b
  | _ => True
  end.

Theorem maybe_swap_correct: forall al,
    Permutation al (maybe_swap al)
    /\ first_le_second (maybe_swap al).
Proof.
  intros. split.
  - apply maybe_swap_perm.
  - (* WORKED IN CLASS *)
    unfold maybe_swap.
    destruct al as [ | a [ | b al]]; simpl; auto.
    bdestruct (a >? b); simpl; omega.
Qed.

(* ################################################################# *)
(** * Summary: Comparisons and Permutations *)

(** To prove correctness of algorithms for sorting and searching,
    we'll reason about comparisons and permutations using the tools
    developed in this chapter.  The [maybe_swap] program is a tiny
    little example of a sorting program.  The proof style in
    [maybe_swap_correct] will be applied (at a larger scale) in
    the next few chapters. *)

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

    To close, we define a utility tactic and lemma.  First, the
    tactic. *)

(** Coq's [inversion H] tactic is so good at extracting
    information from the hypothesis [H] that [H] sometimes becomes
    completely redundant, and one might as well [clear] it from the
    goal.  Then, since the [inversion] typically creates some equality
    facts, why not then [subst] ?  Tactic [inv] does just that. *)

Ltac inv H := inversion H; clear H; subst.

(** Second, the lemma.  You will find [inv] useful in proving it.

    [Forall] is Coq library's version of the [All] proposition defined
    in [Logic], but defined as an inductive proposition rather
    than a fixpoint.  Prove this lemma by induction.  You will need to
    decide what to induct on: [al], [bl], [Permutation al bl], and
    [Forall f al] are possibilities. *)

Theorem Forall_perm: forall {A} (f: A -> Prop) al bl,
  Permutation al bl ->
  Forall f al -> Forall f bl.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* 2020-08-07 17:08 *)


Require Import list.
Require Import fmap.

Fixpoint In (a:Type) (x:a) (l:list a) : Prop :=
    match l with
    | []        => False
    | y :: xs   => y = x \/ In a x xs
    end.

Arguments In {a} _ _.

Lemma In_map : forall (a b:Type) (f:a -> b) (l:list a) (x:a),
    In x l -> In (f x) (map f l).
Proof.
    intros a b f l x. induction l as [|y ys H].
    - intros H. inversion H.
    - simpl. intros [H'|H'].
        + left. rewrite H'. reflexivity.
        + right. apply H. apply H'.
Qed.

Lemma In_map_iff : forall (a b:Type) (f:a -> b) (l:list a) (y:b),
    In y (map f l) <-> exists x, f x = y /\ In x l.
Proof.
    intros a b f l y. split.
    - induction l as [|x xs H].
        + intros H. inversion H.
        + simpl. intros [H'|H'].
            { exists x. split.
                { exact H'. }
                { left. reflexivity. }}
            { apply H in H'. destruct H' as [x' H']. destruct H' as [H1 H2].
                exists x'. split.
                    { exact H1. }
                    { right. exact H2. }}
    - intros [x [H1 H2]]. rewrite <- H1. apply In_map. exact H2.
Qed.

Lemma In_app_iff : forall (a:Type) (l k:list a) (x:a),
    In x (l ++ k) <-> In x l \/ In x k.
Proof.
    intros a l k x. split.
    - induction l as [|y xs H].
        + simpl. intros H. right. exact H.
        + simpl. intros [H'|H'].
            { left. left. exact H'. }
            { apply H in H'. destruct H' as [H1|H2].
                { left. right. exact H1. }
                { right. exact H2. }}
    - induction l as [|y xs H].
        + intros [H'|H'].
            { inversion H'. }
            { exact H'. }
        + simpl. intros [[H'|H']|H'].
            { left. exact H'. }
            { right. apply H. left. exact H'. }
            { right. apply H. right. exact H'. }
Qed.

Fixpoint All (a:Type) (P:a -> Prop) (l:list a) : Prop :=
    match l with
    | []        => True
    | x :: xs   => P x /\ All a P xs
    end.

Arguments All {a} _ _.

Lemma All_In : forall (a:Type) (P:a -> Prop) (l:list a),
    (forall x, In x l -> P x) <-> All P l.
Proof.
    intros a P l. split.
    - induction l as [|x xs H].
        + intros. reflexivity.
        + simpl. intros H'. split.
            { apply H'. left. reflexivity. }
            { apply H. intros x' H0. apply H'. right. exact H0. }
    - induction l as [|x xs H].
        + intros H x H'. inversion H'.
        + simpl. intros [H1 H2] x'[H'|H'].
            { rewrite <- H'. exact H1. }
            { apply H. exact H2. exact H'. }
Qed.

Lemma In_split : forall (a:Type)(x:a)(l:list a),
    In x l -> exists k m, l = k ++ x :: m.
Proof.
    intros a x l. induction l as [|y xs IH].
    - intros H. inversion H.
    - intros [H|H].
        + exists [], xs. simpl. rewrite H. reflexivity.
        + apply IH in H. clear IH. destruct H as [k [m H]].
            exists (y :: k), m. rewrite H. rewrite app_cons. reflexivity.
Qed.

Lemma In_Decidable : forall (a:Type), (forall (x y:a), (x = y) \/ (x <> y)) ->
    forall (x:a) (l:list a), In x l \/ ~In x l.
Proof.
    intros a EqDec x l. induction l as [|y xs [IH|IH]].
    - right. intros H. inversion H.
    - left. right. exact IH.
    - destruct (EqDec x y) as [E|E].
        + left. left. rewrite E. reflexivity.
        + right. intros [H|H].
            { apply E. rewrite H. reflexivity. }
            { apply IH. exact H. }
Qed.


(* Software Foundations *)
(* Exercice 3 stars, alternate *)

Inductive natlist: Type:=
|nil: natlist
|cons: nat -> natlist -> natlist.

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

Fixpoint alternate (l1 l2 : natlist) : natlist :=
match l1, l2 with
|nil , _ => l2
|_ , nil => l1
|cons h1 t1, cons h2 t2 => h1::h2::(alternate t1 t2)
end.

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

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

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

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


(** Exercise: 2 points (plus_assoc) *)
Theorem plus_assoc : forall m n p : nat,
    m + (n + p) = (m + n) + p.
Proof.
  induction m; intros; simpl; eauto.
Qed.

Module Number.
  (** Exercise: 1 point (plus_n_O) *)
  Theorem plus_n_O : forall n : nat,
      n = n + 0.
  Proof.
    induction n; eauto.
  Qed.

End Number.

(** Bonus question: 5 bonus points (plus_very_hard) *)
Theorem plus_very_hard : 0 + 0 = 0.
Proof.
  reflexivity.
Qed.

(** We define a double function. *)
Fixpoint double (n:nat) :=
  match n with
  | O => O
  | S n' => S (S (double n'))
  end.

(** Also the even predicate. *)
Inductive ev : nat -> Prop :=
| ev_0 : ev 0
| ev_SS : forall n : nat, ev n -> ev (S (S n)).

Lemma plus_n_Sm : forall n m : nat,
  S (n + m) = n + (S m).
Proof.
  induction n; simpl; eauto.
Qed.

(** Exercise: 3 points (plus_plus_double) *)
Theorem plus_plus_double : forall n : nat,
    n + n = double n.
Proof.
  induction n; simpl; eauto.
  rewrite <- IHn.
  rewrite <- plus_n_Sm.
  reflexivity.
Qed.

(** Exercise: 3 points (double_ev) *)
Theorem double_ev : forall n : nat,
    ev (double n).
Proof.
  induction n; eauto using ev.
Qed.

(** Exercise: 1 points (test_plus) *)
Example test_plus1 : plus 1 1 = 2.
Proof.
  reflexivity. Qed.

Example test_plus2 : plus 1 2 = 3.
Proof.
  reflexivity. Qed.

Example test_plus3 : plus 1 3 = 4.
Proof.
  reflexivity. Qed.

(** Exercise: 1 points (test_double) *)
Example test_double1 : double 1 = 2.
Proof.
  reflexivity. Qed.

Example test_double2 : double 2 = 4.
Proof.
  reflexivity. Qed.

Example test_double3 : double 3 = 6.
Proof.
  reflexivity. Qed.

(* Exercise: 2 point (leb) *)
Fixpoint leb (n m : nat) : bool :=
  match n, m with
  | 0, _ => true
  | S n', 0 => false
  | S n', S m' => leb n' m'
  end.

(* Exercise: 2 point (leb_refl) *)
Theorem leb_refl : forall n, leb n n = true.
Proof.
  induction n; eauto.
Qed.

(* Exercise: 3 point (leb_succ) *)
(* State and prove that [n] is smaller than or equal to [S n]. *)
Theorem leb_succ :
  forall n, true = leb n (S n).
Proof.
  induction n; eauto.
Qed.

Lemma leb_trans : forall m n p,
    leb m n = true -> leb n p = true -> leb m p = true.
Proof.
  induction m; intros.
  - eauto.
  - destruct n, p; eauto; easy.
Qed.

(* Exercise: 3 point (leb_double) *)
(* State and prove that [n] is smaller than or equal to [double n]. *)
Theorem leb_double :
  forall n, leb n (double n) = true.
Proof.
  induction n.
  simpl. reflexivity.
  simpl.
  eapply leb_trans.
  eauto.
  symmetry.
  apply leb_succ.
Qed.

(* Exercise: 10 point (plus_1) *)
Theorem plus_1 : forall n, plus n 1 = S n.
Proof.
  induction n; simpl; eauto.
Qed.

github-repos/coq/ccyip-CS565Grader/CS565Grader-6e3c9497d99f416097b6ed521f0558ae631cefc9/example/for_grader/input/hw/00000-135266 - Smart Ass - Nov 23, 2020 1226 PM/hw.v


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrfun ssrbool eqtype ssrnat seq div.
From mathcomp
Require Import fintype bigop finset prime fingroup ssralg finalg countalg.

(******************************************************************************)
(*  Definition of the additive group and ring Zp, represented as 'I_p         *)
(******************************************************************************)
(* Definitions:                                                               *)
(* From fintype.v:                                                            *)
(*     'I_p == the subtype of integers less than p, taken here as the type of *)
(*             the integers mod p.                                            *)
(* This file:                                                                 *)
(*     inZp == the natural projection from nat into the integers mod p,       *)
(*             represented as 'I_p. Here p is implicit, but MUST be of the    *)
(*             form n.+1.                                                     *)
(* The operations:                                                            *)
(*      Zp0 == the identity element for addition                              *)
(*      Zp1 == the identity element for multiplication, and a generator of    *)
(*             additive group                                                 *)
(*   Zp_opp == inverse function for addition                                  *)
(*   Zp_add == addition                                                       *)
(*   Zp_mul == multiplication                                                 *)
(*   Zp_inv == inverse function for multiplication                            *)
(* Note that while 'I_n.+1 has canonical finZmodType and finGroupType         *)
(* structures, only 'I_n.+2 has a canonical ring structure (it has, in fact,  *)
(* a canonical finComUnitRing structure), and hence an associated             *)
(* multiplicative unit finGroupType. To mitigate the issues caused by the     *)
(* trivial "ring" (which is, indeed is NOT a ring in the ssralg/finalg        *)
(* formalization), we define additional notation:                             *)
(*       'Z_p == the type of integers mod (max p 2); this is always a proper  *)
(*               ring, by constructions. Note that 'Z_p is provably equal to  *)
(*               'I_p if p > 1, and convertible to 'I_p if p is of the form   *)
(*               n.+2.                                                        *)
(*       Zp p == the subgroup of integers mod (max p 1) in 'Z_p; this is thus *)
(*               is thus all of 'Z_p if p > 1, and else the trivial group.    *)
(* units_Zp p == the group of all units of 'Z_p -- i.e., the group of         *)
(*               (multiplicative) automorphisms of Zp p.                      *)
(* We show that Zp and units_Zp are abelian, and compute their orders.        *)
(* We use a similar technique to represent the prime fields:                  *)
(*        'F_p == the finite field of integers mod the first prime divisor of *)
(*                maxn p 2. This is provably equal to 'Z_p and 'I_p if p is   *)
(*                provably prime, and indeed convertible to the above if p is *)
(*                a concrete prime such as 2, 5 or 23.                        *)
(* Note finally that due to the canonical structures it is possible to use    *)
(* 0%R instead of Zp0, and 1%R instead of Zp1 (for the latter, p must be of   *)
(* the form n.+2, and 1%R : nat will simplify to 1%N).                        *)
(******************************************************************************)

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

Local Open Scope ring_scope.

Section ZpDef.

(***********************************************************************)
(*                                                                     *)
(*  Mod p arithmetic on the finite set {0, 1, 2, ..., p - 1}           *)
(*                                                                     *)
(***********************************************************************)

Variable p' : nat.
Local Notation p := p'.+1.

Implicit Types x y z : 'I_p.

(* Standard injection; val (inZp i) = i %% p *)
Definition inZp i := Ordinal (ltn_pmod i (ltn0Sn p')).
Lemma modZp x : x %% p = x.
Proof. by rewrite modn_small ?ltn_ord. Qed.
Lemma valZpK x : inZp x = x.
Proof. by apply: val_inj; rewrite /= modZp. Qed.

(* Operations *)
Definition Zp0 : 'I_p := ord0.
Definition Zp1 := inZp 1.
Definition Zp_opp x := inZp (p - x).
Definition Zp_add x y := inZp (x + y).
Definition Zp_mul x y := inZp (x * y).
Definition Zp_inv x := if coprime p x then inZp (egcdn x p).1 else x.

(* Additive group structure. *)

Lemma Zp_add0z : left_id Zp0 Zp_add.
Proof. exact: valZpK. Qed.

Lemma Zp_addNz : left_inverse Zp0 Zp_opp Zp_add.
Proof.
by move=> x; apply: val_inj; rewrite /= modnDml subnK ?modnn // ltnW.
Qed.

Lemma Zp_addA : associative Zp_add.
Proof.
by move=> x y z; apply: val_inj; rewrite /= modnDml modnDmr addnA.
Qed.

Lemma Zp_addC : commutative Zp_add.
Proof. by move=> x y; apply: val_inj; rewrite /= addnC. Qed.

Definition Zp_zmodMixin := ZmodMixin Zp_addA Zp_addC Zp_add0z Zp_addNz.
Canonical Zp_zmodType := Eval hnf in ZmodType 'I_p Zp_zmodMixin.
Canonical Zp_finZmodType := Eval hnf in [finZmodType of 'I_p].
Canonical Zp_baseFinGroupType := Eval hnf in [baseFinGroupType of 'I_p for +%R].
Canonical Zp_finGroupType := Eval hnf in [finGroupType of 'I_p for +%R].

(* Ring operations *)

Lemma Zp_mul1z : left_id Zp1 Zp_mul.
Proof. by move=> x; apply: val_inj; rewrite /= modnMml mul1n modZp. Qed.

Lemma Zp_mulC : commutative Zp_mul.
Proof. by move=> x y; apply: val_inj; rewrite /= mulnC. Qed.

Lemma Zp_mulz1 : right_id Zp1 Zp_mul.
Proof. by move=> x; rewrite Zp_mulC Zp_mul1z. Qed.

Lemma Zp_mulA : associative Zp_mul.
Proof.
by move=> x y z; apply: val_inj; rewrite /= modnMml modnMmr mulnA.
Qed.

Lemma Zp_mul_addr : right_distributive Zp_mul Zp_add.
Proof.
by move=> x y z; apply: val_inj; rewrite /= modnMmr modnDm mulnDr.
Qed.

Lemma Zp_mul_addl : left_distributive Zp_mul Zp_add.
Proof. by move=> x y z; rewrite -!(Zp_mulC z) Zp_mul_addr. Qed.

Lemma Zp_mulVz x : coprime p x -> Zp_mul (Zp_inv x) x = Zp1.
Proof.
move=> co_p_x; apply: val_inj; rewrite /Zp_inv co_p_x /= modnMml.
by rewrite -(chinese_modl co_p_x 1 0) /chinese addn0 mul1n mulnC.
Qed.

Lemma Zp_mulzV x : coprime p x -> Zp_mul x (Zp_inv x) = Zp1.
Proof. by move=> Ux; rewrite /= Zp_mulC Zp_mulVz. Qed.

Lemma Zp_intro_unit x y : Zp_mul y x = Zp1 -> coprime p x.
Proof.
case=> yx1; have:= coprimen1 p.
by rewrite -coprime_modr -yx1 coprime_modr coprime_mulr; case/andP.
Qed.

Lemma Zp_inv_out x : ~~ coprime p x -> Zp_inv x = x.
Proof. by rewrite /Zp_inv => /negPf->. Qed.

Lemma Zp_mulrn x n : x *+ n = inZp (x * n).
Proof.
apply: val_inj => /=; elim: n => [|n IHn]; first by rewrite muln0 modn_small.
by rewrite !GRing.mulrS /= IHn modnDmr mulnS.
Qed.

Import GroupScope.

Lemma Zp_mulgC : @commutative 'I_p _ mulg.
Proof. exact: Zp_addC. Qed.

Lemma Zp_abelian : abelian [set: 'I_p].
Proof. exact: FinRing.zmod_abelian. Qed.

Lemma Zp_expg x n : x ^+ n = inZp (x * n).
Proof. exact: Zp_mulrn. Qed.

Lemma Zp1_expgz x : Zp1 ^+ x = x.
Proof. by rewrite Zp_expg; apply: Zp_mul1z. Qed.

Lemma Zp_cycle : setT = <[Zp1]>.
Proof. by apply/setP=> x; rewrite -[x]Zp1_expgz inE groupX ?mem_gen ?set11. Qed.

Lemma order_Zp1 : #[Zp1] = p.
Proof. by rewrite orderE -Zp_cycle cardsT card_ord. Qed.

End ZpDef.

Arguments Zp0 {p'}.
Arguments Zp1 {p'}.
Arguments inZp {p'} i.
Arguments valZpK {p'} x.

Lemma ord1 : all_equal_to (0 : 'I_1).
Proof. by case=> [[] // ?]; apply: val_inj. Qed.

Lemma lshift0 m n : lshift m (0 : 'I_n.+1) = (0 : 'I_(n + m).+1).
Proof. exact: val_inj. Qed.

Lemma rshift1 n : @rshift 1 n =1 lift (0 : 'I_n.+1).
Proof. by move=> i; apply: val_inj. Qed.

Lemma split1 n i :
  split (i : 'I_(1 + n)) = oapp (@inr _ _) (inl _ 0) (unlift 0 i).
Proof.
case: unliftP => [i'|] -> /=.
  by rewrite -rshift1 (unsplitK (inr _ _)).
by rewrite -(lshift0 n 0) (unsplitK (inl _ _)).
Qed.

Lemma big_ord1 R idx (op : @Monoid.law R idx) F :
  \big[op/idx]_(i < 1) F i = F 0.
Proof. by rewrite big_ord_recl big_ord0 Monoid.mulm1. Qed.

Lemma big_ord1_cond R idx (op : @Monoid.law R idx) P F :
  \big[op/idx]_(i < 1 | P i) F i = if P 0 then F 0 else idx.
Proof. by rewrite big_mkcond big_ord1. Qed.

Section ZpRing.

Variable p' : nat.
Local Notation p := p'.+2.

Lemma Zp_nontrivial : Zp1 != 0 :> 'I_p. Proof. by []. Qed.

Definition Zp_ringMixin :=
  ComRingMixin (@Zp_mulA _) (@Zp_mulC _) (@Zp_mul1z _) (@Zp_mul_addl _)
               Zp_nontrivial.
Canonical Zp_ringType := Eval hnf in RingType 'I_p Zp_ringMixin.
Canonical Zp_finRingType := Eval hnf in [finRingType of 'I_p].
Canonical Zp_comRingType := Eval hnf in ComRingType 'I_p (@Zp_mulC _).
Canonical Zp_finComRingType := Eval hnf in [finComRingType of 'I_p].

Definition Zp_unitRingMixin :=
  ComUnitRingMixin (@Zp_mulVz _) (@Zp_intro_unit _) (@Zp_inv_out _).
Canonical Zp_unitRingType := Eval hnf in UnitRingType 'I_p Zp_unitRingMixin.
Canonical Zp_finUnitRingType := Eval hnf in [finUnitRingType of 'I_p].
Canonical Zp_comUnitRingType := Eval hnf in [comUnitRingType of 'I_p].
Canonical Zp_finComUnitRingType := Eval hnf in [finComUnitRingType of 'I_p].

Lemma Zp_nat n : n%:R = inZp n :> 'I_p.
Proof. by apply: val_inj; rewrite [n%:R]Zp_mulrn /= modnMml mul1n. Qed.

Lemma natr_Zp (x : 'I_p) : x%:R = x.
Proof. by rewrite Zp_nat valZpK. Qed.

Lemma natr_negZp (x : 'I_p) : (- x)%:R = - x.
Proof. by apply: val_inj; rewrite /= Zp_nat /= modn_mod. Qed.

Import GroupScope.

Lemma unit_Zp_mulgC : @commutative {unit 'I_p} _ mulg.
Proof. by move=> u v; apply: val_inj; rewrite /= GRing.mulrC. Qed.

Lemma unit_Zp_expg (u : {unit 'I_p}) n :
  val (u ^+ n) = inZp (val u ^ n) :> 'I_p.
Proof.
apply: val_inj => /=; elim: n => [|n IHn] //.
by rewrite expgS /= IHn expnS modnMmr.
Qed.

End ZpRing.

Definition Zp_trunc p := p.-2.

Notation "''Z_' p" := 'I_(Zp_trunc p).+2
  (at level 8, p at level 2, format "''Z_' p") : type_scope.
Notation "''F_' p" := 'Z_(pdiv p)
  (at level 8, p at level 2, format "''F_' p") : type_scope.

Arguments natr_Zp {p'} x.

Section Groups.

Variable p : nat.

Definition Zp := if p > 1 then [set: 'Z_p] else 1%g.
Definition units_Zp := [set: {unit 'Z_p}].

Lemma Zp_cast : p > 1 -> (Zp_trunc p).+2 = p.
Proof. by case: p => [|[]]. Qed.

Lemma val_Zp_nat (p_gt1 : p > 1) n : (n%:R : 'Z_p) = (n %% p)%N :> nat.
Proof. by rewrite Zp_nat /= Zp_cast. Qed.

Lemma Zp_nat_mod (p_gt1 : p > 1)m : (m %% p)%:R = m%:R :> 'Z_p.
Proof. by apply: ord_inj; rewrite !val_Zp_nat // modn_mod. Qed.

Lemma char_Zp : p > 1 -> p%:R = 0 :> 'Z_p.
Proof. by move=> p_gt1; rewrite -Zp_nat_mod ?modnn. Qed.

Lemma unitZpE x : p > 1 -> ((x%:R : 'Z_p) \is a GRing.unit) = coprime p x.
Proof.
by move=> p_gt1; rewrite qualifE /= val_Zp_nat ?Zp_cast ?coprime_modr.
Qed.

Lemma Zp_group_set : group_set Zp.
Proof. by rewrite /Zp; case: (p > 1); apply: groupP. Qed.
Canonical Zp_group := Group Zp_group_set.

Lemma card_Zp : p > 0 -> #|Zp| = p.
Proof.
rewrite /Zp; case: p => [|[|p']] //= _; first by rewrite cards1.
by rewrite cardsT card_ord.
Qed.

Lemma mem_Zp x : p > 1 -> x \in Zp. Proof. by rewrite /Zp => ->. Qed.

Canonical units_Zp_group := [group of units_Zp].

Lemma card_units_Zp : p > 0 -> #|units_Zp| = totient p.
Proof.
move=> p_gt0; transitivity (totient p.-2.+2); last by case: p p_gt0 => [|[|p']].
rewrite cardsT card_sub -sum1_card big_mkcond /=.
by rewrite totient_count_coprime big_mkord.
Qed.

Lemma units_Zp_abelian : abelian units_Zp.
Proof. by apply/centsP=> u _ v _; apply: unit_Zp_mulgC. Qed.

End Groups.

(* Field structure for primes. *)

Section PrimeField.

Open Scope ring_scope.

Variable p : nat.

Section F_prime.

Hypothesis p_pr : prime p.

Lemma Fp_Zcast : (Zp_trunc (pdiv p)).+2 = (Zp_trunc p).+2.
Proof. by rewrite /pdiv primes_prime. Qed.

Lemma Fp_cast : (Zp_trunc (pdiv p)).+2 = p.
Proof. by rewrite Fp_Zcast ?Zp_cast ?prime_gt1. Qed.

Lemma card_Fp : #|'F_p| = p.
Proof. by rewrite card_ord Fp_cast. Qed.

Lemma val_Fp_nat n : (n%:R : 'F_p) = (n %% p)%N :> nat.
Proof. by rewrite Zp_nat /= Fp_cast. Qed.

Lemma Fp_nat_mod m : (m %% p)%:R = m%:R :> 'F_p.
Proof. by apply: ord_inj; rewrite !val_Fp_nat // modn_mod. Qed.

Lemma char_Fp : p \in [char 'F_p].
Proof. by rewrite !inE -Fp_nat_mod p_pr ?modnn. Qed.

Lemma char_Fp_0 : p%:R = 0 :> 'F_p.
Proof. exact: GRing.charf0 char_Fp. Qed.

Lemma unitFpE x : ((x%:R : 'F_p) \is a GRing.unit) = coprime p x.
Proof. by rewrite pdiv_id // unitZpE // prime_gt1. Qed.

End F_prime.

Lemma Fp_fieldMixin : GRing.Field.mixin_of [the unitRingType of 'F_p].
Proof.
move=> x nzx; rewrite qualifE /= prime_coprime ?gtnNdvd ?lt0n //.
case: (ltnP 1 p) => [lt1p | ]; last by case: p => [|[|p']].
by rewrite Zp_cast ?prime_gt1 ?pdiv_prime.
Qed.

Definition Fp_idomainMixin := FieldIdomainMixin Fp_fieldMixin.

Canonical Fp_idomainType := Eval hnf in IdomainType 'F_p  Fp_idomainMixin.
Canonical Fp_finIdomainType := Eval hnf in [finIdomainType of 'F_p].
Canonical Fp_fieldType := Eval hnf in FieldType 'F_p Fp_fieldMixin.
Canonical Fp_finFieldType := Eval hnf in [finFieldType of 'F_p].
Canonical Fp_decFieldType :=
  Eval hnf in [decFieldType of 'F_p for Fp_finFieldType].

End PrimeField.

Canonical Zp_countZmodType m := [countZmodType of 'I_m.+1].
Canonical Zp_countRingType m := [countRingType of 'I_m.+2].
Canonical Zp_countComRingType m := [countComRingType of 'I_m.+2].
Canonical Zp_countUnitRingType m := [countUnitRingType of 'I_m.+2].
Canonical Zp_countComUnitRingType m := [countComUnitRingType of 'I_m.+2].
Canonical Fp_countIdomainType p := [countIdomainType of 'F_p].
Canonical Fp_countFieldType p := [countFieldType of 'F_p].
Canonical Fp_countDecFieldType p := [countDecFieldType of 'F_p].


Require Export NatList.

Check (pair 3 4).

Inductive list (X: Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

Check nil.
Check nil nat.

Check cons.

Check cons nat.
Check cons nat 3.
Check cons nat 3 (nil nat).

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

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

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

Module MumbleGrumble.

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

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

Check d.
Check d nat.
Check e.
Check e nat.

(* d (b a 5 ) is invalid *)

Check d nat (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). is not valid *)

End MumbleGrumble.

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

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

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

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

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

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

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

Fail Definition mynil := nil.

Definition mynil : list nat := nil.

Check nil.

Check @nil.

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

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

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
  intros X l.
  induction l as [| n l'].
  - simpl. reflexivity.
  - simpl. rewrite -> IHl'. reflexivity.
Qed.

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros A l m n.
  induction l.
  - simpl. reflexivity.
  - simpl. rewrite -> IHl. reflexivity.
Qed.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros X l1 l2.
  induction l1.
  - simpl. reflexivity.
  - simpl. rewrite -> IHl1. reflexivity.
Qed.

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros X l1 l2.
  induction l1.
  - simpl. rewrite -> app_nil_r. reflexivity.
  - simpl. rewrite -> IHl1. rewrite -> app_assoc.
    reflexivity.
Qed.

Theorem rev_involutive_helper : forall X : Type, forall l : list X, forall x: X,
      rev (l ++ [x]) = [x] ++ rev l.
Proof.
  intros X l x.
  induction l.
  - simpl. reflexivity.
  - simpl.
    rewrite -> IHl.
    rewrite <- app_assoc at 1.
    simpl. reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros X l.
  induction l.
  - simpl. reflexivity.
  - simpl.
    rewrite -> rev_involutive_helper.
    rewrite -> IHl at 1.
    simpl.
    reflexivity.
Qed.

Inductive prod (X Y : Type) : Type :=
| pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

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

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

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.

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.

Check @combine.

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

Fixpoint split {A B} (l : list (A * B)) : list A * list B :=
  match l with
    [] => ([], [])
  | (x, y) :: xs => let (xs2, ys2) := split xs in (x::xs2, y::ys2)
  end.

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

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

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

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

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

Definition doit3times {X:Type} (f:X -> X) (n:X) : X :=
  f (f (f 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.

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.

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.

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.

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

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.

Check filter.

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

Check ble_nat.
Print ble_nat.
Locate ble_nat.
Check and.
Locate and.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun n => andb (is_even n) (ble_nat 8 n)) l.

Eval compute in filter_even_gt7 [1;2;6;9;10;3;12;8].

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

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

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

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

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

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

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

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.

Lemma map_helper : forall (X Y : Type) (f : X -> Y) (a b : list X),
    map f (a ++ b) = map f a ++ map f b.
Proof.
  intros X Y f a b.
  induction a as [|].
  - simpl. reflexivity.
  - simpl. rewrite -> IHa. reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros X Y f l.
  induction l as [| n l' IHl].
  - simpl. reflexivity.
  - simpl.
    rewrite -> map_helper with (a := rev l') (b := [n]) at 1.
    rewrite -> IHl at 1.
    simpl.
    reflexivity.
Qed.

Fixpoint flat_map {X Y:Type} (f:X -> list Y) (l:list X) : (list Y) :=
  match l with
    | [] => []
    | (x :: xs) => 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.

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.

Check (fold andb).

Eval compute in (fold andb [true; true; false] true).

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.

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.

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.

Module Exercises.

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.

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
  intros X l.
  induction l as [| n l' IHl'].
  - simpl.
    unfold fold_length.
    simpl.
    reflexivity.
  - simpl.
    unfold fold_length.
    simpl.
    fold (fold_length l').
    rewrite -> IHl'.
    reflexivity.
Qed.

Check fold.

Definition fold_map {X Y:Type} (f : X -> Y) (l : list X) : list Y :=
  fold (fun y ys => f y :: ys) l [].

Theorem fold_map_correct: forall X Y (l : list X) (f : X -> Y),
    map f l = fold_map f l.
Proof.
  intros X Y l f.
  induction l as [|n l' IHl'].
  - simpl.
    unfold fold_map.
    simpl.
    reflexivity.
  - simpl.
    unfold fold_map.
    simpl.
    fold (fold_map f l').
    rewrite -> IHl'.
    reflexivity.
Qed.

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

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z := f (fst p) (snd p).

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

(* prod_curry : forall X Y Z :Type, (f : X * Y -> Z) -> (x : X) (y : Y) : Z *)

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type)
                        (f : X -> Y -> Z)
                        x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
  intros X Y Z f x y.
  unfold prod_uncurry.
  unfold prod_curry.
  simpl.
  reflexivity.
Qed.

Lemma fst_snd : forall (X Y : Type) (a : X) (b : Y),
    (fst (a,b), snd (a,b)) = (a,b).
Proof.
  intros X Y a b.
  simpl.
  reflexivity.
Qed.

Lemma fst_snd_p : forall (X Y : Type) (p : X * Y),
    (fst p, snd p) = p.
Proof.
  intros X Y p.
  destruct p.
  - simpl. reflexivity. Qed.

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

Theorem nth_theorem : forall X n l,
  length l = n -> @nth_error X l n = None.
Proof.
  intros X n l.
  intros H.
  induction n as [|].
Abort.

End Exercises.


Require Import Logic.Rel.R.
Require Import Logic.Rel.Id.
Require Import Logic.Rel.Include.
Require Import Logic.Rel.Function.
Require Import Logic.Rel.Converse.
Require Import Logic.Rel.Composition.

Lemma shunting_rule_left :
    forall (a b c:Type) (r:R a b) (f:R b c) (s:R a c), Function f ->
        f ; r <= s <-> r <= conv f ; s.
Proof.
    intros a b c r f s [H1 H2]. split; intros H3.
    - apply incl_trans with ((conv f; f) ; r).
        + remember ((conv f; f) ; r) as e eqn:E. rewrite <- (id_left _ _ r).
          rewrite E. clear e E. apply incl_comp_compat_l. assumption.
        + rewrite comp_assoc. apply incl_comp_compat_r. assumption.
    - apply incl_trans with ((f ; conv f) ; s).
        + rewrite comp_assoc. apply incl_comp_compat_r. assumption.
        + remember ((f ; conv f) ; s) as e eqn:E. rewrite <- (id_left _ _ s).
          rewrite E. clear e E. apply incl_comp_compat_l. assumption.
Qed.

Lemma shunting_rule_right :
    forall (a b c:Type) (f:R b a) (r:R b c) (s:R a c), Function f ->
        r ; conv f <= s <-> r <= s ; f.
Proof.
    intros a b c f r s [H1 H2]. split; intros H3.
    - apply incl_trans with (r; (conv f; f)).
        + remember (r ; (conv f; f)) as e eqn:E. rewrite <- (id_right _ _ r).
          rewrite E. clear e E. apply incl_comp_compat_r. assumption.
        + rewrite <- comp_assoc. apply incl_comp_compat_l. assumption.
    - apply incl_trans with (s; (f ; conv f)).
        + rewrite <- comp_assoc. apply incl_comp_compat_l. assumption.
        + remember (s ; (f ; conv f)) as e eqn:E. rewrite <- (id_right _ _ s).
          rewrite E. clear e E. apply incl_comp_compat_r. assumption.
Qed.

Lemma shunting_rev_left : forall (b c:Type) (f:R b c),
    (forall (a:Type) (r:R a b) (s:R a c), f ; r <= s <-> r <= conv f ; s) ->
    Function f.
Proof.
    intros b c f H1. split.
    - apply (H1 _ (conv f) id). rewrite id_right. apply incl_refl.
    - apply (H1 _ id f). rewrite id_right. apply incl_refl.
Qed.

Lemma shunting_rev_right : forall (a b:Type) (f:R b a),
    (forall (c:Type) (r:R b c) (s:R a c), r ; conv f <= s <-> r <= s ; f) ->
    Function f.
Proof.
    intros a b f H1. split.
   - apply (H1 _ f id). rewrite id_left. apply incl_refl.
   - apply (H1 _ id (conv f)). rewrite id_left. apply incl_refl.
Qed.


(* 問1 *)
Theorem ex1 : forall x, x = 1 -> x + 1 = 2.
Proof.
  intros x H.
  rewrite H.
  reflexivity.
Qed.

(* 問2 *)
(* 1.9 *)
Inductive list (A : Set) : Set :=
  | Nil  : list A
  | Cons : A -> list A -> list A.

(* 1.10 *)
Implicit Arguments Nil  [A].
Implicit Arguments Cons [A].

(* 1.11 *)
Infix "::" := Cons (at level 60, right associativity).

(* 1.12 *)
Fixpoint length {A : Set} (xs : list A) :=
  match xs with
    | Nil      => 0
    | x :: xs' => 1 + length xs'
  end.

(* 1.13 *)
Fixpoint app {A : Set} (xs ys : list A) :=
  match xs with
    | Nil      => ys
    | x :: xs' => x :: app xs' ys
  end.

(* 1.14 *)
Infix "++" := app (at level 60, right associativity).

Fixpoint map_succ (xs : list nat) : list nat :=
  match xs with
    | Nil      => Nil
    | x :: xs' => (x + 1) :: map_succ xs'
  end.

(* 問3 *)
Theorem map_succ_length : forall (xs : list nat),
                            length (map_succ xs) = length xs.
Proof.
  intros xs.
  induction xs.

  reflexivity.

  simpl.
  rewrite IHxs.
  reflexivity.
Qed.

(* おまけ *)
(* map_succ して map_pred で戻る *)

Fixpoint map_pred (xs : list nat) : list nat :=
  match xs with
    | Nil      => Nil
    | x :: xs' => (x - 1) :: map_pred xs'
  end.

Require Import Arith.

Theorem map_succ_pred : forall (xs : list nat),
                          map_pred (map_succ xs) = xs.
Proof.
  intros xs.
  induction xs.

  simpl.
  reflexivity.

  unfold map_succ.
  unfold map_pred.
  rewrite plus_comm.
  rewrite minus_plus.
  fold map_pred.
  fold map_succ.
  rewrite IHxs.
  reflexivity.
Qed.


Require Import TestCommon.
Require Import Equations.

(*

This file implements a list type with type-level-encoded length, called Vector.

We introduce two phantom types: Zero : * and Succ : * -> *, to encode natural numbers on typelevel.

It has the following constructors:
data Vector A N
  empty : () -> Vector a Zero
  cons : (a * Vector a n) -> Vector a (Succ n)

or in dotty:
trait Zero
trait Succ[N]

enum Vector[A,N] {
  case Empty[A](unused: Unit) extends Vector[A, Zero]
  case Cons[A, N](data: (A, Vector[A, N])) extends Vector[A, Succ[N]]
}

Then we wrap the constructors as functions (just as an exercise):
  empty': forall a, Vector a Zero
  cons' : forall a n, a -> Vector a n -> Vector a (Succ n)
or in dotty:
  def empty[A]: Vector[A, Zero]
  def cons[A,N](head: A)(tail: Vector[A, N]): Vector[A, Succ[N]]

we can create a vector containing two units:
  uvec = (cons () (cons () empty)) // I skip the type args here, they are elaborated in the proof
  uvec : Vector Unit (Succ (Succ Zero))

we can create a map function that guarantees that it preserves length:
  map : forall a b n, (a -> b) -> Vector a n -> Vector b n

then we implement the 'safe' head function that works only on non-empty vectors:
  head : forall a n, Vector a (Succ n) -> a
  def head[A,N](v: Vector[A, Succ[N]]): A
this will be an occassion to show how we handle contradictory branches:
- we may use the contradictory type equalities to prove that unit: A for every a and just return it

another showcase of GADT abilities will be a typesafe zip function that only allows to zip vectors of equal length
  zip : forall a b n, Vector a n -> Vector b n -> Vector (a * b) n
  def zip[A,B,N](va: Vector[A,N])(vb: Vector[B,N]): Vector[(A,B), N]

  append (nat - plus)
*)

(* type level natural numbers *)
Axiom Zero : var.
Axiom Succ : var.
Axiom Vector : var.

Open Scope L2GMu.
Axiom all_distinct :
  (Zero <> Succ) /\ (Succ <> Vector) /\ (Zero <> Vector).

(* De Bruijn indices for arguments are in 'reverse' order, that is the last arg on the list is treated as 'closest' and referred to as ##0 *)
Definition VectorDef := (* Vector a len *)
  enum 2 {{
         (* empty : forall a, () -> Vector a Zero *)
         mkGADTconstructor 1 typ_unit [##0; γ() Zero]* |
         (* cons : forall a n, (a * Vector a n) -> Vector a (Succ n) *)
         mkGADTconstructor 2 (##1 ** γ(##1, ##0) Vector) [##1; γ(##0) Succ]*
         }}
.

Definition sigma :=
  empty
    (* Zero and Succ are phantom types, but we add them constructors as at least one constructor is required for consistency *)
  & Zero ~ enum 0 {{
           mkGADTconstructor 0 typ_unit []*
         }}
  & Succ ~ enum 1 {{
           mkGADTconstructor 1 typ_unit [##0]*
         }}
  & Vector ~ VectorDef.

Lemma oksigma : okGadt sigma.
Proof.
  unfold sigma.
  unfold VectorDef.
  lets [? [? ?]]: all_distinct.
  lets: is_var_defined_split.
  econstructor; autotyper1;
    try congruence;
    try econstructor; autotyper1;
      destruct_const_len_list;
      autotyper1;
      repeat rewrite union_empty_r; auto.
Qed.

Definition Nil := (Vector, 0).
Definition Cons := (Vector, 1).

Definition nil A := new Nil [| A |] (trm_unit).
Definition cons A N h t := new Cons [|A, N|]  (trm_tuple h t).

Lemma nil_type : {sigma, emptyΔ, empty} ⊢(Treg) (Λ => nil (##0)) ∈ typ_all (γ(##0, γ() Zero) Vector).
Proof.
  cbv.
  lets: oksigma.
  autotyper1.
Qed.

Ltac distinct22 :=
  lazymatch goal with
  | |- ?a <> ?b =>
    match goal with
    | H: a \in ?S -> False |- _ =>
      intro; apply H; subst; apply in_singleton_self
    | H: b \in ?S -> False |- _ =>
      intro; apply H; subst; apply in_singleton_self
    end
  end.

Ltac free_abs :=
  unshelve econstructor; cbv; try (let v := gather_vars in exact v).

Lemma notin_eqv : forall A (x : A) L,
    (x \in L -> False) <-> x \notin L.
Proof.
  introv.
  intuition.
Qed.

Lemma cons_type :
  {sigma, emptyΔ, empty} ⊢(Treg)
                         (Λ => Λ =>
                          (λ ##1 => λ γ(##1, ##0) Vector =>
                           cons (##1) (##0) (#1) (#0)
                         ))
                         ∈
                         ∀ ∀ (##1 ==> (γ(##1, ##0) Vector) ==> (γ(##1, γ(##0) Succ) Vector)).
Proof.
  cbv.
  lets: oksigma.
  autotyper1.
Qed.

Definition GZ := γ() Zero.
Definition GS (T : typ) := γ(T) Succ.

Definition uvec2 := cons typ_unit (GS GZ) trm_unit (cons typ_unit GZ trm_unit (nil typ_unit)).

Definition two := GS (GS GZ).
Lemma uvec2_type : {sigma, emptyΔ, empty} ⊢(Treg) uvec2 ∈ γ(typ_unit, two) Vector.
Proof.
  cbv.
  lets: oksigma.
  lets [? [? ?]]: all_distinct.
  autotyper1.
Qed.

(*
head : ∀a. ∀n. ((a, (n) Succ) Vector) -> a
head = Λa. Λn. λv: ((a, (n) Succ) Vector).
        case v of {
          Nil[a2](unused) => <>
        | Cons[a2, n2](da) => fst(da)
        }
The term below has been generated from the pseudocode above using the converter tool.
*)
Definition head_trm :=
  trm_tabs (trm_tabs (trm_abs (typ_gadt [##1; typ_gadt [##0]* Succ]* Vector) (trm_matchgadt (#0) Vector [clause 2 (trm_fst (#0)); clause 1 (trm_unit)]*)))
.
Definition head_typ :=
  ∀ ∀ (γ(##1, γ(##0) Succ) Vector ==> ##1).

Lemma head_types : {sigma, emptyΔ, empty} ⊢(Treg) head_trm ∈ head_typ.
Proof.
cbv.
lets: oksigma.
  lets [? [? ?]]: all_distinct.
autotyper4;
  try solve[
    cbn in *;
    destruct_const_len_list;
    cbn; autotyper4
  ].
  - forwards*: H6 v. cbn in *.
    eapply typing_eq.
    + autotyper4.
    + unfold entails_semantic.
      intros O OM.
      exfalso.
      repeat (
        match goal with
        | H: subst_matches_typctx ?A ?B ?C |- _ =>
          inversions H
        end
      ).
      repeat (
        match goal with
        | H: wft ?A ?B ?C |- _ =>
          clear H
        end
      ).
      cbn in *.
      congruence.
    + autotyper4.
  - forwards*: H6 v.
    forwards*: H6 v0.
    cbn in *.
    eapply typing_eq.
    + autotyper4.
    + apply teq_symmetry.
      apply teq_axiom; listin.
    + autotyper4.
  Unshelve.
  fs. fs. fs.
Qed.

(*
zip : ∀a. ∀b. ∀n. ((a,n) Vector -> (b,n) Vector -> (a * b,n) Vector
zip = fix $self: (∀a. ∀b. ∀n. ((a,n) Vector -> (b,n) Vector -> (a * b,n) Vector)).
        Λa. Λb. Λn. λva: ((a,n) Vector). λvb: ((b,n) Vector). case va of {
            Nil[a2](unused) => Nil[a * b](<>)
          | Cons[a2, n2](da) =>
            case vb of {
              Nil[b2](unused) => <>
            | Cons[b2, n3](db) =>
                let h = <fst(da), fst(db)> in
                  let t = (((($self[a])[b])[n2]) (snd(da))) (snd(db)) in
                    Cons[(a*b),n2](<h, t>)
                  end
                end
            }
          }
The term below has been generated from the pseudocode above using the converter tool.
*)
Definition zip_trm :=
  trm_fix (typ_all (typ_all (typ_all ((typ_gadt [##2; ##0]* Vector) ==> ((typ_gadt [##1; ##0]* Vector) ==> (typ_gadt [(##2) ** (##1); ##0]* Vector)))))) (trm_tabs (trm_tabs (trm_tabs (trm_abs (typ_gadt [##2; ##0]* Vector) (trm_abs (typ_gadt [##1; ##0]* Vector) (trm_matchgadt (#1) Vector [clause 2 (trm_matchgadt (#1) Vector [clause 2 (trm_let (trm_tuple (trm_fst (#1)) (trm_fst (#0))) (trm_let (trm_app (trm_app (trm_tapp (trm_tapp (trm_tapp (#5) (##6)) (##5)) (##2)) (trm_snd (#2))) (trm_snd (#1))) (trm_constructor [(##6) ** (##5); ##2]* (Vector, 1) (trm_tuple (#1) (#0))))); clause 1 (trm_unit)]*); clause 1 (trm_constructor [(##3) ** (##2)]* (Vector, 0) (trm_unit))]*))))))
.

Definition zip_typ :=
  ∀ ∀ ∀ (γ(##2, ##0) Vector ==> γ(##1, ##0) Vector ==> γ(##2 ** ##1, ##0) Vector).

Lemma zip_types : {sigma, emptyΔ, empty} ⊢(Treg) zip_trm ∈ zip_typ.
Proof.
cbv.
lets: oksigma.
  lets [? [? ?]]: all_distinct.
autotyper4;
  try solve[
    cbn in *;
    destruct_const_len_list;
    cbn; autotyper4
  ].
  - forwards*: H6 v.
    eapply typing_eq with (γ( x1 ** x2, (γ() Zero)) Vector) _;
      try solve[autotyper4].
      apply eq_typ_gadt.
      apply F2_iff_In_zip.
      split~.
      intros.
      repeat ininv2.
      + apply teq_symmetry.
        apply teq_axiom. listin.
      + apply teq_reflexivity.
  - forwards*: H6 v.
    forwards*: H6 v0.
    cbn in *.
    apply Tgen_from_any with Treg.
    autotyper4.
    + cbn in *.
      forwards*: H12 v1.
      eapply typing_eq.
      * autotyper4.
      * unfold entails_semantic.
        intros O OM.
        exfalso.
        repeat (
          match goal with
          | H: subst_matches_typctx ?A ?B ?C |- _ =>
            inversions H
          end
        ).
        repeat (
          match goal with
          | H: wft ?A ?B ?C |- _ =>
            clear H
          end
        ).
        match goal with
        | H1: subst_tt' (typ_fvar x3) ?S1 = subst_tt' ?A ?S2,
          H2: subst_tt' (typ_fvar x3) ?S3 = subst_tt' ?B ?S4 |- _ =>
          assert (subst_tt' (typ_fvar x3) S1 = subst_tt' (typ_fvar x3) S3)
        end.
        -- cbn.
           fold (subst_tt v T0 x3).
           repeat f_equal.
           assert (x3 <> v1) by (apply neq_from_notin; notin_solve).
           case_if*.
        -- match goal with
          | H1: subst_tt' (typ_fvar x3) ?S1 = subst_tt' ?A ?S2,
            H2: subst_tt' (typ_fvar x3) ?S3 = subst_tt' ?B ?S4,
            H3: subst_tt' (typ_fvar x3) ?S5 = subst_tt' ?C ?S6 |- _ =>
            assert (HEQ: subst_tt' A S1 = subst_tt' B S3) by congruence
          end.
          cbn in HEQ.
          congruence.
      * autotyper4.
    + eapply typing_eq.
      * forwards*: H12 v1.
        forwards*: H12 v2.
        cbn in *.
        match goal with
        | |- {?E, ?D, ?G} ⊢( ?TT) ?t ∈ ?T =>
          assert (okt E D G) by autotyper4
        end.
        econstructor.
        -- econstructor.
           ++ econstructor. econstructor.
              ** solve_bind.
              ** auto.
           ++ econstructor. econstructor.
              ** solve_bind.
              ** auto.
        -- let FR := gather_vars in
            introv xFr;
            instantiate (1:=FR) in xFr.
           match goal with
           | |- {?E, ?D, ?G} ⊢( ?TT) ?t ∈ ?T =>
             assert (okt E D G)
           end.
           1: {
             autotyper4.
           }
           econstructor.
           ++ econstructor.
              2: {
                econstructor.
                2: {
                  econstructor.
                  - econstructor.
                    + econstructor.
                      * econstructor; solve_bind; auto.
                      * autotyper4.
                      * cbn. auto.
                    + autotyper4.
                    + cbn. auto.
                  - autotyper4.
                  - cbn. auto.
                }

                match goal with
                | |- context[x ~l (?A ** ?B)] =>
                  apply typing_eq with B Treg
                end.
                - econstructor.
                  econstructor; solve_bind; auto.
                - apply eq_typ_gadt.
                  apply F2_iff_In_zip.
                  split~.
                  intros.
                  repeat ininv2.
                  * apply teq_reflexivity.
                  * apply teq_symmetry.
                    apply teq_axiom. listin.
                - autotyper4.
              }

              match goal with
              | |- context[x6 ~l (?A ** ?B)] =>
                apply typing_eq with B Treg
              end.
              ** econstructor.
                 econstructor; solve_bind; auto.
              ** apply eq_typ_gadt.
                 apply F2_iff_In_zip.
                 split~.
                 intros.
                 repeat ininv2.
                 --- forwards* HI: inversion_eq_typ_gadt [typ_fvar v1]* [typ_fvar v]*.
                     2: {
                      rewrite F2_iff_In_zip in HI.
                      destruct HI as [? HI].
                      lets* HI2: HI v1 v.
                      apply HI2.
                      cbn; auto.
                     }
                     apply teq_transitivity with (typ_fvar x3).
                     +++ apply teq_symmetry.
                         apply teq_axiom; listin.
                     +++ apply teq_axiom; listin.
                 --- apply teq_symmetry. apply teq_axiom. listin.
              ** autotyper4.
            ++ cbn.
               let FR := gather_vars in
                 introv xFr2;instantiate (1:=FR) in xFr2.
               match goal with
               | |- {?E, ?D, ?G} ⊢( ?TT) ?t ∈ ?T =>
                 assert (okt E D G) by autotyper4
               end.
               econstructor.
               2: {
                 solve_bind.
               }
               2: {
                 cbn. auto.
               }
               2: {
                 cbn. auto.
               }
               2: {
                 cbn. auto.
               }
               1: {
                 eapply typing_eq.
                 - econstructor.
                   + econstructor; solve_bind; auto.
                   + econstructor; solve_bind; auto.
                 - apply eq_typ_tuple.
                   + apply eq_typ_tuple;
                      apply teq_symmetry;
                      apply teq_axiom; listin.
                   + apply teq_reflexivity.
                 - autotyper4.
               }
               2: {
                 cbn.
                 auto.
               }
               autotyper4.
      * apply eq_typ_gadt.
        apply F2_iff_In_zip.
        split~.
        intros.
        repeat ininv2.
        -- apply teq_symmetry.
           apply teq_axiom; listin.
        -- apply teq_reflexivity.
      * autotyper4.
Unshelve.
fs. fs. fs. fs. fs. fs. fs. fs. fs. fs. fs. fs. fs. fs. fs.
fs. fs. fs. fs. fs. fs. fs. fs. fs. fs. fs. fs. fs. fs. fs.
Qed.

(*
  map : forall a b n, (a -> b) -> Vector a n -> Vector b n
 *)
Definition map :=
  fixs ∀ ∀ ∀ ((##2 ==> ##1) ==> γ(##2, ##0) Vector ==> γ(##1, ##0) Vector) =>
  Λ (* a *) => Λ (* b *) => Λ (* n *) =>
  λ (* f *) (##2 ==> ##1) =>
  λ (* v *) γ(##2, ##0) Vector =>
  case #0 as Vector of {
                      (* a' *) 1 => new Nil [| ##2 |] ( <.> ) |
                      (* a', n'; elem *) 2 => new Cons [| ##3, ##0 |] (
                                      trm_tuple
                                        (#2 <| fst(#0))
                                        (#3 <|| ##4 <|| ##3 <|| ##0 <| #2 <| snd(#0))
                                    )
                    }.

Lemma map_types : {sigma, emptyΔ, empty} ⊢(Treg) map ∈ ∀ ∀ ∀ ((##2 ==> ##1) ==> γ(##2, ##0) Vector ==> γ(##1, ##0) Vector).
Proof.
  cbv.
  lets: oksigma.
  lets [? [? ?]]: all_distinct.
  autotyper3;
    rename x0 into map;
    rename x4 into f;
    rename x1 into A;
    rename x2 into B;
    rename x3 into N;
    rename x5 into vec.
  - rename v into C.
    forwards~ : H6 C.
    eapply typing_eq with (T1:=γ(typ_fvar B, γ() Zero) Vector).
    + autotyper4.
    + apply eq_typ_gadt.
      apply F2_iff_In_zip.
      split~.
      intros.
      repeat ininv2.
      * apply teq_symmetry.
        apply teq_axiom. listin.
      * apply teq_reflexivity.
    + autotyper4.
  - rename v0 into A'.
    rename v into N'.
    forwards~ : H6 A'.
    forwards~ : H6 N'.
    apply typing_eq with (γ(typ_fvar B, γ(typ_fvar N') Succ) Vector) Treg.
    + eapply typing_cons; autotyper0.
      * eapply typing_tuple; autotyper0.
        -- econstructor.
           ++ instantiate (1:=A).
              apply typing_eq with A' Treg.
              ** autotyper4.
              ** apply teq_symmetry. apply teq_axiom. listin.
              ** autotyper4.
           ++ autotyper4.
        -- econstructor; autotyper0.
           instantiate (1:= γ(typ_fvar A, typ_fvar N') Vector).
           ++ apply typing_eq with (γ(typ_fvar A', typ_fvar N') Vector) Treg.
              ** autotyper4.
              ** apply eq_typ_gadt.
                 apply F2_iff_In_zip.
                 split~.
                 intros.
                 repeat ininv2.
                 --- apply teq_reflexivity.
                 --- apply teq_symmetry.
                     apply teq_axiom. listin.
              ** autotyper4.
           ++ autotyper4.
      * autotyper4.
    + apply eq_typ_gadt.
      apply F2_iff_In_zip.
      split~.
      intros.
      repeat ininv2.
      * apply teq_symmetry.
        apply teq_axiom. listin.
      * apply teq_reflexivity.
    + autotyper4.
      Unshelve.
      fs.
      fs.
      fs.
      fs.
      fs.
      fs.
      fs.
      fs.
      fs.
      fs.
      fs.
      fs.
      fs.
      fs.
      fs.
Qed.


(** * Lists: Working with Structured Data *)

From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Open Scope qc_scope.
Import GenLow GenHigh.
Set Warnings "-extraction-opaque-accessed,-extraction".
Require Import List ZArith.
Import ListNotations.
(*
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import seq ssreflect ssrbool ssrnat eqtype.
*)

Require Export Induction.
Module NatList.

Inductive natprod : Type :=
| pair : nat -> nat -> natprod.
Derive Arbitrary for natprod.
Derive Show for natprod.
Instance natprod_eq (x y : natprod) : Dec (x = y).
constructor. unfold ssrbool.decidable. repeat (decide equality). Defined.

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

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

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

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

(* BCP: boring! *)
Definition equal_pair (p : natprod) (q : natprod) : bool :=
  match p,q with
  | (p1,p2),(q1,q2) => andb (p1 =? q1) (p2 =? q2)
  end.

Definition surjective_pairing (p : natprod) :=
  equal_pair p (fst p, snd p).
(*! QuickCheck surjective_pairing. *)

Inductive natlist : Type :=
  | nil  : natlist
  | cons : nat -> natlist -> natlist.
Derive Arbitrary for natlist.
Derive Show for natlist.
Instance natlist_eq (x y : natlist) : Dec (x = y).
constructor. unfold ssrbool.decidable. repeat (decide equality). Defined.

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

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

Fixpoint length (l:natlist) : nat :=
  match l with
  | nil => O
  | h :: t => S (length t)
  end.

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

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

Example test_app1:             [1;2;3] ++ [4;5] = [1;2;3;4;5].
Proof. reflexivity.  Qed.
Example test_app2:             nil ++ [4;5] = [4;5].
Proof. reflexivity.  Qed.
Example test_app3:             [1;2;3] ++ nil = [1;2;3].
Proof. reflexivity.  Qed.

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

Definition tl (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => t
  end.

Definition test_hd1 := hd 0 [1;2;3] =? 1.
(*! QuickChick test_hd1. *)

Fixpoint equal_list l1 l2 :=
  match l1,l2 with
  | [],[] => true
  | h1::t1,h2::t2 => andb (h1=?h2) (equal_list t1 t2)
  | _,_ => false
  end.

Definition test_tl := equal_list (tl [1;2;3]) [2;3].
(*! QuickChick test_tl. *)

Fixpoint alternate (l1 l2 : natlist) : natlist
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *) := [].

Definition bag := natlist.

Definition nil_app := fun l:natlist =>
  equal_list ([] ++ l) l.
(* QuickChick nil_app. *)

Definition tl_length_pred := fun l:natlist =>
  pred (length l) =? length (tl l).

(* Ugh -- temporary hack *)
Definition tl_length_prop :=
  forAllShrink arbitrary shrink tl_length_pred.
(*! QuickChick tl_length_prop. *)

Definition app_assoc := fun l1 l2 l3 : natlist =>
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Instance app_assoc_dec (l1 l2 l3 : natlist) : Dec (app_assoc l1 l2 l3).
unfold app_assoc. apply natlist_eq. Defined.

(* BCP: What do I need to write here?
QuickChick app_assoc.
*)

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

Definition rev_length := fun l : natlist =>
  length (rev l) =? length l.
(*! QuickChick rev_length. *)

Fixpoint beq_natlist (l1 l2 : natlist) : bool
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *) := false.

(* BCP: Use this elsewhere *)
Definition beq_natlist_refl := fun l:natlist =>
  Bool.eqb true (beq_natlist l l).
QuickChick (expectFailure beq_natlist).

(* BCP: I wonder how best to do this...? *)
Definition rev_injective := fun (l1 l2 : natlist) =>
  (equal_list (rev l1) (rev l2)) ==> equal_list l1 l2.
(* BCP: Probably needs some mutations to be interesting... *)
(*! QuickChick beq_natlist. *)

(* Let's try with the dependent stuff... *)
Inductive eq_list : natlist -> natlist -> Prop :=
  | eq_nil : eq_list [] []
  | eq_cons : forall h l1 l2, eq_list l1 l2 -> eq_list (h::l1) (h::l2).

Inductive snoc_of : natlist -> nat -> natlist -> Prop :=
  | snoc_of_nil : forall x, snoc_of [] x [x]
  | snoc_of_cons : forall x h t t',
      snoc_of t x t' -> snoc_of (h::t) x (h::t').

Derive ArbitrarySizedSuchThat for (fun h  => snoc_of t h t').
Derive ArbitrarySizedSuchThat for (fun t' => snoc_of t h t').

Inductive reverse_of : natlist -> natlist -> Prop :=
  | reverse_of_nil : reverse_of [] []
  | reverse_of_cons : forall h t t' t'',
      reverse_of t t' ->
      snoc_of t' h t'' ->
      reverse_of (h::t) t''.

Derive ArbitrarySizedSuchThat for (fun l => reverse_of l l').
Derive ArbitrarySizedSuchThat for (fun l => reverse_of l' l).

Inductive equal_reverses : (natlist * natlist)%type -> Prop :=
  | eqrev : forall l1 l2 l,
      reverse_of l1 l -> reverse_of l2 l ->
      equal_reverses (Coq.Init.Datatypes.pair l1 l2).

Derive ArbitrarySizedSuchThat for (fun l1l2 => equal_reverses l1l2).

(* Need to actual write decidability if we want to use it
Instance equal_reverses_dec l1l2 : Dec (equal_reverses l1l2).
Proof.
  constructor; unfold ssrbool.decidable.
  destruct l1l2 as [l1 l2].
  (* ... *)
Admitted.
*)

Definition rev_injective_checker : Checker :=
  forAll (genST (fun l1l2 => equal_reverses l1l2))
         (fun l1l2 => match l1l2 with
                        | Some (Coq.Init.Datatypes.pair l1 l2) => ((l1 = l2)?)
                        | None => true
                      end).

QuickChick rev_injective_checker.

Fixpoint nth_bad (l:natlist) (n:nat) : nat :=
  match l with
  | nil => 42  (* arbitrary! *)
  | a :: l' => match beq_nat n O with
               | true => a
               | false => nth_bad l' (pred n)
               end
  end.

Inductive natoption : Type :=
  | Some : nat -> natoption
  | None : natoption.
Derive Arbitrary for natoption.
Derive Show for natoption.
Instance natoption_eq (x y : natoption) : Dec (x = y).
constructor. unfold ssrbool.decidable. repeat (decide equality). Defined.

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

(* BCP: Fix *)
Definition test_nth_error1 :=
  (nth_error [4;5;6;7] 0) = (Some 4)?.
(*! QuickChick test_nth_error1. *)

End NatList.

Inductive id : Type :=
  | Id : nat -> id.
Derive Arbitrary for id.
Derive Show for id.
Instance id_eq (x y : id) : Dec (x = y).
constructor. unfold ssrbool.decidable. repeat (decide equality). Defined.

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

(* BCP: Extraction inside modules is broken! *)
(*
Module PartialMap.
*)
Export NatList.

Inductive partial_map : Type :=
  | empty  : partial_map
  | record : id -> nat -> partial_map -> partial_map.
Derive Arbitrary for partial_map.
Derive Show for partial_map.
Instance partial_map_eq (x y : partial_map) : Dec (x = y).
constructor. unfold ssrbool.decidable. repeat (decide equality). Defined.

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

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

Definition update_eq :=
  fun (d : partial_map) (x : id) (v: nat) =>
    (find x (update d x v) = Some v)?.
(*! QuickChick update_eq. *)