Require Import Iron.Language.SimpleRef.Step.
Require Import Iron.Language.SimpleRef.Ty.
Require Import Iron.Language.SimpleRef.Exp.

(* A closed, well typed expression is either a value or can
   take a step in the evaluation. *)
Theorem progress
 :  forall se h x t
 ,  TYPEH se h
 -> TYPE  nil se x t
 -> value x \/ (exists h' x', STEP h x h' x').
Proof.
 intros se h x t HTH HT.
 remember (@nil ty) as te.
 induction HT; subst; try (solve [left; burn]); right.

 Case "XApp".
  destruct IHHT1; eauto.
  SCase "value x1".
   destruct IHHT2; eauto.
   SSCase "value x2".
    SSSCase "EsLamApp".
     assert (exists t x, x1 = XLam t x) as HF. eauto.
     dests HF. subst.
     exists h (substX 0 x2 x). auto.

   SSCase "x2 steps".
    dests H0. exists h' (XApp x1 x'). eauto.

   SSCase "x1 steps".
    dests H. exists h' (XApp x' x2).
    lets D: EsContext XcApp1; eauto.

 Case "XNewRef".
  destruct IHHT; eauto.
  SCase "x1 steps".
   dests H. exists h' (XNewRef x'). auto.

 Case "XReadRef".
  destruct IHHT; eauto.
  SCase "xRef value".
   assert (exists l, xRef = XLoc l) as HF. eauto.
   dest HF. subst.
   inverts_type.
   assert (exists xData, get l h = Some xData).
    eauto. eapply Forall2_get_get_right; eauto.
    dest H0.
    exists h xData. auto.

  SCase "xRef steps".
   dests H.
   exists h' (XReadRef x').
   lets D: EsContext XcReadRef. eauto.

 Case "XWriteRef".
  destruct IHHT1; eauto.
  SCase "value xRef".
   destruct IHHT2; eauto.
    SSCase "value xData".
     assert (exists l, xRef = XLoc l) as HF. eauto.
     dest HF. subst.
     exists (update l xData h) xUnit. auto.
    SSCase "x2 steps".
     dests H0.
     exists h' (XWriteRef xRef x'). auto.
   SCase "xRef Steps".
    dests H.
    lets D: EsContext XcWriteRef1. eauto.
Qed.


Require Import Autosubst.Autosubst.
Require Types Term.
Require Import Reduction Typing.

Notation SN e :=
  (Acc (fun e e' => red e' e) e).

Fixpoint reducible e t : Prop :=
  match t with
  | Types.Var _ => SN e
  | Types.Fun t1 t2 =>
      forall v, reducible v t1 -> reducible (Term.App e v) t2
  end.
Hint Constructors Acc.

Notation neutral t := match t with Term.Abs _ _ => False | _ => True end.

Lemma CR2 t : forall e e',
  red e e' ->
  reducible e t -> reducible e' t.
Proof.
  induction t; intros ? ? ? Hreducible; simpl in *; eauto.
  - inversion Hreducible; eauto.
Qed.
Hint Resolve CR2.

Lemma CR1_CR3 t :
  (forall e, reducible e t -> SN e) /\
  (forall e, neutral e ->
    (forall e', red e e' -> reducible e' t) -> reducible e t).
Proof.
  induction t; split; simpl in *; eauto.
  - intros ? H.
    destruct IHt1 as [ IHt1C1 IHt1C3 ].
    assert (Hc : reducible (Term.Var 0) t1).
    { apply IHt1C3; eauto.
      intros ? Hred.
      inversion Hred. }
    apply H in Hc.
    destruct IHt2 as [ IHt2C1 ].
    apply IHt2C1 in Hc.
    clear H.
    remember (Term.App e (Term.Var 0)) as e'.
    generalize dependent e.
    induction Hc; intros; subst.
    eauto.
  - intros ? Hneutral H ? HRt1.
    destruct IHt1 as [ IHt1C1 IHt1C3 ].
    destruct IHt2 as [ IHt2C1 IHt2C3 ].
    apply IHt2C3; eauto.
    specialize (IHt1C1 _ HRt1).
    induction IHt1C1.
    intros ? Hred.
    inversion Hred; subst; eauto.
    inversion Hneutral.
Qed.

Let CR1 t := proj1 (CR1_CR3 t).
Let CR3 t := proj2 (CR1_CR3 t).
Hint Resolve CR1.

Lemma reducible_abs : forall e1 t1 t2,
  (forall v, reducible v t1 -> reducible (e1.[v/]) t2) ->
  reducible (Term.Abs t1 e1) (Types.Fun t1 t2).
Proof.
  simpl.
  intros ? ? ? Hsubst ? Hreducible.
  generalize (CR1 _ _ Hreducible). intros HSN.
  generalize (CR1 _ _ (Hsubst _ Hreducible)). intros HSNsubst.
  generalize dependent e1.
  induction HSN as [? ? IH].
  intros.
  remember (e1.[x/]) as e.
  generalize dependent e1.
  generalize dependent x.
  induction HSNsubst as [? ? IH'].
  intros. subst.
  apply CR3; eauto.
  intros ? Hred.
  inversion Hred; subst; eauto 7.
  inversion H4; subst.
  eapply IH'; try reflexivity; eauto.
Qed.

Lemma fundamental_property env t T :
  typed env t T ->
  forall s,
  (forall x T, env x = Some T -> reducible (s x) T) ->
  reducible (t.[s]) T.
Proof.
  induction 1; intros ? Hsubst; simpl in *; eauto.
  - intros ? Hreducible.
    apply reducible_abs; eauto.
    intros ? ?.
    rewrite subst_comp.
    apply IHtyped.
    intros [| x] ? Heq; simpl in *.
    + congruence.
    + replace ((up s (S x)).[v0/]) with (s x) by autosubst.
      eauto.
Qed.

Theorem strong_normalization env t T :
  typed env t T ->
  SN t.
Proof.
  intros Htyped.
  apply fundamental_property with (s := ids) in Htyped.
  - rewrite subst_id in Htyped.
    eauto.
  - intros ? ? ?.
    apply CR3; simpl; eauto.
    intros ? Hred.
    inversion Hred.
Qed.


Require Export DMFP.Day06_sorting.

(* ################################################################# *)
(** * Binary trees *)

(** Recall the definition of binary trees [bt] from Day04_structures:

Inductive bt (X : Type) : Type :=
| empty
| node (l : bt X) (v : X) (r : bt X).

*)

Check empty.
Check @empty nat.
Check (node empty true empty). (* leaf node *)
Check (node empty 5 empty). (* leaf node *)
Check (node empty G (node empty C empty)).
Check (node (node empty 12 empty) 25 (node (node empty 5 empty) 5 empty)).

Compute (size (node (node empty 12 empty) 25 (node (node empty 5 empty) 5 empty))).

(** We defined some terminology already: a _leaf_ is a node where both
    children are [empty].

    The _root_ of a tree is the topmost node. *)

Definition root {X : Type} (t : bt X) : option X :=
  match t with
  | empty => None
  | node _ v _ => Some v
  end.

Compute (root (node (node empty 12 empty) 25 (node (node empty 5 empty) 5 empty))).
(* ===> Some 25 *)

(** It's common enough to want to make a leaf that we'll define a
    function to do it for us. *)
Definition leaf {X : Type} (v : X) : bt X := node empty v empty.

Compute (root (node (leaf 12) 25 (node (leaf 5) 5 empty))).
(* ===> Some 25 *)

(* ################################################################# *)
(** * What are trees for? *)

(** Trees are a useful and general structure. Computer scientists use
    trees:

    - In interpreters, compilers, and program analyses to represent
      and manipulate programs.

    - In machine learning's so-called "decision trees".

    - In game AI to represent strategies.

    - In operating systems to store filesystem information.

    - In databases to quickly manipulate stored values.

    But it's not just CS! Biological systematists use trees to model
    evolutionary relationships. Linguists use trees to model syntactic
    structure. Genealogists use trees to model familial relationships.

    Trees are a Big Deal. Here's a very contrived tree model of
    declarative English sentences. *)

Inductive proper_noun : Type :=
  | Prof_Greenberg
  | Opie_the_dog
  | Prof_Osborn
  | Dr_Dave.

Inductive article : Type :=
  | the
  | a.

Inductive noun : Type :=
  | program
  | frisbee
  | lasagna
  | unicycle.

Inductive noun_phrase : Type :=
  | np_proper (pn : proper_noun)
  | np_compound (a : article) (n : noun).

Inductive verb_intransitive : Type :=
  | laughed
  | danced
  | barked.

Inductive verb_transitive : Type :=
  | bit
  | wrote
  | baked
  | rode.

Inductive preposition : Type :=
  | under
  | around
  | in_front_of.

Inductive adverb : Type :=
  | goofily
  | well
  | sarcastically.

Inductive modifier : Type :=
  | m_prep (p : preposition) (np : noun_phrase)
  | m_adverb (a : adverb).

Inductive verb_phrase : Type :=
  | vp_intransitive (v : verb_intransitive)
  | vp_transitive (v : verb_transitive) (o : noun_phrase)
  | vp_modifier (vp : verb_phrase) (m : modifier).

Inductive sentence : Type :=
  | s (np : noun_phrase) (vp : verb_phrase).

(** **** Exercise: 1 star, standard (sentences)

    Write a tree that models a sentence where Prof. Greenberg danced in front of Opie. *)
Definition goofball : sentence :=
  s (np_proper Prof_Greenberg)(vp_modifier (vp_intransitive danced)(m_prep in_front_of (np_proper Opie_the_dog))).

(** Write a tree that models a sentence where Opie bakes a lasagna
    well. Good boy! *)
Definition good_dog : sentence :=
  s (np_proper Opie_the_dog)(vp_modifier (vp_transitive baked (np_compound a lasagna))(m_adverb well)).

(** Translate the following tree to an English sentence. *)
Definition so_talented : sentence :=
  s (np_proper Dr_Dave)
    (vp_modifier
       (vp_modifier
          (vp_transitive rode (np_compound the unicycle))
          (m_adverb goofily))
       (m_prep around (np_compound the frisbee))).
(* Dr. Dave rode the unicycle goofily around the frisbee. *)

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

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

(** A tree is a useful data structure in a program, but it isn't
    always what people want to see---people often do better with
    lists.

    Any function that looks at every node of a tree is called a
    _traversal_. The word 'traversal' often refers particularly to the
    process of converting a tree to a list.

    There are three common notions of traversal, named for what they
    do with the value at a given node:

    - A _pre-order_ traversal puts the value first, then traverses the
      left child, then the right child.

    - An _in-order_ traversal first traverses the left child, then the
      value of the node, then the right child.

    - A _post-order_ traversal first traverses the left child, then
      the right child, then the value of the node.

    You'll notice that all three of these go left-to-right. That's a
    convention---you could look at the right children, then the left
    children, then the node. Which traversal you use in practice
    depends on *)

(** Here's an in-order traversal. *)
Fixpoint inorder {X : Type} (t : bt X) : list X :=
  match t with
  | empty => []
  | node l v r => inorder l ++ [v] ++ inorder r
  end.

Compute (inorder (node (node empty 12 empty) 25 (node (node empty 5 empty) 5 empty))).

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

    Define traversal functions [preorder] and [postorder] that
    implement those respective traversals. *)
Fixpoint preorder {X : Type} (t : bt X) : list X :=
  match t with
  | empty => []
  | node l v r => [v] ++ preorder l ++ preorder r
  end.

Compute (preorder (node (node empty 12 empty) 25 (node (node empty 5 empty) 5 empty))).

Fixpoint postorder {X : Type} (t : bt X) : list X :=
  match t with
  | empty => []
  | node l v r => postorder l  ++ postorder r ++ [v]
  end.

Compute (postorder (node (node empty 12 empty) 25 (node (node empty 5 empty) 5 empty))).

(** Write a tree that produces different output from all three
    traversals. (Note the type!) It should have at least three
    nodes. *)
Definition different_all_three : bt base :=
  node(node empty T empty) C  (node empty A empty).

Compute (inorder different_all_three).
Compute (preorder different_all_three).
Compute (postorder different_all_three).

(** Write a tree that produces the same output from pre- and in-order
    traversals (but not post-order). It should have at least three
    nodes. *)
Definition same_pre_in : bt base :=
  node(node empty T empty) T  (node empty A empty).

Compute (inorder same_pre_in).
Compute (preorder same_pre_in).
Compute (postorder same_pre_in).

(** Write a tree that produces the same output from in- and post-order
    traversals (but not pre-order). It should have at least three
    nodes. *)
Definition same_post_in : bt base :=
  node(node empty T empty) C  (node empty C empty).

Compute (inorder same_post_in).
Compute (preorder same_post_in).
Compute (postorder same_post_in).

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

(* ################################################################# *)
(** * Binary search trees (BSTs) *)

(** Binary search trees are pervasive and powerful data
    structures. They are used to implement sets and associative maps,
    two of the most commonly used data structures.

    BSTs _refine_ binary trees with an _invariant_ called the 'search
    property'. A binary tree [t] is said to have the _search property_
    when for a given ordering (i.e., a notion of 'less than' and
    'greater than'):

    - [t] is [empty], or

    - [t] is [node l v r] where:

      + [l] and [r] have the search property

      + every value in [l] is less than [v]

      + every value in [r] is greater than [v]

    The search property is very useful. Suppose you have a binary
    search tree, and you wonder if a value [n] is in it. First, you
    check the root: if that's it, great. If not, then ask: is [n] less
    than or greater than the root? You only have to keep looking in
    one side of the tree! If your tree is well balanced, you'll do
    very little traversal at all.  If you kept a list rather than a
    BST, you'd have to search the whole list to be sure. Nice... what
    a savings!

    It turns out other operations on BSTs---adding and deleting
    elements---are also very efficient. We'll implement a few.

    (Sometimes people want BSTs were values in [l] are less than _or
    equal to_ [v]. It depends; for sets and maps, you want _less
    than_, because it guarantees there are no duplicates.)
*)

(** **** Exercise: 1 star, standard (search_property)

    Write two trees of naturals that have the search property and two
    trees that do not. All of your trees should have at least two
    nodes. *)

Definition bst1 : bt nat := node(node empty 5 empty) 10 (node empty 24 empty).
Definition bst2 : bt nat := node(node empty 35 empty) 48 (node empty 55 empty).
Definition non_bst1 : bt nat := node(node empty 20 empty) 10 (node empty 30 empty).
Definition non_bst2 : bt nat := node(node empty 45 empty) 69 (node empty 58 empty).
(* Do not modify the following line: *)
Definition manual_grade_for_search_property : option (nat*string) := None.
(** [] *)

(** We've already defined [eqb] and [leb], so we could just use
    those. But it's common to use a [compare] operation that gives us
    'complete' comparison information. It saves comparisons and is
    less error prone. What's not to like? *)
Inductive ordering : Type :=
  | LT
  | EQ
  | GT.

Fixpoint compare (n m : nat) : ordering :=
  match n, m with
  | O, O => EQ
  | S _, O => GT
  | O, S _ => LT
  | S n', S m' => compare n' m'
  end.

Compute (compare 0 0).       (* ===> EQ *)
Compute (compare 0 10).      (* ===> LT *)
Compute (compare 7 4).       (* ===> GT *)
Compute (compare 1000 1000). (* ===> EQ *)

(** Here's a function that uses the search property to rapidly
    determine whether or not a value is in a BST already. *)
Fixpoint lookup (n : nat) (t : bt nat) : bool :=
  match t with
  | empty => false
  | node l v r =>
    match compare n v with
    | LT => lookup n l
    | EQ => true
    | GT => lookup n r
    end
  end.

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

    Write a function that inserts a number [n] into a binary search
    tree [t]. To get full credit, you should use the binary search
    property!

    What should your function do when [n] is already in the tree?  *)
Fixpoint insert (n : nat) (t : bt nat) : bt nat :=
  match t with
  | empty => node empty n empty
  | node l v r => match compare n v with
                   | LT => node ( insert n l) v r
                   | EQ => t
                   | GT => node l v ( insert n r)
                   end
  end.

Compute (insert 5 (node (node empty 3 empty)4 (node empty 6 empty))).
Compute (insert 8 (node (node empty 7 empty) 9 (node empty 10 empty))).
Compute (insert 11 (node (node empty 11 empty) 12 (node empty 13 empty))).
Compute (insert 4 (node (node(node empty  1 empty) 2 (node empty 3 empty)) 5 (node empty 6 empty))).

(** [] *)

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

    Write a function that tries to remove the smallest element from a
    binary search tree. You'll need to return not just the smallest
    element, but also what's left of the tree.

    Your function should return [None] only when [t] is [empty]. Use
    the search property! *)
Fixpoint remove_min (t : bt nat) : option (nat * bt nat) :=
  match t with
  |empty  => None
  | node l v r => match l with
                  | empty => Some (v , r)
                  | node empty l' empty => Some (l' , node empty v r)
                  | node l' v' r' =>  match remove_min l with
                                      | None => None
                                      | Some (nat, empty )=> Some ( nat , node empty v r)
                                      | Some ( nat , node l' v' r' ) => Some ( nat , node (node l' v' r' ) v r)
                                      end
                  end
 end.

Compute (remove_min (node (node  empty 1 (node empty 2 empty) ) 3 (node (node empty 4 empty) 5 empty))).
Compute (remove_min empty ).
Compute (remove_min (node empty 6 empty)).
Compute (remove_min (node empty 7 (node (node empty 8 empty) 9 (node empty 10 empty)))).

(** [] *)

(** **** Exercise: 4 stars, standard (remove)

    Write a function that removes a number [n] from a binary search
    tree.  If [n] isn't in the tree, you should return the tree
    unchanged.

    It turns out this is a hard function to write! Here's a general
    plan:

    - Handling [empty] should be simple.

    - To remove [n] from [node l v r], look at [compare n v].

      + The [LT] and [GT] cases should be simple.

      + The [EQ] case is tricky! Use [remove_min] to find a new root
        element from [r] if you can. What does it mean if [remove_min
        r = None]?
 *)
Fixpoint remove (n : nat) (t : bt nat) : bt nat :=
  match t with
  | empty => t
  | node l v r => match compare n v with
                  | LT => node (remove n l) v r
                  | EQ => match remove_min r with
                          | None => l
                          | Some (nat , empty) => node l nat empty
                          | Some (nat, node l' v' r')=> node l nat (node l' v' r')
                          end
                  | GT => node l v (remove n r)
                  end
  end.

Compute (remove 3 (node (node  empty 1 (node empty 2 empty) ) 3 (node (node empty 4 empty) 5 empty))).
Compute (remove 5  empty ).
Compute (remove 6 (node empty 6 empty)).
Compute (remove 7 (node empty 7 (node (node empty 8 empty) 9 (node empty 10 empty)))).

(** [] *)

(** **** Exercise: 4 stars, standard, optional (is_bst)

    Write a function [is_bst] that takes [t : bt nat] and returns
    [true] if [t] has the search property.

    There are different ways to go here. A few hints:

    - You'll need at least one helper function. How can you check the
      "every value" parts of the search property?

    - Don't think about efficiency---you're just making things hard
      for yourself. Get it to work first, and then make it efficient
      if that'll make you happy.

    We'd like you to write the signature yourself. If you can't finish
    writing the function, that's fine---but make sure you use
    [Definition] and [Admitted] to leave something behind for the
    grader. Talk to the TAs if you're stuck.  *)

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

(* 2021-09-13 09:44 *)


From Hammer Require Import Hammer.

From Coq Require Import Program.Equality.
From Coq Require Import omega.Omega.
From Coq Require Import Logic.ClassicalChoice.

From Topology Require Import InverseImageLemmas.
From ZornsLemma Require Export FiniteIntersections.
From ZornsLemma Require Export CountableTypes.

Ltac destruct_ensembles_in :=
match goal with
| [H : Ensembles.In _ _ |- _] => destruct H
end.

Ltac extensionality_ensembles :=
apply Extensionality_Ensembles;
split; red; intros;
repeat destruct_ensembles_in.

Section Lemmas.
Open Scope nat.

Lemma nat_countable : CountableT nat.
Proof. hammer_hook "FiniteIntersectionLemmas" "FiniteIntersectionLemmas.nat_countable".
apply intro_nat_injection with (fun n => n).
now intros [|m] [|n].
Qed.

Lemma intersection_full_set
{X : Type}
{U : Ensemble X} :
Intersection Full_set U = U.
Proof. hammer_hook "FiniteIntersectionLemmas" "FiniteIntersectionLemmas.intersection_full_set".
now extensionality_ensembles.
Qed.

Lemma intersection_associative
{X : Type}
(U V W: Ensemble X) :
Intersection (Intersection U V) W = Intersection U (Intersection V W).
Proof. hammer_hook "FiniteIntersectionLemmas" "FiniteIntersectionLemmas.intersection_associative".
now extensionality_ensembles.
Qed.

Inductive finite_intersections_len {X : Type} (F : Family X) : IndexedFamily nat (Ensemble X) :=
| intro_fi_len_full : In (finite_intersections_len F 0) Full_set
| intro_fi_len_S : forall U : Ensemble X, In F U -> In (finite_intersections_len F 1) U
| intro_fi_len_intersection : forall (U V : Ensemble X) (m k : nat),
In (finite_intersections_len F m) U ->
In (finite_intersections_len F k) V ->
In (finite_intersections_len F (m + k)) (Intersection U V).

Lemma finite_intersections_len_0_full_set
{X : Type}
{F : Family X}
{U : Ensemble X} :
In (finite_intersections_len F 0) U -> U = Full_set.
Proof. hammer_hook "FiniteIntersectionLemmas" "FiniteIntersectionLemmas.finite_intersections_len_0_full_set".
intro H.
red in H.
dependent induction H;
try rewrite IHfinite_intersections_len, intersection_full_set, IHfinite_intersections_len0;
reflexivity + omega.
Qed.

Lemma finite_intersections_len_1_in
{X : Type}
{F : Family X}
{U : Ensemble X} :
In (finite_intersections_len F 1) U -> In F U.
Proof. hammer_hook "FiniteIntersectionLemmas" "FiniteIntersectionLemmas.finite_intersections_len_1_in".
intro H.
red in H.
dependent induction H.
- assumption.
- destruct m, k;
discriminate + injection x as x;
subst.
+ rewrite (finite_intersections_len_0_full_set H), intersection_full_set.
now apply IHfinite_intersections_len0.
+ rewrite (finite_intersections_len_0_full_set H0), Intersection_commutative, intersection_full_set.
apply IHfinite_intersections_len.
omega.
+ omega.
Qed.

Lemma finite_intersections_len_SS_intersection
{X : Type}
{F : Family X}
{U : Ensemble X}
(n : nat) :
In (finite_intersections_len F (S (S n))) U ->
exists m k V W,
In (finite_intersections_len F (S m)) V /\
In (finite_intersections_len F (S k)) W /\
U = Intersection V W /\
n = m + k.
Proof. hammer_hook "FiniteIntersectionLemmas" "FiniteIntersectionLemmas.finite_intersections_len_SS_intersection".
intro H.
red in H.
dependent induction H.
- destruct m, k;
discriminate + injection x as x;
subst.
+ rewrite (finite_intersections_len_0_full_set H), intersection_full_set.
now apply IHfinite_intersections_len0.
+ rewrite (finite_intersections_len_0_full_set H0), Intersection_commutative, intersection_full_set.
apply IHfinite_intersections_len.
omega.
+ exists m, k, U, V.
repeat split;
omega + assumption.
Qed.

Lemma finite_intersections_len_S_exists
{X : Type}
{F : Family X}
{U : Ensemble X}
{n : nat} :
In (finite_intersections_len F (S n)) U ->
exists V W,
In (finite_intersections_len F n) V /\
In (finite_intersections_len F 1) W /\
U = Intersection V W.
Proof. hammer_hook "FiniteIntersectionLemmas" "FiniteIntersectionLemmas.finite_intersections_len_S_exists".
generalize dependent U.
generalize dependent n.
apply (well_founded_ind lt_wf (fun n =>
forall U,
In (finite_intersections_len F (S n)) U ->
exists V W,
In (finite_intersections_len F n) V /\
In (finite_intersections_len F 1) W /\
U = Intersection V W)).
intros [|n] IH U H.
- apply finite_intersections_len_1_in in H.
exists Full_set, U.
now repeat split;
constructor + rewrite intersection_full_set.
- apply finite_intersections_len_SS_intersection in H.
destruct H as [m [[|k] [V [W [HV [HW [eq1 eq2]]]]]]].
+ rewrite Nat.add_0_r in eq2.
subst.
now exists V, W.
+ apply IH in HV; [|omega].
destruct HV as [V1 [V2 [HV1 [HV2 eq3]]]].
rewrite eq2, plus_n_Sm.
exists (Intersection V1 W), V2.
repeat (constructor; try easy).
subst.
now rewrite (intersection_associative V1 W),
(Intersection_commutative _ W),
<- (intersection_associative V1).
Qed.

Lemma finite_intersections_len_S_choice
{X : Type}
(F : Family X)
(n : nat) :
exists f : {U : Ensemble X | In (finite_intersections_len F (S n)) U} ->
{U : Ensemble X | In (finite_intersections_len F n) U} *
{U : Ensemble X | In (finite_intersections_len F 1) U},
forall U, proj1_sig U = Intersection (proj1_sig (fst (f U))) (proj1_sig (snd (f U))).
Proof. hammer_hook "FiniteIntersectionLemmas" "FiniteIntersectionLemmas.finite_intersections_len_S_choice".
apply choice with (R :=
fun U : {U : Ensemble X | In (finite_intersections_len F (S n)) U} =>
fun y : {U : Ensemble X | In (finite_intersections_len F n) U} *
{U : Ensemble X | In (finite_intersections_len F 1) U} =>
proj1_sig U = Intersection (proj1_sig (fst y)) (proj1_sig (snd y))).
intros [? HU].
destruct (finite_intersections_len_S_exists HU) as [V [W [HV [HW ?]]]].
now exists (exist _ V HV, exist _ W HW).
Qed.

Lemma finite_intersections_len_union
{X : Type}
(F : Family X) :
IndexedUnion (finite_intersections_len F) = finite_intersections F.
Proof. hammer_hook "FiniteIntersectionLemmas" "FiniteIntersectionLemmas.finite_intersections_len_union".
apply Extensionality_Ensembles.
split.
- intros ? [n U HU].
red in HU.
dependent induction HU.
+ apply intro_full.
+ now apply intro_S.
+ now apply intro_intersection.
- intros ? HU.
red in HU.
dependent induction HU;
try destruct IHHU, IHHU0;
econstructor.
+ constructor.
+ now apply intro_fi_len_S.
+ apply intro_fi_len_intersection.
exact H1.
exact H2.
Qed.

Lemma finite_intersections_countable
{X : Type}
(F : Family X) :
Countable F -> Countable (finite_intersections F).
Proof. hammer_hook "FiniteIntersectionLemmas" "FiniteIntersectionLemmas.finite_intersections_countable".
intros [f Hf].
rewrite <- finite_intersections_len_union.
apply countable_union.
- apply nat_countable.
- intro n.
induction n.
+ apply intro_nat_injection with (fun x => 0).
intros [U HU] [V HV] eq.
apply Proj1SigInjective.proj1_sig_injective.
simpl.
now rewrite (finite_intersections_len_0_full_set HU),
(finite_intersections_len_0_full_set HV).
+ destruct (finite_intersections_len_S_choice F n) as [g Hg],
IHn as [fn Hfn].
refine (inj_countable (fun U =>
(fn (fst (g U)),
f (exist _ (proj1_sig (snd (g U))) _)))
countable_nat_product _).
intros [U HU] [V HV] eq.
injection eq as eq1 eq2.
apply Hfn, proj1_sig_eq in eq1.
apply Hf, proj1_sig_eq in eq2.
apply Proj1SigInjective.proj1_sig_injective.
now rewrite Hg, Hg, eq1, eq2.
Unshelve.
destruct (snd (g U)).
now apply finite_intersections_len_1_in.
Qed.

End Lemmas.


(*
   Copyright 2001, 2009 Luc Rutten

   This file is part of ModRed.

   ModRed is free software: you can redistribute it and/or modify
   it under the terms of the GNU Lesser General Public License as published by
   the Free Software Foundation, either version 3 of the License, or
   (at your option) any later version.

   ModRed is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU Lesser General Public License for more details.

   You should have received a copy of the GNU Lesser General Public License
   along with ModRed.  If not, see <http://www.gnu.org/licenses/>.
*)

(* Preparations for fast modular reduction lemmas. *)

(* Coq 8.2 *)
Require Import ZArith.

Open Scope Z_scope.

Definition in_Z_ (m x : Z) := 0 <= x < m.

Definition Z_ (m : Z) := sig (in_Z_ m).

Coercion Z_from_Z_ (m : Z) (x : Z_ m) := proj1_sig (P := in_Z_ m) x.

Notation _Z := (Z_from_Z_ _).

Definition in_Zpls (x : Z) := 0 < x.

Definition Zpls := sig in_Zpls.

Coercion Zpls_ (x : Zpls) := proj1_sig (P := in_Zpls) x.

Lemma le_0__Z : forall (n : Z) (i : Z_ n), 0 <= i.

  intros n i. case i. unfold in_Z_. simpl. tauto. Qed.

Lemma lt_z__Z : forall (n : Z) (i : Z_ n), i < n.

  intros n i. case i. unfold in_Z_. simpl. tauto. Qed.

Lemma Zmod_le_0_z : forall x m : Z, 0 < m -> 0 <= x mod m.

  intros x m H. elim (Z_mod_lt x m); omega. Qed.

Lemma Zmod_lt_z_m : forall x m : Z, 0 < m -> x mod m < m.

  intros x m H. elim (Z_mod_lt x m); omega. Qed.

Lemma Zdiv_small_0 : forall x m : Z, 0 <= x -> x < m -> x / m = 0.

  intros x m H H0. cut (m * (x / m) + x mod m < m). intro H1. cut (m * (x / m) < m).
  intro H2. elim (Zle_or_lt 0 (x / m)); intro H3. elim (Zle_lt_or_eq 0 (x / m)). intro H4.
  cut (m * 1 <= m * (x / m)). intro H5. absurd (m * (x / m) < m). omega. assumption.
  apply Zmult_le_compat_l. omega. omega. omega. assumption. absurd (x / m < 0). apply Zle_not_lt.
  apply Zge_le. apply Z_div_ge0; omega. assumption. cut (0 <= x mod m). omega. elim (Z_mod_lt x m). omega.
  omega. rewrite <- Z_div_mod_eq. assumption. omega. Qed.

Lemma Zle_0_div : forall a m : Z, 0 <= a -> 0 < m -> 0 <= a / m.

  intros a m H H0. apply Zge_le. apply Z_div_ge0. omega. omega. Qed.

Lemma Zdiv_le : forall a b m : Z, 0 < m -> a <= b -> a / m <= b / m.

  intros. apply Zge_le. apply Z_div_ge. omega. omega. Qed.

Lemma Zmod_plus_m : forall x m : Z, 0 < m -> (x + m) mod m = x mod m.

  intros x m H. replace (x + m) with (x + 1 * m). apply Z_mod_plus. omega. ring. Qed.

Lemma Zmod_minus_m : forall x m : Z, 0 < m -> (x - m) mod m = x mod m.

  intros x m H. replace (x - m) with (x + -1 * m). apply Z_mod_plus. omega. ring. Qed.

Lemma Zmod_km_plus : forall x k m : Z, 0 < m -> (k * m + x) mod m = x mod m.

  intros. rewrite Zplus_comm. apply Z_mod_plus. omega. Qed.

Lemma Zmod_minus_km : forall x k m : Z, 0 < m -> (x - k * m) mod m = x mod m.

  intros. unfold Zminus. rewrite <- Zopp_mult_distr_l_reverse. apply Z_mod_plus. omega. Qed.

Lemma Zdivmod_split : forall x m : Z, 0 < m -> x / m * m + x mod m = x.

  intros. rewrite Zmult_comm. rewrite <- Z_div_mod_eq. trivial. omega. Qed.

Lemma Zmod_plus_distr_l : forall a b m : Z, 0 < m -> (a + b) mod m = (a mod m + b) mod m.

  intros a b m H. replace (a + b) with (a / m * m + a mod m + b). rewrite Zplus_comm.
  rewrite Zplus_comm with (m := a mod m). rewrite Zplus_assoc. rewrite Z_mod_plus.
  rewrite Zplus_comm. trivial. omega. rewrite Zdivmod_split. trivial. assumption. Qed.

Lemma Zmod_mult_distr_l : forall a b m : Z, 0 < m -> (a * b) mod m = (a mod m * b) mod m.

  intros a b m H. replace (a * b) with ((a / m * m + a mod m) * b).
  rewrite Zmult_plus_distr_l. rewrite Zmod_plus_distr_l.
  replace (a / m * m * b) with (0 + a / m * b * m). rewrite Z_mod_plus. trivial. omega.
  ring. assumption. rewrite Zdivmod_split. trivial. assumption. Qed.

Lemma Zmod_minus_distr_l : forall a b m : Z, 0 < m -> (a - b) mod m = (a mod m - b) mod m.

  unfold Zminus. intros. apply Zmod_plus_distr_l. assumption. Qed.

Lemma Zmod_minus_distr_r : forall a b m : Z, 0 < m -> (a - b) mod m = (a - b mod m) mod m.

  intros a b m H. unfold Zminus. replace (- b) with (b * -1). do 2 rewrite Zplus_comm with (n := a).
  rewrite Zmod_plus_distr_l. rewrite Zmod_mult_distr_l. rewrite <- Zmod_plus_distr_l.
  apply f_equal2 with (f := Zmod). ring. trivial. assumption. assumption. assumption. ring. Qed.

Lemma modred : forall x m : Z, 0 <= x -> x < m -> x mod m = x.

  intros x m H H0. rewrite <- Zdivmod_split with (x := x) (m := m).
  replace ((x / m * m + x mod m) mod m) with (x mod m).
  rewrite Zdiv_small_0; auto. rewrite Zdivmod_split. trivial. omega. omega. Qed.

Lemma Zdiv_a_b_b_Zmod : forall a b : Z, 0 < b -> a / b * b = a - a mod b.

  intros a b H. cut (a / b * b + a mod b = a). omega. apply Zdivmod_split. assumption. Qed.

Lemma Zminus_Zdiv_Zmult : forall a b : Z, 0 < b -> a - a / b * b = a mod b.

  intros. rewrite Zdiv_a_b_b_Zmod. ring. assumption. Qed.

Lemma Zmod_prod_Zmod : forall x y z : Z, 0 < y -> 0 < z -> x mod (y * z) mod z = x mod z.

  intros x y z H H0. rewrite <- Zminus_Zdiv_Zmult with (a := x). rewrite Zmult_assoc.
  apply Zmod_minus_km. assumption. fold (0 * 0). apply Zmult_lt_0_compat; omega. Qed.

Lemma Zdiv_mult_plus : forall a b m : Z, 0 < m -> 0 <= b -> b < m -> (a * m + b) / m = a.

  intros. rewrite Zplus_comm. rewrite Z_div_plus. rewrite Zdiv_small_0. ring.
  assumption. assumption. omega. Qed.

Lemma Zdiv_mult_minus : forall a b m : Z, 0 < m -> 0 < b -> b <= m -> (a * m - b) / m = a - 1.

  intros. replace (a * m - b) with ((a - 1) * m + (m - b)). apply Zdiv_mult_plus. auto. omega.
  omega. ring. Qed.

Lemma Zdiv_times_plus : forall x y m : Z, 0 < m -> (x * m + y) / m = (x + y / m).

  intros. rewrite Zplus_comm. rewrite Z_div_plus. ring. omega. Qed.

Lemma div_1_id : forall a : Z, a / 1 = a.

  intro a. replace a with (a * 1). rewrite Z_div_mult. ring. omega. ring. Qed.

Lemma mod_1_0 : forall z : Z, z mod 1 = 0.

  intro z. cut (0 <= z mod 1). cut (z mod 1 < 1). omega. apply Zmod_lt_z_m. omega. apply Zmod_le_0_z. omega. Qed.

Set Implicit Arguments.
Unset Strict Implicit.

Definition If (T : Set) (b : bool) (t e : T) :=
   (* If T b t e  =  if b then t else e *)
  match b with
  | true => t
  | false => e
  end.

Set Strict Implicit.
Unset Implicit Arguments.

Lemma Z_to_inject_nat : forall x : Z, 0 <= x -> Z_of_nat (Zabs_nat x) = x.

  simple destruct x. simpl. omega. intros. simpl. symmetry.
  apply Zpos_eq_Z_of_nat_o_nat_of_P. intros p H. absurd (0 <= Zneg p). unfold Zle. tauto.
  assumption. Qed.

Lemma Zlt_0_power_nat : forall i : nat, 0 < Zpower_nat 2 i.

  simple induction i. replace (Zpower_nat 2 0) with 1. omega. trivial. intros n H.
  rewrite <- two_power_nat_correct. rewrite two_power_nat_S. rewrite two_power_nat_correct.
  omega. Qed.

Lemma Zpower_nat_Zpower : forall i : nat, Zpower_nat 2 i = 2 ^ Z_of_nat i.

  induction i. simpl. trivial. rewrite <- two_power_nat_correct. rewrite two_power_nat_S.
  rewrite two_power_nat_correct. rewrite IHi. replace (Z_of_nat (S i)) with (1 + Z_of_nat i).
  rewrite Zpower_exp. replace (2 ^ 1) with 2. trivial. trivial. omega. omega. rewrite inj_S.
  omega. Qed.

Lemma Zpower_Zpower_nat : forall i : Z, 0 <= i -> 2 ^ i = Zpower_nat 2 (Zabs_nat i).

  intros i H. rewrite Zpower_nat_Zpower. rewrite Z_to_inject_nat. trivial. assumption. Qed.

Lemma lt_0_Zpow : forall x : Z, 0 <= x -> 0 < 2 ^ x.

  intros x H. rewrite Zpower_Zpower_nat. apply Zlt_0_power_nat. assumption. Qed.

Lemma Zlt_pow_lt :
  forall i j : Z, 0 <= i -> i < j -> 2 ^ i < 2 ^ j.

  intros i j Hi Hij. replace j with (i + (j - i)). rewrite Zpower_exp.
  apply Zle_lt_trans with (2 ^ i * 2 ^ 0). simpl. omega. apply Zmult_lt_compat_l. apply lt_0_Zpow.
  assumption. replace (j - i) with (j - i - 1 + 1).  rewrite Zpower_exp. replace (2 ^ 1) with 2.
  replace (2 ^ 0) with 1. cut (0 < 2 ^ (j - i - 1)). omega. apply lt_0_Zpow. omega. trivial. trivial.
  omega. omega.  ring. omega. omega. ring. Qed.

Lemma Zle_pow_le :
  forall i j : Z, 0 <= i -> i <= j -> 2 ^ i <= 2 ^ j.

  intros i j Hi Hij. elim (Zle_lt_or_eq i j). intro. apply Zlt_le_weak. apply Zlt_pow_lt.
  assumption. assumption. intro H. rewrite H. omega. assumption. Qed.

Lemma lt_pow_lt :
  forall i j : Z, 0 <= i -> 0 <= j -> 2 ^ i < 2 ^ j -> i < j.

  intros i j Hi Hj Hij. elim (Zle_lt_or_eq i j). trivial. intro H. rewrite H in Hij.
  absurd (2 ^ j < 2 ^ j). omega. assumption. elim (Zle_or_lt i j). trivial. intro H. cut (2 ^ j < 2 ^ i).
  intro H0. absurd (2 ^ j < 2 ^ i); omega. apply Zlt_pow_lt; omega. Qed.

Definition Zlog_sup (M : Z) :=
  match M with
  | Zpos p => log_sup p
  | _ => 0
  end.

Lemma Zlog_sup_pow : forall i : Z, 0 <= i -> Zlog_sup (2 ^ i) = i.

  intros i H. replace (2 ^ i) with (Zpos (shift_nat (Zabs_nat i) 1)). simpl. rewrite log_sup_shift_nat.
  apply Z_to_inject_nat. assumption. rewrite shift_nat_correct. rewrite Zpower_nat_Zpower.
  rewrite Z_to_inject_nat. ring. assumption. Qed.

Lemma two_p_pow : forall z : Z, 0 <= z -> two_p z = 2 ^ z.

  intros z H. unfold two_p. case z. trivial. intro p. rewrite two_power_pos_correct. trivial. trivial. Qed.

Lemma Zlog_sup_correct1 : forall z : Z, 0 < z -> 0 <= Zlog_sup z.

  intro z. case z. intro H. absurd (0 < 0); omega. simpl. intros p H. apply log_sup_correct1.
  intros p H. absurd (0 < Zneg p). simplify_eq. assumption. Qed.

Lemma Zlog_sup_correct2 : forall z : Z, 0 < z -> 2 ^ (Zlog_sup z - 1) < z <= 2 ^ Zlog_sup z.

  intros z H. elim (Zle_or_lt z 1). intro Hz. cut (z = 1). intro H0. rewrite H0. simpl. omega. omega.
  case z. intro. absurd (1 < 0); omega. simpl. intros p H0. rewrite <- two_p_pow. rewrite <- two_p_pow.
  replace (log_sup p - 1) with (Zpred (log_sup p)). apply log_sup_correct2. unfold Zpred. ring. apply log_sup_correct1.
  generalize H0. case p. simpl. intros q H1. cut (0 <= log_inf q). omega. apply log_inf_correct1. simpl.
  intros q H1. cut (0 <= log_sup q). omega. apply log_sup_correct1. intro. absurd (1 < 1); omega.
  intros p H0. absurd (1 < Zneg p). simplify_eq. assumption. Qed.

Lemma Zlog_sup_unique : forall z : Z, 0 < z -> forall i j : Z, 0 <= i -> 0 <= j ->
  2 ^ (i - 1) < z -> z <= 2 ^ i -> 2 ^ (j - 1) < z -> z <= 2 ^ j -> i = j.

  intros z Hz i j Hi Hj H0 H1 H2 H3. elim (Zle_lt_or_eq i j). intro H4. cut (2 ^ i <= 2 ^ (j - 1)).
  intro H5. absurd (2 ^ (j - 1) < z). omega. assumption. apply Zle_pow_le. assumption. omega. trivial.
  elim (Zle_or_lt i j); intro H4. assumption. cut (2 ^ j <= 2 ^ (i - 1)). intro H5.
  absurd (2 ^ (i - 1) < z). omega. assumption. apply Zle_pow_le. assumption. omega. Qed.

Lemma Zlog_sup_from_interval : forall z : Z, 0 < z -> forall i : Z, 0 <= i -> 2 ^ (i - 1) < z ->
  z <= 2 ^ i -> Zlog_sup z = i.

  intros z Hz i Hi Hl Hh. apply Zlog_sup_unique with (z := z). assumption. apply Zlog_sup_correct1.
  assumption. assumption. elim (Zlog_sup_correct2 z). tauto. assumption. elim (Zlog_sup_correct2 z).
  tauto. assumption. assumption. assumption. Qed.

Lemma Zlog_sup_seq : forall p q : Z, p <= q -> Zlog_sup p <= Zlog_sup q.

  intros p q H. elim (Zle_or_lt p 0). intro Hp. replace (Zlog_sup p) with 0. elim (Zle_or_lt q 0).
  intro Hq. replace (Zlog_sup q) with 0. omega. generalize Hq. elim q. trivial. intros r Hr.
  absurd (Zpos r <= 0). apply Zlt_not_le. unfold Zlt. trivial. assumption. intros r Hr. trivial.
  apply Zlog_sup_correct1. generalize Hp. elim p. trivial. intros r Hr. absurd (Zpos r <= 0).
  apply Zlt_not_le. unfold Zlt. trivial. assumption. intros r Hr. trivial. intro H0.
  elim (Zle_or_lt (Zlog_sup p) (Zlog_sup q)); intro H1. assumption. cut (Zlog_sup q <= Zlog_sup p - 1).
  intro H2. cut (2 ^ Zlog_sup q <= 2 ^ (Zlog_sup p - 1)). intro H3. absurd (p <= q). apply Zlt_not_le.
  apply Zle_lt_trans with (2 ^ Zlog_sup q). elim (Zlog_sup_correct2 q). omega. omega.
  elim (Zlog_sup_correct2 p). omega. assumption. assumption. apply Zle_pow_le. apply Zlog_sup_correct1.
  omega. assumption. omega. Qed.

Lemma Z_pow_plus : forall x : Z, 0 <= x -> 2 ^ x + 2 ^ x = 2 ^ (x + 1).

  intros. rewrite Zplus_diag_eq_mult_2. rewrite Zpower_exp. trivial. omega. omega. Qed.

Lemma Zdivdivdiv : forall x y z : Z, 0 < y -> 0 < z -> x / y / z = x / (y * z).

  intros x y z H H0.
  replace (x / y / z) with
   ((x / (y * z) * z * y + x mod (y * z)) / y / z).
  rewrite Zdiv_times_plus. rewrite Zdiv_times_plus. rewrite Zplus_comm. rewrite Zdiv_small_0. ring.
  apply Zle_0_div. apply Zmod_le_0_z. apply Zmult_lt_0_compat; assumption. assumption.
  apply Zle_lt_trans with ((y * z - 1) / y). apply Zdiv_le. assumption. cut (x mod (y * z) < y * z).
  omega. apply Zmod_lt_z_m. apply Zmult_lt_0_compat; omega. rewrite Zmult_comm. rewrite Zdiv_mult_minus;
  omega. assumption. assumption. rewrite Zmult_comm with (n := y). rewrite <- Zmult_assoc.
  rewrite Zdivmod_split. trivial. apply Zmult_lt_0_compat; assumption. Qed.

Lemma Zdiv_simpl : forall x y z : Z, 0 < y -> 0 < z -> (x * z) / (y * z) = x / y.

  intros x y z H H0. rewrite Zmult_comm with (n := y). rewrite <- Zdivdivdiv.
  rewrite Z_div_mult. trivial. omega. assumption. assumption. Qed.

Lemma Zdiv_den_le : forall x y z : Z, 0 <= x -> 0 < z -> z <= y -> x / y <= x / z.

  intros x y z H H0 H1. rewrite <- Zdiv_simpl with (y := y) (z := z).
  rewrite <- Zdiv_simpl with (y := z) (z := y). rewrite Zmult_comm with (n := y).
  apply Zdiv_le. apply Zmult_lt_0_compat; omega. apply Zmult_le_compat_l; omega. assumption. omega. omega.
  assumption. Qed.

Lemma approx_cz : forall c y z : Z, 0 < c -> 0 < y -> 0 <= z -> z <= c ->
  z / y - c / y * z / c <= 1.

  intros c y z Hc Hy Hz Hzc. rewrite <- Z_div_mult with (a := z / y - c / y * z / c) (b := c * y).
  rewrite Zmult_minus_distr_r. rewrite Zmult_comm with (n := c). rewrite Zmult_assoc.
  rewrite Zdiv_a_b_b_Zmod. rewrite Zmult_comm with (n := y). rewrite Zmult_assoc. rewrite Zdiv_a_b_b_Zmod.
  do 2 rewrite Zmult_minus_distr_r. rewrite <- Zmult_assoc. rewrite Zmult_comm with (m := y).
  rewrite Zmult_assoc. rewrite Zdiv_a_b_b_Zmod. rewrite Zmult_minus_distr_r.
  replace (z * c - z mod y * c - (c * z - c mod y * z - (c / y * z) mod c * y))
     with (c mod y * z + (c / y * z) mod c * y - z mod y * c).
  apply Zle_trans with ((c mod y * z + c * y) / (c * y)). apply Zdiv_le. apply Zmult_lt_0_compat;
  assumption. apply Zle_trans with (c mod y * z + (c / y * z) mod c * y). cut (0 <= z mod y * c). omega.
  apply Zmult_le_0_compat. apply Zmod_le_0_z. assumption. omega. apply Zplus_le_compat. omega.
  apply Zmult_le_compat_r. apply Zlt_le_weak. apply Zmod_lt_z_m. assumption. omega.
  replace (c mod y * z + c * y) with (1 * (c * y) + c mod y * z).
  rewrite Zdiv_times_plus. cut (c mod y * z / (c * y) <= 0). omega.
  apply Zle_trans with ((y - 1) * z / (c * y)). apply Zdiv_le. apply Zmult_lt_0_compat; assumption.
  apply Zmult_le_compat_r. cut (c mod y < y). omega. apply Zmod_lt_z_m.
  assumption. omega. rewrite Zdiv_small_0. omega. apply Zmult_le_0_compat; omega.
  rewrite Zmult_comm with (n := c). elim (Zle_lt_or_eq 0 z). intro H. apply Zlt_le_trans with (y * z).
  apply Zmult_lt_compat_r. assumption. omega. apply Zmult_le_compat_l; omega. intro H. rewrite <- H.
  replace ((y - 1) * 0) with 0. apply Zmult_lt_0_compat; assumption. ring. assumption.
  apply Zmult_lt_0_compat; assumption. ring. ring. assumption. assumption. assumption.
  apply Zmult_gt_0_compat; omega. Qed.

Lemma approx_le1 : forall a b y x : Z, 0 < a -> 0 < b -> 0 < y -> 0 <= x -> x < a * b + a ->
  x / a * a / y - x / a * (a * b / y) / b <= 1.

  intros a b y x Ha Hb Hy Hx Hxab. rewrite Zmult_comm with (m := a * b / y).
  rewrite <- Zdiv_simpl with (y := b) (z := a). rewrite <- Zmult_assoc. rewrite Zmult_comm with (n := b).
  apply approx_cz. apply Zmult_lt_0_compat; assumption. assumption. apply Zmult_le_0_compat.
  apply Zle_0_div; assumption. omega. rewrite Zmult_comm with (m := b). apply Zmult_le_compat_r.
  apply Zle_trans with ((b * a + (a - 1)) / a). apply Zdiv_le. assumption. rewrite Zmult_comm. omega.
  rewrite Zdiv_mult_plus; omega. omega. assumption. assumption. Qed.

Lemma approx_m1_one : forall a b y x : Z, 0 < a -> 0 < b -> 0 < y -> 0 <= x -> x < a * b + a ->
  x / a * a / y - 1 <= x / a * (a * b / y) / b.

  intros a b y x Ha Hb Hy Hx Hxab. cut (x / a * a / y - x / a * (a * b / y) / b <= 1). omega.
  apply approx_le1; assumption. Qed.

Lemma approx_cz0 : forall c y z : Z, 0 < c -> 0 < y -> 0 <= z ->
  c / y * z / c <= z / y.

  intros c y z Hc Hy Hz. rewrite <- Zdiv_simpl with (z := y). replace (c / y * z * y) with (c / y * y * z).
  apply Zle_trans with (c * z / (c * y)). apply Zdiv_le. apply Zmult_lt_0_compat; assumption.
  apply Zmult_le_compat_r. rewrite Zmult_comm. apply Z_mult_div_ge. omega. assumption.
  do 2 rewrite Zmult_comm with (n := c). rewrite Zdiv_simpl. omega. assumption. assumption. ring.
  assumption. assumption. Qed.

Lemma approx_ab_le : forall a b y x : Z, 0 < a -> 0 < b -> 0 < y -> 0 <= x ->
  x / a * (a * b / y) / b <= x / a * a / y.

  intros a b y x Ha Hb Hy Hx. rewrite Zmult_comm. rewrite <- Zdiv_simpl with (z := a).
  rewrite <- Zmult_assoc. rewrite Zmult_comm with (n := b). apply approx_cz0. apply Zmult_lt_0_compat; assumption.
  assumption. apply Zmult_le_0_compat. apply Zle_0_div; assumption. omega. assumption. assumption. Qed.

Lemma approx_m1_two : forall y a b x : Z, 0 < y -> 0 < a -> a <= y -> 0 < b -> 0 <= x ->
  x / y - 1 <= x / a * a / y.

  intros y a b x lt_0_y lt_0_a le_a_y lt_0_b le_0_x. replace (x / y) with ((a * (x / a) + x mod a) / y).
  unfold Zminus. rewrite <- Z_div_plus. apply Zdiv_le. assumption. rewrite Zmult_comm.
  cut (x mod a <= 1 * y). omega. apply Zle_trans with a. apply Zlt_le_weak. apply Zmod_lt_z_m. assumption.
  omega. omega. rewrite <- Z_div_mod_eq. trivial. omega. Qed.

Lemma approx_m2 : forall y a b x : Z, 0 < y -> 0 < a -> a <= y -> 0 < b -> 0 <= x ->
  x < a * b + a -> x / y - 2 <= x / a * (a * b / y) / b.

  intros y a b x lt_0_y lt_0_a lt_a_y lt_0_b le_0_x lt_x_ab.
  apply Zle_trans with (x / a * a / y - 1). cut (x / y - 1 <= x / a * a / y). omega.
  apply approx_m1_two with (b := b); assumption. apply approx_m1_one; omega. Qed.

Lemma approx_0_one : forall y a b x : Z, 0 < y -> 0 < a -> 0 < b -> 0 <= x ->
  x / a * (a * b / y) / b <= x / a * a / y.

  intros y a b x lt_0_y lt_0_a lt_0_b le_0_x. rewrite <- Zdiv_simpl with (z := y). rewrite <- Zmult_assoc.
  apply Zle_trans with (x / a * (a * b) / (b * y)). apply Zdiv_le. apply Zmult_lt_0_compat; omega.
  apply Zmult_le_compat_l. rewrite Zmult_comm. apply Z_mult_div_ge. omega. apply Zle_0_div;
  omega. rewrite Zmult_comm with (m := y). rewrite Zmult_assoc. rewrite Zdiv_simpl. omega. assumption.
  assumption. assumption. assumption. Qed.

Lemma approx_0_two : forall y a b x : Z, 0 < y -> 0 < a -> 0 < b -> 0 <= x ->
  x / a * a / y <= x / y.

  intros y a b x lt_0_y lt_0_a lt_0_b le_0_x.
  apply Zdiv_le. assumption. rewrite Zmult_comm. apply Z_mult_div_ge. omega. Qed.

Lemma approx_0 : forall y a b x : Z, 0 < y -> 0 < a -> 0 < b -> 0 <= x ->
  x / a * (a * b / y) / b <= x / y.

  intros y a b x lt_0_y lt_0_a lt_0_b le_0_x. apply Zle_trans with (x / a * a / y). apply approx_0_one;
  assumption. apply approx_0_two with (b := b); assumption. Qed.

Lemma mod_over_div : forall a b c m : Z, 0 < b -> 0 < m -> (a * b + c) / b * b mod m = (a mod m * b + c) / b * b mod m.

  intros a b c m Hb Hm. rewrite Zplus_comm. rewrite Z_div_plus. rewrite Zplus_comm with (m := c). rewrite Z_div_plus.
  rewrite Zmod_mult_distr_l. rewrite Zplus_comm. rewrite Zmod_plus_distr_l. rewrite Zplus_comm. rewrite <- Zmod_mult_distr_l.
  trivial. assumption. assumption. assumption. omega. omega. Qed.

Lemma sum_r'_i : forall a b m : Z, 0 < m -> (a mod m + b mod m) / m = 0 \/ (a mod m + b mod m) / m = 1.

  intros a b m H. cut (0 <= (a mod m + b mod m) / m). cut ((a mod m + b mod m) / m <= 1). omega.
  apply Zle_trans with ((m - 1 + m) / m). apply Zdiv_le. omega. apply Zplus_le_compat. cut (a mod m < m). omega.
  apply Zmod_lt_z_m. omega. cut (b mod m < m). omega. apply Zmod_lt_z_m. omega. replace (m - 1 + m) with (2 * m - 1).
  rewrite Zdiv_mult_minus. omega. omega. omega. omega. ring. apply Zle_0_div. fold (0 + 0). apply Zplus_le_compat.
  apply Zmod_le_0_z. omega. apply Zmod_le_0_z. omega. omega. Qed.

Lemma mod_plus : forall a b m : Z, 0 < m -> a mod m + b mod m = (a + b) mod m \/ a mod m + b mod m = (a + b) mod m + m.

  intros a b m H. rewrite Z_div_mod_eq with (a := a mod m + b mod m) (b := m). elim sum_r'_i with (a := a) (b := b) (m := m).
  intro H0. rewrite H0. left. rewrite <- Zmod_plus_distr_l. rewrite Zplus_comm with (n := a). rewrite <- Zmod_plus_distr_l.
  rewrite Zplus_comm with (m := a). ring. omega. omega. intro H0. rewrite H0. right. rewrite <- Zmod_plus_distr_l.
  rewrite Zplus_comm with (n := a). rewrite <- Zmod_plus_distr_l. rewrite Zplus_comm with (m := a). ring. omega. omega. omega.
  omega. Qed.

Lemma div_m_1 : forall m : Z, 0 < m -> 2 ^ Zlog_sup m / m = 1.

  intros m H. elim (Zle_lt_or_eq 1 m). intro H0. replace (2 ^ Zlog_sup m) with (1 * m + (2 ^ Zlog_sup m - m)).
  apply Zdiv_mult_plus. omega. cut (m <= 2 ^ Zlog_sup m). omega. elim (Zlog_sup_correct2 m). tauto. assumption.
  cut (2 ^ Zlog_sup m < m + m). omega.
  apply Zlt_le_trans with (2 ^ (Zlog_sup m - 1) + 1 + (2 ^ (Zlog_sup m - 1) + 1)).
  replace (2 ^ (Zlog_sup m - 1) + 1 + (2 ^ (Zlog_sup m - 1) + 1))
     with (2 ^ (Zlog_sup m - 1) + 2 ^ (Zlog_sup m - 1) + 2). rewrite Z_pow_plus.
  replace (Zlog_sup m - 1 + 1) with (Zlog_sup m). omega. ring. cut (1 <= Zlog_sup m). omega. replace 1 with (Zlog_sup 2).
  apply Zlog_sup_seq. omega. trivial. ring. apply Zplus_le_compat. cut (2 ^ (Zlog_sup m - 1) < m). omega.
  elim (Zlog_sup_correct2 m). tauto. assumption. cut (2 ^ (Zlog_sup m - 1) < m). omega. elim (Zlog_sup_correct2 m). tauto.
  assumption. ring. intro H0. rewrite <- H0. simpl. unfold Zdiv. trivial. omega. Qed.

Lemma div_r'_i : forall a m : Z, 0 < m -> a mod 2 ^ Zlog_sup m / m = 0 \/ a mod 2 ^ Zlog_sup m / m = 1.

  intros a m H. cut (0 <= a mod 2 ^ Zlog_sup m / m). cut (a mod 2 ^ Zlog_sup m / m <= 1). omega.
  apply Zle_trans with (2 ^ Zlog_sup m / m). apply Zdiv_le. assumption. cut (a mod 2 ^ Zlog_sup m < 2 ^ Zlog_sup m). omega.
  apply Zmod_lt_z_m. apply lt_0_Zpow. apply Zlog_sup_correct1. assumption. rewrite div_m_1. omega. assumption. apply Zle_0_div.
  apply Zmod_le_0_z. apply lt_0_Zpow. apply Zlog_sup_correct1. assumption. assumption. Qed.

(* <KEEP TOGETHER - approx_0_m2 *)
Theorem approx_0_m2 : forall (y b : Zpls) (a : Z_ y) (x : Z_ (a * b + a)),
  x / y - 2 <= x / a * (a * b / y) / b <= x / y.

  intros y b a x. split. apply approx_m2. case y; trivial. elim (Zle_lt_or_eq 0 a). trivial. intro H.
  rewrite <- H in x. simpl in x. elim x. unfold in_Z_. intros z H0. elim H0; intros H1 H2. absurd (z < 0);
  omega. apply le_0__Z. apply Zlt_le_weak. apply lt_z__Z. case b; trivial. apply le_0__Z. apply lt_z__Z.
  apply approx_0. elim y; trivial. elim (Zle_lt_or_eq 0 a). trivial. intro H. rewrite <- H in x.
  simpl in x. elim x. unfold in_Z_. intros z H0. elim H0; intros H1 H2. absurd (z < 0);
  omega. apply le_0__Z. elim b; trivial. apply le_0__Z. Qed.
(* KEEP TOGETHER> - approx_0_m2 *)

(* <KEEP TOGETHER - div_approx1 *)
Theorem div_approx1 : forall (y : Zpls) (a : Zpls) (b : Zpls)
  (x : Z_ (a * b + a)),
    x / a * a / y - 1 <= x / a * (a * b / y) / b <=
    x / a * a / y.

  intros y a b x. cut (0 < y). cut (0 < a). cut (0 < b).
  cut (0 <= x). cut (x < (a * b + a)). intros Hxlt H0lex Hb Ha Hy. split.
  apply approx_m1_one; assumption. apply approx_ab_le; assumption. apply lt_z__Z. apply le_0__Z.
  elim b. trivial. elim a. trivial. elim y. trivial. Qed.
(* KEEP TOGETHER> - div_approx1 *)

Close Scope Z_scope.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Lists.List.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.ListUtil.
Require Export Crypto.Util.FixCoqMistakes.

Fixpoint tuple' T n : Type :=
  match n with
  | O => T
  | S n' => (tuple' T n' * T)%type
  end.

Definition tuple T n : Type :=
  match n with
  | O => unit
  | S n' => tuple' T n'
  end.

(** right-associated tuples *)
Fixpoint rtuple' T n : Type :=
  match n with
  | O => T
  | S n' => (T * rtuple' T n')%type
  end.

Definition rtuple T n : Type :=
  match n with
  | O => unit
  | S n' => rtuple' T n'
  end.

Fixpoint rsnoc' T n {struct n} : forall (x : rtuple' T n) (y : T), rtuple' T (S n)
  := match n return forall (x : rtuple' T n) (y : T), rtuple' T (S n) with
     | O => fun x y => (x, y)
     | S n' => fun x y => (fst x, @rsnoc' T n' (snd x) y)
     end.
Global Arguments rsnoc' {T n} _ _.

Fixpoint cons' T n {struct n} : forall (y : T) (x : tuple' T n), tuple' T (S n)
  := match n return forall (y : T) (x : tuple' T n), tuple' T (S n) with
     | O => fun y x => (y, x)
     | S n' => fun y x => (@cons' T n' y (fst x), snd x)
     end.
Global Arguments cons' {T n} _ _.

Fixpoint assoc_right' {n T} {struct n}
  : tuple' T n -> rtuple' T n
  := match n return tuple' T n -> rtuple' T n with
     | 0 => fun x => x
     | S n' => fun ts => let xs := @assoc_right' n' T (fst ts) in
                         let x := snd ts in
                         rsnoc' xs x
     end.

Definition assoc_right {n T}
  : tuple T n -> rtuple T n
  := match n with
     | 0 => fun x => x
     | S n' => @assoc_right' n' T
     end.

Fixpoint assoc_left' {n T} {struct n}
  : rtuple' T n -> tuple' T n
  := match n return rtuple' T n -> tuple' T n with
     | 0 => fun x => x
     | S n' => fun ts => let xs := @assoc_left' n' T (snd ts) in
                         let x := fst ts in
                         cons' x xs
     end.

Definition assoc_left {n T}
  : rtuple T n -> tuple T n
  := match n with
     | 0 => fun x => x
     | S n' => @assoc_left' n' T
     end.

Definition tl' {T n} : tuple' T (S n) -> tuple' T n := @fst _ _.
Definition tl {T n} : tuple T (S n) -> tuple T n :=
  match n with
  | O => fun _ => tt
  | S n' => @tl' T n'
  end.
Definition hd' {T n} : tuple' T n -> T :=
  match n with
  | O => fun x => x
  | S n' => @snd _ _
  end.
Definition hd {T n} : tuple T (S n) -> T := @hd' _ _.

Fixpoint to_list' {T} (n:nat) {struct n} : tuple' T n -> list T :=
  match n with
  | 0 => fun x => (x::nil)%list
  | S n' => fun xs : tuple' T (S n') => let (xs', x) := xs in (x :: to_list' n' xs')%list
  end.

Definition to_list {T} (n:nat) : tuple T n -> list T :=
  match n with
  | 0 => fun _ => nil
  | S n' => fun xs : tuple T (S n') => to_list' n' xs
  end.

Program Fixpoint from_list' {T} (y:T) (n:nat) (xs:list T) : length xs = n -> tuple' T n :=
  match n return _ with
  | 0 =>
    match xs return (length xs = 0 -> tuple' T 0) with
    | nil => fun _ => y
    | _ => _ (* impossible *)
    end
  | S n' =>
    match xs return (length xs = S n' -> tuple' T (S n')) with
    | cons x xs' => fun _ => (from_list' x n' xs' _, y)
    | _ => _ (* impossible *)
    end
  end.

Program Definition from_list {T} (n:nat) (xs:list T) : length xs = n -> tuple T n :=
match n return _ with
| 0 =>
    match xs return (length xs = 0 -> tuple T 0) with
    | nil => fun _ : 0 = 0 => tt
    | _ => _ (* impossible *)
    end
| S n' =>
    match xs return (length xs = S n' -> tuple T (S n')) with
    | cons x xs' => fun _ => from_list' x n' xs' _
    | _ => _ (* impossible *)
    end
end.

Lemma to_list_from_list : forall {T} (n:nat) (xs:list T) pf, to_list n (from_list n xs pf) = xs.
Proof.
  destruct xs; simpl; intros; subst; auto.
  generalize dependent t. simpl in *.
  induction xs; simpl in *; intros; congruence.
Qed.

Lemma length_to_list' T n t : length (@to_list' T n t) = S n.
Proof. induction n; simpl in *; trivial; destruct t; simpl; congruence. Qed.

Lemma length_to_list : forall {T} {n} (xs:tuple T n), length (to_list n xs) = n.
Proof.
  destruct n; [ reflexivity | apply length_to_list' ].
Qed.

Lemma from_list'_to_list' : forall T n (xs:tuple' T n),
    forall x xs' pf, to_list' n xs = cons x xs' ->
      from_list' x n xs' pf = xs.
Proof.
  induction n; intros.
  { simpl in *. injection H; clear H; intros; subst. congruence. }
  { destruct xs eqn:Hxs;
    destruct xs' eqn:Hxs';
    injection H; clear H; intros; subst; try discriminate.
    simpl. f_equal. eapply IHn. assumption. }
Qed.

Lemma from_list_to_list : forall {T n} (xs:tuple T n) pf, from_list n (to_list n xs) pf = xs.
Proof.
  destruct n; auto; intros; simpl in *.
  { destruct xs; auto. }
  { destruct (to_list' n xs) eqn:H; try discriminate.
    eapply from_list'_to_list'; assumption. }
Qed.

Lemma to_list_S {A n} (x : tuple A (S n)) (a:A)
  : to_list (T:=A) (S (S n)) (x,a) = a :: to_list (S n) x.
Proof. reflexivity. Qed.

Fixpoint curry'T (R T : Type) (n : nat) : Type
  := match n with
     | 0 => T -> R
     | S n' => curry'T (T -> R) T n'
     end.
Definition curryT (R T : Type) (n : nat) : Type
  := match n with
     | 0 => R
     | S n' => curry'T R T n'
     end.

Fixpoint uncurry' {R T n} : (tuple' T n -> R) -> curry'T R T n
  := match n return (tuple' T n -> R) -> curry'T R T n with
     | 0 => fun f x => f x
     | S n' => fun f => @uncurry' (T -> R) T n' (fun xs x => f (xs, x))
     end.

Fixpoint uncurry {R T n} : (tuple T n -> R) -> curryT R T n
  := match n return (tuple T n -> R) -> curryT R T n with
     | 0 => fun f => f tt
     | S n' => @uncurry' R T n'
     end.

Fixpoint curry' {R T n} : curry'T R T n -> (tuple' T n -> R)
  := match n return curry'T R T n -> (tuple' T n -> R) with
     | 0 => fun f x => f x
     | S n' => fun f xs_x => @curry' (T -> R) T n' f (fst xs_x) (snd xs_x)
     end.

Fixpoint curry {R T n} : curryT R T n -> (tuple T n -> R)
  := match n return curryT R T n -> (tuple T n -> R) with
     | 0 => fun r _ => r
     | S n' => @curry' R T n'
     end.

Fixpoint eta' {n A B} : (tuple' A n -> B) -> tuple' A n -> B
  := match n with
     | 0 => fun f => f
     | S n' => fun (f : tuple' A n' * A -> B)
                   (xy : tuple' A n' * A)
               => let '(x, y) := xy in
                  eta' (fun x => f (x, y)) x
     end.

Definition eta {n A B} : (tuple A n -> B) -> tuple A n -> B
  := match n with
     | 0 => fun f => f
     | S n' => @eta' n' A B
     end.

Definition on_tuple {A B} (f:list A -> list B)
           {n m:nat} (H:forall xs, length xs = n -> length (f xs) = m)
           (xs:tuple A n) : tuple B m :=
  from_list m (f (to_list n xs))
            (H (to_list n xs) (length_to_list xs)).

Section map.
  (* Put the types and function in the context, so that the fixpoint doesn't depend on them *)
  Context {A B} (f:A -> B).

  Fixpoint map' {n} : tuple' A n -> tuple' B n
    := match n with
       | 0 => f
       | S n' => fun x : tuple' _ _ * _ => (@map' n' (fst x), f (snd x))
       end.
End map.

Definition map {n A B} (f:A -> B) : tuple A n -> tuple B n
  := match n with
     | 0 => fun x => x
     | S n' => map' f
     end.

Definition on_tuple2 {A B C} (f : list A -> list B -> list C) {a b c : nat}
           (Hlength : forall la lb, length la = a -> length lb = b -> length (f la lb) = c)
           (ta:tuple A a) (tb:tuple B b) : tuple C c
  := from_list c (f (to_list a ta) (to_list b tb))
               (Hlength (to_list a ta) (to_list b tb) (length_to_list ta) (length_to_list tb)).

Definition map2 {n A B C} (f:A -> B -> C) (xs:tuple A n) (ys:tuple B n) : tuple C n
  := on_tuple2 (map2 f) (fun la lb pfa pfb => eq_trans (@map2_length _ _ _ _ la lb) (eq_trans (f_equal2 _ pfa pfb) (Min.min_idempotent _))) xs ys.

Lemma to_list'_ext {n A} (xs ys:tuple' A n) : to_list' n xs = to_list' n ys -> xs = ys.
Proof.
  induction n; simpl in *; [cbv; congruence|]; destruct_head' prod.
  intro Hp; injection Hp; clear Hp; intros; subst; eauto using f_equal2.
Qed.

Lemma to_list_ext {n A} (xs ys:tuple A n) : to_list n xs = to_list n ys -> xs = ys.
Proof.
  destruct n; simpl in *; destruct_head unit; eauto using to_list'_ext.
Qed.

Lemma from_list'_complete {A n} (xs:tuple' A n) : exists x ls pf, xs = from_list' x n ls pf.
Proof.
  destruct n; simpl in xs.
  {  exists xs. exists nil. exists eq_refl. reflexivity. }
  { destruct xs as [xs' x]. exists x. exists (to_list' _ xs'). eexists (length_to_list' _ _ _).
    symmetry; eapply from_list'_to_list'. reflexivity. }
Qed.

Lemma from_list_complete {A n} (xs:tuple A n) : exists ls pf, xs = from_list n ls pf.
Proof.
  exists (to_list n xs). exists (length_to_list _). symmetry; eapply from_list_to_list.
Qed.

Ltac tuples_from_lists :=
  repeat match goal with
         | [xs:tuple ?A _ |- _] =>
           let ls := fresh "l" xs in
           destruct (from_list_complete xs) as [ls [? ?]]; subst
         | [xs:tuple' ?A _ |- _] =>
           let a := fresh A in
           let ls := fresh "l" xs in
           destruct (from_list'_complete xs) as [a [ls [? ?]]]; subst
         end.

Lemma map_to_list {A B n ts} (f : A -> B)
  : List.map f (@to_list A n ts) = @to_list B n (map f ts).
Proof.
  destruct n; simpl; [ reflexivity | ].
  induction n; simpl in *; [ reflexivity | ].
  destruct ts; simpl; congruence.
Qed.

Lemma to_list_map2 {A B C n xs ys} (f : A -> B -> C)
  : ListUtil.map2 f (@to_list A n xs) (@to_list B n ys) = @to_list C n (map2 f xs ys).
Proof.
  tuples_from_lists; unfold map2, on_tuple2.
  repeat (rewrite to_list_from_list || rewrite from_list_to_list).
  reflexivity.
Qed.

Ltac tuple_maps_to_list_maps :=
  try eapply to_list_ext;
  tuples_from_lists;
  repeat (rewrite <-@map_to_list || rewrite <-@to_list_map2 ||
          rewrite @to_list_from_list || rewrite @from_list_to_list).

Lemma map_map2 {n A B C D} (f:A -> B -> C) (g:C -> D) (xs:tuple A n) (ys:tuple B n)
  : map g (map2 f xs ys) = map2 (fun a b => g (f a b)) xs ys.
Proof.
  tuple_maps_to_list_maps; eauto using ListUtil.map_map2.
Qed.

Lemma map2_fst {n A B C} (f:A -> C) (xs:tuple A n) (ys:tuple B n)
  : map2 (fun a b => f a) xs ys = map f xs.
Proof.
  tuple_maps_to_list_maps; eauto using ListUtil.map2_fst.
Qed.

Lemma map2_snd {n A B C} (f:B -> C) (xs:tuple A n) (ys:tuple B n)
  : map2 (fun a b => f b) xs ys = map f ys.
Proof.
  tuple_maps_to_list_maps; eauto using ListUtil.map2_snd.
Qed.

Lemma map_id_ext {n A} (f : A -> A) (xs:tuple A n)
  : (forall x, f x = x) -> map f xs = xs.
Proof.
  intros; tuple_maps_to_list_maps.
  transitivity (List.map (fun x => x) lxs).
  { eapply ListUtil.pointwise_map; cbv [pointwise_relation]; eauto. }
  { eapply List.map_id. }
Qed.

Lemma map_id {n A} (xs:tuple A n)
  : map (fun x => x) xs = xs.
Proof. eapply map_id_ext; intros; reflexivity. Qed.

Lemma map2_map {n A B C A' B'} (f:A -> B -> C) (g:A' -> A) (h:B' -> B) (xs:tuple A' n) (ys:tuple B' n)
  : map2 f (map g xs) (map h ys) = map2 (fun a b => f (g a) (h b)) xs ys.
Proof.
  tuple_maps_to_list_maps; eauto using ListUtil.map2_map.
Qed.

Lemma map_S' {n A B} (f:A -> B) (xs:tuple A (S n)) (x:A)
  : map (n:=S (S n)) f (xs, x) = (map (n:=S n) f xs, f x).
Proof.
  tuple_maps_to_list_maps.
  destruct lxs as [|x' lxs']; [simpl in *; discriminate|].
  change ( f x :: List.map f (to_list (S n) (from_list (S n) (x' :: lxs') x0)) = f x :: to_list (S n) (map f (from_list (S n) (x' :: lxs') x0)) ).
  tuple_maps_to_list_maps.
  reflexivity.
Qed.

Definition map_S {n A B} (f:A -> B) (xs:tuple' A n) (x:A)
  : map (n:=S (S n)) f (xs, x) = (map (n:=S n) f xs, f x) := map_S' _ _ _.

Lemma map2_S' {n A B C} (f:A -> B -> C) (xs:tuple A (S n)) (ys:tuple B (S n)) (x:A) (y:B)
  : map2 (n:=S (S n)) f (xs, x) (ys, y) = (map2 (n:=S n) f xs ys, f x y).
Proof.
  tuple_maps_to_list_maps.
  destruct lxs as [|x' lxs']; [simpl in *; discriminate|].
  destruct lys as [|y' lys']; [simpl in *; discriminate|].
  change ( f x y ::  ListUtil.map2 f (to_list (S n) (from_list (S n) (x' :: lxs') x1))
    (to_list (S n) (from_list (S n) (y' :: lys') x0)) = f x y :: to_list (S n) (map2 f (from_list (S n) (x' :: lxs') x1) (from_list (S n) (y' :: lys') x0)) ).
  tuple_maps_to_list_maps.
  reflexivity.
Qed.

Definition map2_S {n A B C} (f:A -> B -> C) (xs:tuple' A n) (ys:tuple' B n) (x:A) (y:B)
  : map2 (n:=S (S n)) f (xs, x) (ys, y) = (map2 (n:=S n) f xs ys, f x y) := map2_S' _ _ _ _ _.

Lemma map2_map_fst {n A B C A'} (f:A -> B -> C) (g:A' -> A) (xs:tuple A' n) (ys:tuple B n)
  : map2 f (map g xs) ys = map2 (fun a b => f (g a) b) xs ys.
Proof.
  rewrite <- (map2_map f g (fun x => x)), map_id; reflexivity.
Qed.

Lemma map2_map_snd {n A B C B'} (f:A -> B -> C) (g:B' -> B) (xs:tuple A n) (ys:tuple B' n)
  : map2 f xs (map g ys) = map2 (fun a b => f a (g b)) xs ys.
Proof.
  rewrite <- (map2_map f (fun x => x) g), map_id; reflexivity.
Qed.

Lemma map_map {n A B C} (g : B -> C) (f : A -> B) (xs:tuple A n)
  : map g (map f xs) = map (fun x => g (f x)) xs.
Proof. tuple_maps_to_list_maps; eapply List.map_map. Qed.

Section monad.
  Context (M : Type -> Type) (bind : forall X Y, M X -> (X -> M Y) -> M Y) (ret : forall X, X -> M X).
  Fixpoint lift_monad' {n A} {struct n}
    : tuple' (M A) n -> M (tuple' A n)
    := match n return tuple' (M A) n -> M (tuple' A n) with
       | 0 => fun t => t
       | S n' => fun xy => bind _ _ (@lift_monad' n' _ (fst xy)) (fun x' => bind _ _ (snd xy) (fun y' => ret _ (x', y')))
       end.
  Fixpoint push_monad' {n A} {struct n}
    : M (tuple' A n) -> tuple' (M A) n
    := match n return M (tuple' A n) -> tuple' (M A) n with
       | 0 => fun t => t
       | S n' => fun xy => (@push_monad' n' _ (bind _ _ xy (fun xy' => ret _ (fst xy'))),
                            bind _ _ xy (fun xy' => ret _ (snd xy')))
       end.
  Definition lift_monad {n A}
    : tuple (M A) n -> M (tuple A n)
    := match n return tuple (M A) n -> M (tuple A n) with
       | 0 => ret _
       | S n' => @lift_monad' n' A
       end.
  Definition push_monad {n A}
    : M (tuple A n) -> tuple (M A) n
    := match n return M (tuple A n) -> tuple (M A) n with
       | 0 => fun _ => tt
       | S n' => @push_monad' n' A
       end.
End monad.
Local Notation option_bind
  := (fun A B (x : option A) f => match x with
                                  | Some x' => f x'
                                  | None => None
                                  end).
Definition lift_option {n A} (xs : tuple (option A) n) : option (tuple A n)
  := lift_monad (fun T => option T) option_bind (fun T v => @Some T v) xs.
Definition push_option {n A} (xs : option (tuple A n)) : tuple (option A) n
  := push_monad (fun T => option T) option_bind (fun T v => @Some T v) xs.

Lemma lift_push_option {n A} (xs : option (tuple A (S n))) : lift_option (push_option xs) = xs.
Proof.
  simpl in *.
  induction n; [ reflexivity | ].
  simpl in *; rewrite IHn; clear IHn.
  destruct xs as [ [? ?] | ]; reflexivity.
Qed.

Lemma push_lift_option {n A} {xs : tuple (option A) (S n)} {v}
  : lift_option xs = Some v <-> xs = push_option (Some v).
Proof.
  simpl in *.
  induction n; [ reflexivity | ].
  specialize (IHn (fst xs) (fst v)).
  repeat first [ progress destruct_head_hnf' prod
               | progress destruct_head_hnf' and
               | progress destruct_head_hnf' iff
               | progress destruct_head_hnf' option
               | progress inversion_option
               | progress inversion_prod
               | progress subst
               | progress break_match
               | progress simpl in *
               | progress specialize_by exact eq_refl
               | reflexivity
               | split
               | intro ].
Qed.

Fixpoint fieldwise' {A B} (n:nat) (R:A -> B -> Prop) : tuple' A n -> tuple' B n -> Prop
  := match n with
     | 0 => R
     | S n' => fun (x y : tuple' _ _ * _)
               => @fieldwise' A B n' R (fst x) (fst y) /\ R (snd x) (snd y)
     end.
Definition fieldwise {A B} (n:nat) (R:A -> B -> Prop) : tuple A n -> tuple B n -> Prop
  := match n with
     | 0 => fun _ _ => True
     | S n' => fieldwise' n' R
     end.

Local Ltac Equivalence_fieldwise'_t :=
  let n := match goal with |- ?R (fieldwise' ?n _) => n end in
  let IHn := fresh in
  (* could use [dintuition] in 8.5 only, and remove the [destruct] *)
  repeat match goal with
         | [ H : Equivalence _ |- _ ] => destruct H
         | [ |- Equivalence _ ] => constructor
         end;
  induction n as [|? IHn]; [solve [auto]|];
  simpl; constructor; repeat intro; repeat intuition eauto.

Section Equivalence.
  Context {A} {R:relation A}.
  Global Instance Reflexive_fieldwise' {R_Reflexive:Reflexive R} {n:nat} : Reflexive (fieldwise' n R) | 5.
  Proof. Equivalence_fieldwise'_t. Qed.
  Global Instance Symmetric_fieldwise' {R_Symmetric:Symmetric R} {n:nat} : Symmetric (fieldwise' n R) | 5.
  Proof. Equivalence_fieldwise'_t. Qed.
  Global Instance Transitive_fieldwise' {R_Transitive:Transitive R} {n:nat} : Transitive (fieldwise' n R) | 5.
  Proof. Equivalence_fieldwise'_t. Qed.
  Global Instance Equivalence_fieldwise' {R_equiv:Equivalence R} {n:nat} : Equivalence (fieldwise' n R).
  Proof. constructor; exact _. Qed.

  Global Instance Reflexive_fieldwise {R_Reflexive:Reflexive R} {n:nat} : Reflexive (fieldwise n R) | 5.
  Proof. destruct n; (repeat constructor || exact _). Qed.
  Global Instance Symmetric_fieldwise {R_Symmetric:Symmetric R} {n:nat} : Symmetric (fieldwise n R) | 5.
  Proof. destruct n; (repeat constructor || exact _). Qed.
  Global Instance Transitive_fieldwise {R_Transitive:Transitive R} {n:nat} : Transitive (fieldwise n R) | 5.
  Proof. destruct n; (repeat constructor || exact _). Qed.
  Global Instance Equivalence_fieldwise {R_equiv:Equivalence R} {n:nat} : Equivalence (fieldwise n R).
  Proof. constructor; exact _. Qed.
End Equivalence.

Arguments fieldwise' {A B n} _ _ _.
Arguments fieldwise {A B n} _ _ _.

Local Hint Extern 0 => solve [ solve_decidable_transparent ] : typeclass_instances.
Global Instance dec_fieldwise' {A RA} {HA : DecidableRel RA} {n} : DecidableRel (@fieldwise' A A n RA) | 10.
Proof.
  induction n; simpl @fieldwise'.
  { exact _. }
  { intros ??.
    exact _. }
Defined.

Global Instance dec_fieldwise {A RA} {HA : DecidableRel RA} {n} : DecidableRel (@fieldwise A A n RA) | 10.
Proof.
  destruct n; unfold fieldwise; exact _.
Defined.

Section fieldwise_map.
  Local Arguments map : simpl never.
  Lemma fieldwise'_map_eq {A A' B B' n} R (f:A -> A') (g:B -> B') (t1:tuple' A n) (t2:tuple' B n)
    : fieldwise' R (map (n:=S n) f t1) (map (n:=S n) g t2)
      = fieldwise' (fun x y => R (f x) (g y)) t1 t2.
  Proof.
    induction n; [ reflexivity | ].
    destruct t1, t2.
    rewrite !map_S.
    simpl @fieldwise'; rewrite IHn; reflexivity.
  Qed.

  Lemma fieldwise_map_eq {A A' B B' n} R (f:A -> A') (g:B -> B') (t1:tuple A n) (t2:tuple B n)
    : fieldwise R (map f t1) (map g t2)
      = fieldwise (fun x y => R (f x) (g y)) t1 t2.
  Proof.
    destruct n; [ reflexivity | apply fieldwise'_map_eq ].
  Qed.

  Lemma fieldwise'_map_iff {A A' B B' n} R (f:A -> A') (g:B -> B') (t1:tuple' A n) (t2:tuple' B n)
    : fieldwise' R (map (n:=S n) f t1) (map (n:=S n) g t2)
      <-> fieldwise' (fun x y => R (f x) (g y)) t1 t2.
  Proof. rewrite fieldwise'_map_eq; reflexivity. Qed.

  Lemma fieldwise_map_iff {A A' B B' n} R (f:A -> A') (g:B -> B') (t1:tuple A n) (t2:tuple B n)
    : fieldwise R (map f t1) (map g t2)
      <-> fieldwise (fun x y => R (f x) (g y)) t1 t2.
  Proof. rewrite fieldwise_map_eq; reflexivity. Qed.
End fieldwise_map.

Fixpoint fieldwiseb' {A B} (n:nat) (R:A->B->bool) (a:tuple' A n) (b:tuple' B n) {struct n} : bool.
  destruct n; simpl @tuple' in *.
  { exact (R a b). }
  { exact (fieldwiseb' _ _ n R (fst a) (fst b) && R (snd a) (snd b))%bool. }
Defined.

Definition fieldwiseb {A B} (n:nat) (R:A->B->bool) (a:tuple A n) (b:tuple B n) : bool.
  destruct n; simpl @tuple in *.
  { exact true. }
  { exact (fieldwiseb' _ R a b). }
Defined.

Arguments fieldwiseb' {A B n} _ _ _.
Arguments fieldwiseb {A B n} _ _ _.

Lemma fieldwiseb'_fieldwise' :forall {A B} n R Rb
                                   (a:tuple' A n) (b:tuple' B n),
  (forall a b, Rb a b = true <-> R a b) ->
  (fieldwiseb' Rb a b = true <-> fieldwise' R a b).
Proof.
  intros.
  revert n a b;
  induction n; intros; simpl @tuple' in *;
    simpl fieldwiseb'; simpl fieldwise'; auto.
  cbv beta.
  rewrite Bool.andb_true_iff.
  f_equiv; auto.
Qed.

Lemma fieldwiseb_fieldwise :forall {A B} n R Rb
                                   (a:tuple A n) (b:tuple B n),
  (forall a b, Rb a b = true <-> R a b) ->
  (fieldwiseb Rb a b = true <-> fieldwise R a b).
Proof.
  intros; destruct n; simpl @tuple in *;
    simpl @fieldwiseb; simpl @fieldwise; try tauto.
  auto using fieldwiseb'_fieldwise'.
Qed.

Fixpoint from_list_default' {T} (d y:T) (n:nat) (xs:list T) : tuple' T n :=
  match n return tuple' T n with
  | 0 => y (* ignore high digits *)
  | S n' =>
         match xs return _ with
         | cons x xs' => (from_list_default' d x n' xs', y)
         | nil => (from_list_default' d d n' nil, y)
         end
  end.

Definition from_list_default {T} d (n:nat) (xs:list T) : tuple T n :=
match n return tuple T n with
| 0 => tt
| S n' =>
    match xs return _ with
    | cons x xs' => (from_list_default' d x n' xs')
    | nil => (from_list_default' d d n' nil)
    end
end.

Lemma from_list_default'_eq : forall {T} (d : T) xs n y pf,
  from_list_default' d y n xs = from_list' y n xs pf.
Proof.
  induction xs; destruct n; intros; simpl in *;
    solve [ congruence (* 8.5 *)
          | erewrite IHxs; reflexivity ]. (* 8.4 *)
Qed.

Lemma from_list_default_eq : forall {T} (d : T) xs n pf,
  from_list_default d n xs = from_list n xs pf.
Proof.
  induction xs; destruct n; intros; try solve [simpl in *; congruence].
  apply from_list_default'_eq.
Qed.

Fixpoint function R T n : Type :=
  match n with
  | O => R
  | S n' => T -> function R T n'
  end.

Fixpoint apply' {R T} (n:nat) : (T -> function R T n) -> tuple' T n -> R :=
  match n with
  | 0 => id
  | S n' => fun f x => apply' n' (f (snd x)) (fst x)
  end.

Definition apply {R T} (n:nat) : function R T n -> tuple T n -> R :=
  match n with
  | O => fun r _ => r
  | S n' => fun f x =>  apply' n' f x
  end.

Require Import Coq.Lists.SetoidList.

Lemma fieldwise_to_list_iff : forall {T n} R (s t : tuple T n),
    (fieldwise R s t <-> Forall2 R (to_list _ s) (to_list _ t)).
Proof.
  induction n; split; intros.
  + constructor.
  + cbv [fieldwise]. auto.
  + destruct n; cbv [tuple to_list fieldwise] in *.
    - cbv [to_list']; auto.
    - simpl in *. destruct s,t; cbv [fst snd] in *.
      constructor; intuition auto.
      apply IHn; auto.
  + destruct n; cbv [tuple to_list fieldwise] in *.
    - cbv [fieldwise']; auto.
      cbv [to_list'] in *; inversion H; auto.
    - simpl in *. destruct s,t; cbv [fst snd] in *.
      inversion H; subst.
      split; try assumption.
      apply IHn; auto.
Qed.

Fixpoint eta_tuple'_dep {T n} : forall (P : tuple' T n -> Type),
    (forall ts : tuple' T n, P ts) -> forall ts : tuple' T n, P ts
  := match n with
     | 0 => fun P f => f
     | S n' => fun P f (ts : tuple' T n' * T)
               => let '(ts', x) := ts in
                  @eta_tuple'_dep T n' (fun ts' => P (ts', x)) (fun ts'' => f (ts'', x)) ts'
     end.
Definition eta_tuple' {T n B} : (tuple' T n -> B) -> (tuple' T n -> B)
  := @eta_tuple'_dep T n (fun _ => B).
Global Arguments eta_tuple' {T !n B} / _ _.
Definition eta_tuple_dep {T n} : forall (P : tuple T n -> Type),
    (forall ts : tuple T n, P ts) -> forall ts : tuple T n, P ts
  := match n with
     | 0 => fun P f => f
     | S n' => @eta_tuple'_dep T n'
     end.
Global Arguments eta_tuple_dep {T !n} P / _ _.
Definition eta_tuple {T n B} : (tuple T n -> B) -> (tuple T n -> B)
  := @eta_tuple_dep T n (fun _ => B).
Global Arguments eta_tuple {T !n B} / _ _.

Fixpoint eta_rtuple'_dep {T n} : forall (P : rtuple' T n -> Type),
    (forall ts : rtuple' T n, P ts) -> forall ts : rtuple' T n, P ts
  := match n with
     | 0 => fun P f => f
     | S n' => fun P f (ts : T * rtuple' T n')
               => let '(x, ts') := ts in
                  @eta_rtuple'_dep T n' (fun ts' => P (x, ts')) (fun ts'' => f (x, ts'')) ts'
     end.
Definition eta_rtuple' {T n B} : (rtuple' T n -> B) -> (rtuple' T n -> B)
  := @eta_rtuple'_dep T n (fun _ => B).
Global Arguments eta_rtuple' {T !n B} / _ _.
Definition eta_rtuple_dep {T n} : forall (P : rtuple T n -> Type),
    (forall ts : rtuple T n, P ts) -> forall ts : rtuple T n, P ts
  := match n with
     | 0 => fun P f => f
     | S n' => @eta_rtuple'_dep T n'
     end.
Global Arguments eta_rtuple_dep {T !n} P / _ _.
Definition eta_rtuple {T n B} : (rtuple T n -> B) -> (rtuple T n -> B)
  := @eta_rtuple_dep T n (fun _ => B).
Global Arguments eta_rtuple {T !n B} / _ _.

Lemma strip_eta_tuple'_dep {T n} P (f : forall ts : tuple' T n, P ts) ts
  : eta_tuple'_dep P f ts = f ts.
Proof.
  revert dependent P; induction n; simpl in *; [ reflexivity | intros ].
  destruct_head prod.
  rewrite IHn; reflexivity.
Qed.
Lemma strip_eta_tuple' {T n B} (f : tuple' T n -> B) ts
  : eta_tuple' f ts = f ts.
Proof. exact (strip_eta_tuple'_dep _ _ _). Qed.
Lemma strip_eta_tuple_dep {T n} P (f : forall ts : tuple T n, P ts) ts
  : eta_tuple_dep P f ts = f ts.
Proof. destruct n; [ reflexivity | exact (strip_eta_tuple'_dep _ _ _) ]. Qed.
Lemma strip_eta_tuple {T n B} (f : tuple T n -> B) ts
  : eta_tuple f ts = f ts.
Proof. exact (strip_eta_tuple_dep _ _ _). Qed.

Lemma strip_eta_rtuple'_dep {T n} P (f : forall ts : rtuple' T n, P ts) ts
  : eta_rtuple'_dep P f ts = f ts.
Proof.
  revert dependent P; induction n; simpl in *; [ reflexivity | intros ].
  destruct_head prod.
  rewrite IHn; reflexivity.
Qed.
Lemma strip_eta_rtuple' {T n B} (f : rtuple' T n -> B) ts
  : eta_rtuple' f ts = f ts.
Proof. exact (strip_eta_rtuple'_dep _ _ _). Qed.
Lemma strip_eta_rtuple_dep {T n} P (f : forall ts : rtuple T n, P ts) ts
  : eta_rtuple_dep P f ts = f ts.
Proof. destruct n; [ reflexivity | exact (strip_eta_rtuple'_dep _ _ _) ]. Qed.
Lemma strip_eta_rtuple {T n B} (f : rtuple T n -> B) ts
  : eta_rtuple f ts = f ts.
Proof. exact (strip_eta_rtuple_dep _ _ _). Qed.

Definition append {A n} (a : A) : tuple A n -> tuple A (S n) :=
  match n as n0 return (tuple A n0 -> tuple A (S n0)) with
  | O => fun t => a
  | S n' => fun t => (t,a)
  end.

Lemma hd_append {A n} (x: tuple A n) (a:A) : hd (append a x) = a.
Proof. destruct n; reflexivity. Qed.

Lemma tl_append {A n} (x: tuple A n) (a:A) : tl (append a x) = x.
Proof. destruct n; try destruct x; reflexivity. Qed.

Lemma from_list'_cons {A n} (a0 a1:A) (xs:list A) H :
  from_list' a0 (S n) (a1::xs) H = append (n:=S n) a0 (from_list' a1 n xs (length_cons_full _ _ _ H)).
Proof. simpl; rewrite <-!from_list_default'_eq with (d:=a0); eauto. Qed.

Lemma from_list_cons {A n}:
  forall (xs : list A) a (H:length (a::xs)=S n),
  from_list (S n) (a :: xs) H = append a (from_list n xs (length_cons_full _ _ _ H)).
Proof.
  destruct n; intros; destruct xs; distr_length; [reflexivity|].
  cbv [from_list]; rewrite !from_list'_cons.
  rewrite <-!from_list_default'_eq with (d:=a).
  reflexivity.
Qed.

Lemma map_append' {A B n} (f:A->B) : forall (x:tuple' A n) (a:A),
  map f (append (n:=S n) a x) = append (f a) (map (n:=S n) f x).
Proof.
  reflexivity.
Qed.

Lemma map_append {A B n} (f:A->B) : forall (x:tuple A n) (a:A),
  map f (append a x) = append (f a) (map f x).
Proof. destruct n; auto using map_append'. Qed.

(* map operation that carries state *)
(* first argument to f is index in tuple *)
Fixpoint mapi_with' {T A B n} i (f: nat->T->A->T*B) (start:T)
  : tuple' A n -> T * tuple' B n :=
  match n as n0 return (tuple' A n0 -> T * tuple' B n0) with
  | O => fun ys => f i start ys
  | S n' => fun ys =>
              (fst (mapi_with' (S i) f (fst (f i start (hd ys))) (tl ys)),
               (snd (mapi_with' (S i) f (fst (f i start (hd ys))) (tl ys)),
               snd (f i start (hd ys))))
  end.

Fixpoint mapi_with {T A B n} (f: nat->T->A->T*B) (start:T)
  : tuple A n -> T * tuple B n :=
  match n as n0 return (tuple A n0 -> T * tuple B n0) with
  | O => fun ys => (start, tt)
  | S n' => fun ys => mapi_with' 0 f start ys
  end.

Lemma mapi_with'_invariant {T A B} (f: nat->T->A->T*B)
      (P : forall n, nat -> T -> T -> tuple A n -> tuple B n -> Prop)
      (P_holds : forall n i starter rem inp out,
          P n (S i) (fst (f i starter (hd inp))) rem (tl inp) out
          -> P (S n) i starter rem inp (append (snd (f i starter (hd inp))) out))
      (P_base : forall i rem, P 0%nat i rem rem tt tt)
  :
  forall {n} i (start : T) (input : tuple A (S n)),
    P (S n) i start (fst (mapi_with' i f start input)) input (snd (mapi_with' i f start input)).
Proof.
  induction n; intros.
  { specialize (P_holds 0%nat i start (fst (f i start input)) input tt).
    apply P_holds. apply P_base. }
  { specialize (P_holds (S n) i start (fst (mapi_with' i f start input)) input).
    apply P_holds. apply IHn. }
Qed.

Lemma mapi_with_invariant {T A B} (f: nat->T->A->T*B)
      (P : forall n, nat -> T -> T -> tuple A n -> tuple B n -> Prop)
      (P_holds : forall n i starter rem inp out,
          P n (S i) (fst (f i starter (hd inp))) rem (tl inp) out
          -> P (S n) i starter rem inp (append (snd (f i starter (hd inp))) out))
      (P_base : forall i rem, P 0%nat i rem rem tt tt)
  :
  forall {n} (start : T) (input : tuple A n),
    P n 0%nat start (fst (mapi_with f start input)) input (snd (mapi_with f start input)).
Proof.
  destruct n; [intros; destruct input; apply P_base|];
    apply mapi_with'_invariant; auto.
Qed.

Fixpoint repeat {A} (a:A) n : tuple A n :=
  match n with
  | O => tt
  | S n' => append a (repeat a n')
  end.

Lemma map_repeat {A B} (f:A->B) (a: A) n :
  map f (repeat a n) = repeat (f a) n.
Proof.
  induction n; simpl repeat; [reflexivity|rewrite map_append; congruence].
Qed.

Lemma to_list_repeat {A} (a:A) n : to_list _ (repeat a n) = List.repeat a n.
Proof. induction n; [reflexivity|destruct n; simpl in *; congruence]. Qed.

Require Import Crypto.Util.ListUtil. (* To initialize [distr_length] database *)
Hint Rewrite length_to_list' @length_to_list : distr_length.


(* QuickChick Prelude *)
Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

Require Import String List. Open Scope string.

From QuickChick Require Import QuickChick Tactics.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.
Import QcDefaultNotation. Open Scope qc_scope.

Set Bullet Behavior "Strict Subproofs".

(* End prelude *)

Inductive day : Type :=
  | monday : day
  | tuesday : day
  | wednesday : day
  | thursday : day
  | friday : day
  | saturday : day
  | sunday : day.

Derive (Arbitrary, Show) for day.
Derive (Sized, CanonicalSized) for day.
Derive SizeMonotonic for day using genSday.
Derive SizedMonotonic for day.
Derive SizedCorrect for day using genSday and SizeMonotonicday.

Definition next_weekday (d:day) : day :=
  match d with
  | monday    => tuesday
  | tuesday   => wednesday
  | wednesday => thursday
  | thursday  => friday
  | friday    => monday
  | saturday  => monday
  | sunday    => monday
  end.

Module BoolPlayground.
Inductive bool : Type :=
  | true : bool
  | false : bool.

Derive (Arbitrary, Show) for bool.
Derive (Sized, CanonicalSized) for bool.
Derive SizeMonotonic for bool using genSbool.
Derive SizedMonotonic for bool.
Derive SizedCorrect for bool using genSbool and SizeMonotonicbool.

Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition orb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.
End BoolPlayground.

Module NatPlayground.

(* Note: nat already exists *)
(*
Inductive nat : Type :=
  | O : nat
  | S : nat -> nat.
*)

Derive (Arbitrary, Show) for nat.
Derive (Sized, CanonicalSized) for nat.
(* XXX these do not work because there's already an instance for nat. *)
(*
Derive SizeMonotonic for nat using genSnat.
Derive SizedMonotonic for nat.
Derive SizedCorrect for nat using genSnat and SizeMonotonicnat.
*)

Inductive nat' : Type :=
  | stop : nat'
  | tick : nat' -> nat'.

(* Not sure why this works but the above doesn't. If it's nat-specific I don't really care *)
(* Yes it was nat specific. It breaks because there are two instances for nat -- one of them handwritten. *)
Derive (Arbitrary, Show) for nat'.
Derive (Sized, CanonicalSized) for nat'.
Derive SizeMonotonic for nat' using genSnat'.
Derive SizedMonotonic for nat'.
Derive SizedCorrect for nat' using genSnat' and SizeMonotonicnat'.

(** The second branch can be read: "if [n] has the form [S n']
    for some [n'], then return [n']."  *)

End NatPlayground.

Definition pred (n : nat) : nat :=
  match n with
    | O => O
    | S n' => n'
  end.

Definition minustwo (n : nat) : nat :=
  match n with
    | O => O
    | S O => O
    | S (S n') => n'
  end.

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

Definition oddb (n:nat) : bool   :=   negb (evenb n).

Module NatPlayground2.

Fixpoint plus (n : nat) (m : nat) : nat :=
  match n with
    | O => m
    | S n' => S (plus n' m)
  end.

Fixpoint mult (n m : nat) : nat :=
  match n with
    | O => O
    | S n' => plus m (mult n' m)
  end.

Fixpoint minus (n m:nat) : nat :=
  match n, m with
  | O   , _    => O
  | S _ , O    => n
  | S n', S m' => minus n' m'
  end.

End NatPlayground2.

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

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

Theorem plus_O_n : forall n : nat, 0 + n = n.
Admitted. (* QuickChick plus_O_n. *)

Theorem plus_O_n' : forall n : nat, 0 + n = n.
Admitted. (* QuickChick plus_O_n'. *)

Theorem plus_1_l : forall n:nat, 1 + n = S n.
Admitted. (* QuickChick plus_1_l. *)

Theorem mult_0_l : forall n:nat, 0 * n = 0.
Admitted. (* QuickChick mult_0_l. *)

Theorem plus_0_example: forall n, n = 17 -> n = 42.
Admitted. (* QuickChick plus_0_example. *)

Conjecture plus_id_example : forall n m : nat, n = m -> n + n = m + 0.
QuickChick plus_id_example.

(*
Derive ArbitrarySizedSuchThat for (fun x => eq x a).

QuickChickDebug Debug On.

Derive SizeMonotonicSuchThatOpt for (fun x => eq x a).

Derive SizedProofEqs for (fun x => eq x a).
Proof.
refine (fun x => conj
   (fun Hin =>
    match Hin with
    | ex_intro s Hc =>
        match Hc with
        | conj Hl Hin =>
            nat_ind
              (fun n =>
               forall x (input0_ : A),
               Basics.impl
                 ((let
                     fix aux_iter size0 (input0_ : A) :=
                       match size0 with
                       | O => setU (set1 input0_) set0
                       | S size' => setU (set1 input0_) set0
                       end in
                   aux_iter n input0_) x) ((@eq A) x input0_))
              (fun x (input0_ : A) hin =>
               match hin with
               | or_introl Hr0 => _ (* eq_ind _ _ (eq_refl _) _ Hr0*)
               | or_intror Hl0 => False_ind _ Hl0
               end)
              (fun size0 IHs x (input0_ : A) hin =>
               match hin with
               | or_introl Hr1 => _ (* eq_ind _ _ (eq_refl _) _ Hr1 *)
               | or_intror Hl1 => False_ind _ Hl1
               end)
              s x input0_ Hin

        end
    end)
   _).
- inversion Hr0; auto.
- inversion Hr1; auto.
- intros H; symmetry in H; move: H.
  apply eq_ind.
  eapply (ex_intro input0_).
Defined.
Defined.
  admit.
Admitted.

  refine ((fun x' => ex_intro _ _) _).
  refine (ex_intro _).
  refine (eq_ind
      (fun _gen (input0_ : A) =>
       bigcup setT
         (fun n =>
          let
            fix aux_iter size0 (input0_ : A) :=
              match size0 with
              | O => setU (set1 input0_) set0
              | S size' => setU (set1 input0_) set0
              end in
          aux_iter n input0_) _gen)
      _ x input0_).
      (fun x => ex_intro _ (Coq.Init.Datatypes.S 0) (conj I (or_introl (Logic.eq_refl _)))) x
      input0_).

Definition s A (input0_ : A) :=
(fun x =>
 conj
   (fun Hin =>
    match Hin with
    | ex_intro s Hc =>
        match Hc with
        | conj Hl Hin =>
            nat_ind
              (fun n =>
               forall x (input0_ : A),
               Basics.impl
                 ((let
                     fix aux_iter size0 (input0_ : A) :=
                       match size0 with
                       | O => setU (set1 input0_) set0
                       | S size' => setU (set1 input0_) set0
                       end in
                   aux_iter n input0_) x) ((@eq A) x input0_))
              (fun x (input0_ : A) hin =>
               match hin with
               | or_introl Hr0 => eq_ind _ _ (eq_refl _) _ Hr0
               | or_intror Hl0 => False_ind _ Hl0
               end)
              (fun size0 IHs x (input0_ : A) hin =>
               match hin with
               | or_introl Hr1 => eq_ind _ _ (eq_refl _) _ Hr1
               | or_intror Hl1 => False_ind _ Hl1
               end) s x input0_ Hin
        end
    end)
   (eq_ind
      (fun _gen (input0_ : A) =>
       bigcup setT
         (fun n =>
          let
            fix aux_iter size0 (input0_ : A) :=
              match size0 with
              | O => setU (set1 input0_) set0
              | S size' => setU (set1 input0_) set0
              end in
          aux_iter n input0_) _gen)
      (fun x => ex_intro _ (Coq.Init.Datatypes.S 0) (conj I (or_introl (Logic.eq_refl _)))) x
      input0_)).

(* TODO: Replace these with derived versions *)
(*

QuickChickDebug Debug On.

Derive GenSizedSuchThatCorrect for (fun eq => eq x a).

Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => goodFooUnif n foo).
*)
*)

Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Admitted.  QuickChick plus_id_exercise.

Theorem mult_0_plus : forall n m : nat,
  (0 + n) * m = n * m. Admitted. (* QuickChick mult_0_plus. *)

Theorem mult_S_1 : forall n m : nat,
  m = S n ->
  m * (1 + n) = m * m.
Admitted. (* QuickChick mult_S_1. *)

Theorem plus_1_neq_0_firsttry : forall n : nat,
  beq_nat (n + 1) 0 = false.
Admitted. (* QuickChick plus_1_neq_0_firsttry. *)

Theorem negb_involutive : forall b : bool,
  negb (negb b) = b. Admitted. (* QuickChick negb_involutive. *)

Theorem andb_commutative : forall b c, andb b c = andb c b.
Admitted. (* QuickChick andb_commutative. *)

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Admitted. (* Leo: OUT-OF-SCOPE *)

Theorem zero_nbeq_plus_1 : forall n : nat,
  beq_nat 0 (n + 1) = false.
Admitted. (* QuickChick zero_nbeq_plus_1 *)

Theorem identity_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = x) ->
  forall (b : bool), f (f b) = b.
Admitted. (* Leo: FUNCTION *)

Theorem andb_eq_orb :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
Admitted. (* Leo: OUT-OF-SCOPE *)


Require Import general.
Require Import list_facts.
Require Import lterms.

Section Red.

Variable R : lterm -> lterm -> Prop.
Variable R_refl : forall x, R x x.
Variable R_trans : forall x y z, R x y -> R y z -> R x z.
Variable R_cong_ltup_0 : forall x x' y l, R x x' -> R (ltup x y l) (ltup x' y l).
Variable R_cong_ltup_1 : forall x y y' l, R y y' -> R (ltup x y l) (ltup x y' l).
Variable R_cong_ltup_2 : forall x y l1 z z' l2, R z z' -> R (ltup x y (l1 ++ z :: l2))
                                                            (ltup x y (l1 ++ z' :: l2)).

Lemma lem_red_ltup_closure_0 :
  forall l l', list_closure R l l' ->
               forall x y l0, R (ltup x y (l0 ++ l)) (ltup x y (l0 ++ l')).
Proof.
  induction l, l'; yisolve.
  intro H.
  yinversion H.
  intros.
  assert (R (ltup x y ((l1 ++ a :: nil) ++ l)) (ltup x y ((l1 ++ a :: nil) ++ l'))).
  ycrush.
  assert (HH: forall q q', (q ++ a :: nil) ++ q' = q ++ a :: q').
  induction q.
  simpl; auto with datatypes.
  simpl; intro.
  assert ((q ++ a :: nil) ++ q' = q ++ a :: q') by ycrush.
  ycrush.
  assert (R (ltup x y (l1 ++ a :: l)) (ltup x y (l1 ++ a :: l'))).
  ycrush.
  ycrush.
Qed.

Lemma lem_red_ltup_closure :
  forall x y x' y' l l', R x x' -> R y y' -> list_closure R l l' ->
                                 R (ltup x y l) (ltup x' y' l').
Proof.
  intros.
  assert (R (ltup x y (nil ++ l)) (ltup x y (nil ++ l'))).
  pose lem_red_ltup_closure_0; ycrush.
  ycrush.
Qed.

Lemma lem_red_list_closure :
  forall P l, (forall t, In t l -> exists t', R t t' /\ P t') ->
              exists l', list_closure R l l' /\ forall t, In t l' -> P t.
Proof.
  intros.
  assert (forall t, exists t', In t l -> R t t' /\ P t').
  intro t.
  assert (In t l \/ not (In t l)) by auto using classic.
  ycrush.
  assert (exists f, forall t, In t l -> R t (f t) /\ P (f t)).
  pose (choice (fun x y => In x l -> R x y /\ P y)); ycrush.
  simp_hyps.
  rename x into f.
  exists (map f l).
  clear H H0.
  induction l.
  ycrush.
  simpl in *; split; pose_lc; ycrush.
Qed.

Lemma lem_red_ltup_in :
  forall P x y l,
    (forall t, In t l -> exists t', R t t' /\ P t') ->
    exists l', R (ltup x y l) (ltup x y l') /\ forall t, In t l' -> P t.
Proof.
  pose lem_red_ltup_closure; pose lem_red_list_closure; ycrush.
Qed.

Lemma lem_red_list_closure_2 :
  forall P l, (forall t, In t l -> exists t', R t' t /\ P t') ->
              exists l', list_closure R l' l /\ forall t, In t l' -> P t.
Proof.
  intros.
  assert (forall t, exists t', In t l -> R t' t /\ P t').
  intro t.
  assert (In t l \/ not (In t l)) by auto using classic.
  ycrush.
  assert (exists f, forall t, In t l -> R (f t) t /\ P (f t)).
  pose (choice (fun x y => In x l -> R y x /\ P y)); ycrush.
  simp_hyps.
  rename x into f.
  exists (map f l).
  clear H H0.
  induction l.
  ycrush.
  simpl in *; split; pose_lc; ycrush.
Qed.

Lemma lem_red_ltup_in_2 :
  forall P x y l,
    (forall t, In t l -> exists t', R t' t /\ P t') ->
    exists l', R (ltup x y l') (ltup x y l) /\ forall t, In t l' -> P t.
Proof.
  pose lem_red_ltup_closure; pose lem_red_list_closure_2; ycrush.
Qed.

End Red.


Require Export Contexts.
Require Import List.
Import ListNotations.

Inductive Circuit (w : WType) : Set :=
| output : Pat w -> Circuit w
| gate   : forall {w1 w2},
           Gate w1 w2 ->  Pat w1 -> (Pat w2 -> Circuit w) -> Circuit w
| lift   : Pat Bit -> (bool -> Circuit w) -> Circuit w.

Inductive Box w1 w2 : Set := box : (Pat w1 -> Circuit w2) -> Box w1 w2.
Arguments output {w}.
Arguments gate {w w1 w2}.
Arguments lift {w}.
Arguments box {w1 w2}.

Definition Square_Box W := Box W W.

Definition unbox {w1 w2} (b : Box w1 w2)  (p : Pat w1) : Circuit w2 :=
  match b with box c => c p end.

(* TODO: Rename since Coq defines `compose` now. *)
Fixpoint compose {w1 w2} (c : Circuit w1) (f : Pat w1 -> Circuit w2) : Circuit w2 :=
  match c with
  | output p     => f p
  | gate g p c'  => gate g p (fun p' => compose (c' p') f)
  | lift p c'    => lift p (fun bs => compose (c' bs) f)
  end.

(* Typed Circuits and Boxes *)

Reserved Notation "Γ ⊢ c :Circ" (at level 30).
Reserved Notation "Γ ⊢ f :Fun"  (at level 30).

Inductive Types_Circuit : OCtx -> forall {w}, Circuit w -> Set :=
| types_output : forall {Γ Γ' w} {p : Pat w} {pf : Γ = Γ'},
  Γ ⊢ p :Pat -> Γ' ⊢ output p :Circ
| types_gate : forall {Γ Γ1 Γ1' w1 w2 w} {f : Pat w2 -> Circuit w}
                                         {p1 : Pat w1} {g : Gate w1 w2} ,
               Γ1 ⊢ p1 :Pat ->
(*               Γ ⊢ f :Fun ->*)
               (forall Γ2 Γ2' (p2 : Pat w2) {pf2 : Γ2' == Γ2 ∙ Γ},
                       Γ2 ⊢ p2 :Pat -> Γ2' ⊢ f p2 :Circ) ->
               forall {pf1 : Γ1' == Γ1 ∙ Γ},
               Γ1' ⊢ gate g p1 f :Circ
| types_lift : forall {Γ1 Γ2 Γ w } {p : Pat Bit} {f : bool -> Circuit w},
               Γ1 ⊢ p :Pat ->
               (forall b, Γ2 ⊢ f b :Circ) ->
               forall {pf : Γ == Γ1 ∙ Γ2},
               Γ ⊢ lift p f :Circ
where "Γ ⊢ c :Circ" := (Types_Circuit Γ c)
and "Γ ⊢ f :Fun" := (forall Γ0 Γ0' p0, Γ0' == Γ0 ∙ Γ ->
                                            Γ0 ⊢ p0 :Pat ->
                                            Γ0' ⊢ f p0 :Circ ).

(* Notation "Γ ⊢_Q c : w" := (@Types_Circuit Γ w c) (at level 30). *)
(* Notation "Γ ⇒_Q p : w" := (@Types_Pat Γ w p) (at level 30). *)

(*
| types_lift_qubit : forall {Γ1 Γ2 p Γ w f} {v : is_valid Γ} {m : Γ = Γ1 ⋓ Γ2},
                     Types_Pat Γ1 p Qubit ->
                     (forall b, Types_Circuit Γ2 (f b) w) ->
                     Types_Circuit Γ (lift p f) w.
*)
(*
Notation "Γ ⊢ c :Circ" := (Types_Circuit Γ c) (at level 30).
Notation "Γ ⊢ f :Fun" := (forall Γ0 Γ0' p0, Γ0' == Γ0 ∙ Γ ->
                                            Γ0 ⊢ p0 :Pat ->
                                            Γ0' ⊢ f p0 :Circ ) (at level 30).
*)

Print Types_Circuit.

Definition Typed_Box {W1 W2 : WType} (b : Box W1 W2) : Set :=
  forall Γ (p : Pat W1), Γ ⊢ p :Pat -> Γ ⊢ unbox b p :Circ.

(* Prevent compute from unfolding important fixpoints *)
Opaque merge.
Opaque Ctx.
Opaque is_valid.

(* Composition lemma *)

Lemma compose_typing : forall Γ1 Γ1' Γ W W' (c : Circuit W) (f : Pat W -> Circuit W'),
        Γ1 ⊢ c :Circ ->
        Γ ⊢ f :Fun ->
        forall {pf : Γ1' == Γ1 ∙ Γ},
        Γ1' ⊢ compose c f :Circ.
Proof.
  do 7 intro. intros types_c.
  generalize dependent Γ1'.
  generalize dependent Γ.
  dependent induction types_c; intros Γ0 Γ01' types_f pf0.
  * simpl. subst. eapply types_f; eauto.
  * simpl.
    eapply @types_gate with (Γ1 := Γ1) (Γ := Γ ⋓ Γ0); auto; try solve_merge.
    intros.
    apply H with (Γ2 := Γ2) (Γ := Γ0) (Γ2' := Γ2 ⋓ Γ); auto; solve_merge.
  * simpl.
    apply @types_lift with (Γ1 := Γ1) (Γ2 := Γ2 ⋓ Γ0); auto; try solve_merge.
    intros. apply H with (Γ := Γ0); auto; solve_merge.
Qed.

Lemma unbox_typing : forall Γ W1 W2 (p : Pat W1) (c : Box W1 W2),
                                    Γ ⊢ p :Pat ->
                                    Typed_Box c ->
                                    Γ ⊢ unbox c p :Circ.
Proof. unfold Typed_Box in *. auto. Qed.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal86.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Succ (Succ (Succ (Succ (Succ Zero))))).
Definition lfind_example_2  := ( Succ (Succ (Succ Zero))).
Definition lfind_example_3  := ( Succ (Succ Zero)).
Definition lfind_example_4  := ( Succ Zero).
Definition lfind_example_5  := ( Zero).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal86_plus_commut_63_plus_zero/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 .