(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require map.Map.

(* Why3 goal *)
Definition occ: forall {a:Type} {a_WT:WhyType a}, a -> (map.Map.map Z a) ->
  Z -> Z -> Z.
Proof.
intros a a_WT v m l u.
induction (Z.to_nat (u-l)) as [|delta occ_].
exact Z0.
exact ((if why_decidable_eq (map.Map.get m (l + Z_of_nat delta)%Z) v then 1 else 0) + occ_)%Z.
Defined.

Lemma occ_equation :
  forall {a:Type} {a_WT:WhyType a} v m l u,
  (l < u)%Z ->
  occ v m l u =
  ((if why_decidable_eq (map.Map.get m (u - 1)%Z) v then 1 else 0) + occ v m l (u - 1))%Z.
Proof.
intros a a_WT v m l u Hlu.
assert (0 < u - l)%Z as h1' by omega.
unfold occ.
replace (u - 1 - l)%Z with (u - l - 1)%Z by ring.
replace (u - 1)%Z with (l + (u - l - 1))%Z by ring.
rewrite <- (Z2Nat.id (u - l - 1)) by omega.
rewrite (Z2Nat.inj_sub _ 1) by easy.
destruct (u - l)%Z ; try easy.
simpl.
assert (exists n, Pos.to_nat p = S n) as [n ->].
  exists (Z.to_nat (Zpred (Zpos p))).
  rewrite Z2Nat.inj_pred.
  apply (S_pred _ O).
  apply Pos2Nat.is_pos.
simpl.
now rewrite <- minus_n_O, Nat2Z.id.
Qed.

(* Why3 goal *)
Lemma occ_empty :
forall {a:Type} {a_WT:WhyType a},
forall (v:a) (m:(map.Map.map Z a)) (l:Z) (u:Z),
 (u <= l)%Z -> ((occ v m l u) = 0%Z).
Proof.
intros a a_WT v m l u h1.
assert (u - l <= 0)%Z as h1' by omega.
unfold occ.
destruct (u - l)%Z ; try reflexivity.
now elim h1'.
Qed.

(* Why3 goal *)
Lemma occ_right_no_add :
forall {a:Type} {a_WT:WhyType a},
forall (v:a) (m:(map.Map.map Z a)) (l:Z) (u:Z),
 (l < u)%Z ->
 ((~ ((map.Map.get m (u - 1%Z)%Z) = v)) ->
  ((occ v m l u) = (occ v m l (u - 1%Z)%Z))).
Proof.
intros a a_WT v m l u h1 h2.
rewrite occ_equation with (1 := h1).
now destruct why_decidable_eq as [H|H].
Qed.

(* Why3 goal *)
Lemma occ_right_add :
forall {a:Type} {a_WT:WhyType a},
forall (v:a) (m:(map.Map.map Z a)) (l:Z) (u:Z),
 (l < u)%Z ->
 (((map.Map.get m (u - 1%Z)%Z) = v) ->
  ((occ v m l u) = (1%Z + (occ v m l (u - 1%Z)%Z))%Z)).
Proof.
intros a a_WT v m l u h1 h2.
rewrite occ_equation with (1 := h1).
now destruct why_decidable_eq as [H|H].
Qed.

(* Why3 goal *)
Lemma occ_bounds :
forall {a:Type} {a_WT:WhyType a},
forall (v:a) (m:(map.Map.map Z a)) (l:Z) (u:Z),
 (l <= u)%Z -> ((0%Z <= (occ v m l u))%Z /\ ((occ v m l u) <= (u - l)%Z)%Z).
Proof.
intros a a_WT v m l u h1.
cut (0 <= u - l)%Z. 2: omega.
replace (occ v m l u) with (occ v m l (l + (u - l)))%Z.
pattern (u - l)%Z; apply Z_lt_induction. 2: omega.
intros.
assert (h: (x = 0 \/ x <> 0)%Z) by omega. destruct h.
now rewrite occ_empty; omega.
destruct (why_decidable_eq (Map.get m (l + (x-1))%Z) v).
rewrite occ_right_add.
generalize (H (x-1)%Z); clear H; intros.
assert (0 <= occ v m l (l + (x - 1)) <= x-1)%Z.
apply H; omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring.
omega.
omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring.
trivial.
rewrite occ_right_no_add.
assert (0 <= occ v m l (l + (x - 1)) <= x-1)%Z.
apply H; omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring.
omega.
omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring.
trivial.
replace (l + (u-l))%Z with u by ring. trivial.
Qed.

(* Why3 goal *)
Lemma occ_append :
forall {a:Type} {a_WT:WhyType a},
forall (v:a) (m:(map.Map.map Z a)) (l:Z) (mid:Z) (u:Z),
 ((l <= mid)%Z /\ (mid <= u)%Z) ->
 ((occ v m l u) = ((occ v m l mid) + (occ v m mid u))%Z).
Proof.
intros a a_WT v m l mid u (h1,h2).
cut (0 <= u - mid)%Z. 2: omega.
replace (occ v m l u) with (occ v m l (mid + (u - mid)))%Z.
replace (occ v m mid u) with (occ v m mid (mid + (u - mid)))%Z.
pattern (u - mid)%Z; apply Z_lt_induction. 2: omega.
intros.
assert (h: (x = 0 \/ x <> 0)%Z) by omega. destruct h.
rewrite (occ_empty _ _ mid (mid+x)%Z).
subst x. ring_simplify ((mid+0)%Z). ring.
omega.
destruct (why_decidable_eq (Map.get m (mid + (x-1))%Z) v).
rewrite (occ_right_add _ _ l (mid+x))%Z.
rewrite (occ_right_add _ _ mid (mid+x))%Z.
generalize (H (x-1)%Z); clear H; intros.
assert ((occ v m l (mid+(x-1)) = (occ v m l mid) + occ v m mid (mid + (x - 1)))%Z).
apply H; omega.
replace (mid + x - 1)%Z with (mid+(x-1))%Z by ring.
omega. omega.
trivial.
replace (mid + x - 1)%Z with (mid+(x-1))%Z by ring. trivial.
omega.
replace (mid + x - 1)%Z with (mid+(x-1))%Z by ring. trivial.

rewrite (occ_right_no_add _ _ l (mid+x))%Z.
rewrite (occ_right_no_add _ _ mid (mid+x))%Z.
generalize (H (x-1)%Z); clear H; intros.
assert ((occ v m l (mid+(x-1)) = (occ v m l mid) + occ v m mid (mid + (x - 1)))%Z).
apply H; omega.
replace (mid + x - 1)%Z with (mid+(x-1))%Z by ring.
omega. omega.
trivial.
replace (mid + x - 1)%Z with (mid+(x-1))%Z by ring. trivial.
omega.
replace (mid + x - 1)%Z with (mid+(x-1))%Z by ring. trivial.

replace (mid + (u-mid))%Z with u by ring. trivial.
replace (mid + (u-mid))%Z with u by ring. trivial.
Qed.

(* Why3 goal *)
Lemma occ_neq :
forall {a:Type} {a_WT:WhyType a},
forall (v:a) (m:(map.Map.map Z a)) (l:Z) (u:Z),
 (forall (i:Z), ((l <= i)%Z /\ (i < u)%Z) -> ~ ((map.Map.get m i) = v)) ->
 ((occ v m l u) = 0%Z).
Proof.
intros a a_WT v m l u.
assert (h: (u < l \/ 0 <= u - l)%Z) by omega. destruct h.
rewrite occ_empty. trivial. omega.
replace u with (l + (u - l))%Z. 2:ring.
generalize H.
pattern (u - l)%Z; apply Z_lt_induction. 2: omega.
clear H; intros.
assert (h: (x = 0 \/ x <> 0)%Z) by omega. destruct h.
now rewrite occ_empty; omega.
destruct (why_decidable_eq (Map.get m (l + (x-1))%Z) v).
assert (Map.get m (l + (x - 1)) <> v)%Z.
  apply H1; omega.
intuition.
rewrite occ_right_no_add.
replace (l+x-1)%Z with (l+(x-1))%Z by ring.
apply H; intuition.
apply (H1 i). omega. assumption.
omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring.
trivial.
Qed.

(* Why3 goal *)
Lemma occ_exists :
forall {a:Type} {a_WT:WhyType a},
forall (v:a) (m:(map.Map.map Z a)) (l:Z) (u:Z),
 (0%Z < (occ v m l u))%Z ->
 exists i:Z, ((l <= i)%Z /\ (i < u)%Z) /\ ((map.Map.get m i) = v).
Proof.
intros a a_WT v m l u h1.
assert (h: (u < l \/ 0 <= u - l)%Z) by omega. destruct h.
rewrite occ_empty in h1. elimtype False; omega. omega.
generalize h1.
replace u with (l + (u - l))%Z. 2:ring.
generalize H.
pattern (u - l)%Z; apply Z_lt_induction. 2: omega.
clear H; intros.
assert (h: (x = 0 \/ x <> 0)%Z) by omega. destruct h.
rewrite occ_empty in h0. elimtype False; omega. omega.
destruct (why_decidable_eq (Map.get m (l + (x-1))%Z) v).
exists (l+(x-1))%Z. split. omega. now trivial.
destruct (H (x-1))%Z as (i,(hi1,hi2)). omega. omega.
rewrite occ_right_no_add in h0.
replace (l + (x - 1))%Z with (l+x-1)%Z by ring. trivial.
omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring. trivial.
exists i. split. omega. assumption.
Qed.

(* Why3 goal *)
Lemma occ_pos :
forall {a:Type} {a_WT:WhyType a},
forall (m:(map.Map.map Z a)) (l:Z) (u:Z) (i:Z),
 ((l <= i)%Z /\ (i < u)%Z) -> (0%Z < (occ (map.Map.get m i) m l u))%Z.
Proof.
intros a a_WT m l u i (h1,h2).
pose (v := (Map.get m i)). fold v.
assert (occ v m l u = occ v m l i + occ v m i u)%Z.
  apply occ_append. omega.
assert (occ v m i u = occ v m i (i+1) + occ v m (i+1) u)%Z.
  apply occ_append. omega.
assert (occ v m i (i + 1) = 1)%Z.
rewrite occ_right_add.
  ring_simplify (i+1-1)%Z. rewrite occ_empty. ring. omega. omega.
ring_simplify (i+1-1)%Z. auto.
assert (0 <= occ v m l i <= i -l)%Z. apply occ_bounds. omega.
assert (0 <= occ v m i (i+1) <= (i+1)-i)%Z. apply occ_bounds. omega.
assert (0 <= occ v m (i+1) u <= u - (i+1))%Z. apply occ_bounds. omega.
omega.
Qed.

(* Why3 goal *)
Lemma occ_eq :
forall {a:Type} {a_WT:WhyType a},
forall (v:a) (m1:(map.Map.map Z a)) (m2:(map.Map.map Z a)) (l:Z) (u:Z),
 (forall (i:Z),
   ((l <= i)%Z /\ (i < u)%Z) -> ((map.Map.get m1 i) = (map.Map.get m2 i))) ->
 ((occ v m1 l u) = (occ v m2 l u)).
Proof.
intros a a_WT v m1 m2 l u h1.
assert (h: (u < l \/ 0 <= u - l)%Z) by omega. destruct h.
rewrite occ_empty.
rewrite occ_empty. trivial.
omega. omega.
generalize h1.
replace u with (l + (u - l))%Z. 2:ring.
generalize H.
pattern (u - l)%Z; apply Z_lt_induction. 2: omega.
clear H; intros.
assert (h: (x = 0 \/ x <> 0)%Z) by omega. destruct h.
rewrite occ_empty. rewrite occ_empty. trivial. omega. omega.
destruct (why_decidable_eq (Map.get m1 (l + (x-1))%Z) v).
rewrite occ_right_add.
rewrite (occ_right_add v m2).
apply f_equal.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring.
apply H. omega. omega. intros. apply h0. omega. omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring.
rewrite <- h0. trivial. omega. omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring. assumption.

rewrite occ_right_no_add.
rewrite (occ_right_no_add v m2).
replace (l + x - 1)%Z with (l+(x-1))%Z by ring.
apply H. omega. omega. intros. apply h0. omega. omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring.
rewrite <- h0. trivial. omega. omega.
replace (l + x - 1)%Z with (l+(x-1))%Z by ring. assumption.
Qed.


From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
Require Export Coq.Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Lists.List.
Import ListNotations.

Definition eqb_string ( x y : string) : bool :=
  if string_dec x y then true else false.

Theorem eqb_string_refl : forall s : string, true= eqb_string s s.
Proof.
  intros s.  unfold eqb_string. destruct (string_dec s s) as [| Hs].
  - reflexivity.
  - destruct Hs. reflexivity.
Qed.

Theorem eqb_string_true_iff : forall x y : string,
    eqb_string x y = true <-> x = y.
Proof.
  intros x y. split.
  - unfold eqb_string. destruct (string_dec x y) as [|] eqn:E.
    + intros H. apply e.
    + intros H. inversion H.
  - intros H. rewrite H. symmetry. apply eqb_string_refl.
Qed.

Theorem eqb_string_false_iff : forall x y : string,
    eqb_string x y = false <-> x <> y.
Proof.
  intros x y. rewrite <- eqb_string_true_iff.
  rewrite not_true_iff_false. reflexivity.
Qed.

Theorem eqb_string_false_iff' : forall x y : string,
    eqb_string x y = false <-> x <> y.
Proof.
  intros x y. split.
  - intros H. destruct (string_dec x y) as [|] eqn:E.
    + rewrite e in H. rewrite <- eqb_string_refl in H. inversion H.
    + apply n.
  - intros H. unfold eqb_string.
    destruct (string_dec x y) as [|] eqn:E.
    + rewrite e in H. destruct H. reflexivity.
    + reflexivity.
Qed.

Theorem false_eqb_string : forall x y : string,
    x <> y -> eqb_string x y = false.
Proof.
  intros x y.
  rewrite (eqb_string_false_iff x y).
  congruence.
Qed.

Definition total_map (A:Type) := string -> A.

Definition t_empty {A:Type} (v :A) : total_map A :=
  (fun _ => v).

Definition t_update {A:Type} (m : total_map A) (x : string) (v :A) :=
  fun x' => if eqb_string x x' then v else m x'.

Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true) "bar" true.

Notation "'_' '!->' v" := (t_empty v)
                            (at level 100, right associativity).

Example example_empty := (_ !-> false).
Notation "x '!->' v ';' m" := (t_update m x v)
                                (at level 100, v at next level, right associativity).

Definition examplemap' :=
  ( "bar" !-> true ;
      "foo" !-> true;
      _ !-> false).

Lemma t_apply_empty : forall (A:Type) (x:string) (v:A),
    (_ !-> v)  x = v.
Proof.
  intros A x v. unfold t_empty. reflexivity.
Qed.

Lemma t_update_eq : forall (A:Type) (m: total_map A) x v,
    (x !-> v ; m) x= v.
Proof.
  intros. unfold t_update. rewrite <- eqb_string_refl. reflexivity.
Qed.

Theorem t_update_neq: forall (A:Type) (m:total_map A) x1 x2 v,
    x1 <> x2 -> (x1 !-> v ; m) x2 = m x2.
Proof.
  intros A m x1 x2 v H.
  unfold t_update.  rewrite <- eqb_string_false_iff in H. rewrite H. reflexivity.
Qed.

Lemma t_update_shadow : forall (A: Type) (m:total_map A) x v1 v2,
    (x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
Proof.
  intros. apply functional_extensionality. intros x0.
  unfold t_update. destruct (eqb_string x x0) as [|] eqn:E.
  - reflexivity.
  - reflexivity.
Qed.

Lemma eqb_stringP : forall x y :string,
    reflect (x = y) (eqb_string x y).
Proof.
  intros. apply iff_reflect.  rewrite eqb_string_true_iff.
  reflexivity.
Qed.

Theorem t_update_same : forall (A:Type) (m :total_map A) x,
    (x !-> m x ; m) = m.
Proof.
  intros. apply functional_extensionality. intros x0. unfold t_update.
  destruct (eqb_stringP x x0).
  - congruence.
  - reflexivity.
Qed.

Theorem t_update_permute : forall (A:Type) (m:total_map A) v1 v2 x1 x2,
    x2<> x1 -> (x1 !-> v1 ; x2 !-> v2 ; m)
               = (x2 !-> v2 ; x1 !-> v1 ; m).
Proof.
  intros. apply functional_extensionality. intros x.  unfold t_update.
  destruct (eqb_stringP x1 x).
  destruct (eqb_stringP x2 x).
  subst x2 x1. destruct H. reflexivity.
  reflexivity.
  destruct (eqb_stringP x2 x).
  reflexivity. reflexivity.
Qed.

Definition partial_map (A: Type) := total_map (option A).
Definition empty {A:Type} : partial_map A := t_empty None.
Definition update {A:Type} (m : partial_map A) (x : string) (v :A) :=
  (x !-> Some v ; m).

Notation "x '|->' v ';' m" := (update m x v)
                                (at level 100, v at next level, right associativity).

Notation "x '|->' v" := (update empty x v) (at level 100).
Example examplepmap := ("Church" |-> true ; "Turing" |-> false).

Lemma apply_empty : forall (A:Type) (x :string),
    @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty. reflexivity.
Qed.

Lemma update_eq : forall (A:Type) (m:partial_map A) x v,
    (x |-> v ; m) x = Some v.
Proof.
  intros. unfold update. apply t_update_eq.
Qed.

Lemma update_neq: forall (A:Type) (m:partial_map A) x1 x2 v,
    x2 <> x1 -> (x2 |-> v ;m) x1 = m x1.
Proof.
  intros. unfold update. apply t_update_neq. apply H. Qed.

Lemma update_shadow : forall (A:Type) (m:partial_map A) x v1 v2,
    (x |-> v2 ; x |-> v1 ; m) = (x |-> v2; m).
Proof.
  intros.
  unfold update. apply t_update_shadow. Qed.

Theorem update_same : forall (A:Type) (m:partial_map A) x v,
    m x = Some v -> (x |-> v ; m) = m.
Proof.
  intros. unfold update. rewrite <- H. apply t_update_same. Qed.

Theorem update_permute : forall (A:Type) (m: partial_map A) x1 x2 v1 v2,
    x2 <> x1 -> (x1 |-> v1 ; x2 |-> v2 ; m) = (x2 |-> v2 ; x1 |-> v1 ; m).
Proof.
  intros. unfold update.
  apply t_update_permute. apply H. Qed.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
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.

Require Import Circom.Default.

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

(* left associative by default *)
Fixpoint tuple (T: Type) n : Type :=
  match n with
  | O => unit
  | S n' => tuple T n' * T
  end.

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

Fixpoint rsnoc T n {struct n} : rtuple T n -> T -> rtuple T (S n) :=
  match n return rtuple T n -> T -> rtuple T (S n) with
  | O => fun x y => (y, x)
  | 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} : T -> tuple T n -> tuple T (S n) :=
  match n return T -> tuple T n -> tuple T (S n) with
  | O => fun y x => (x, y)
  | 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
  | O => 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.

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 tl {T n} : tuple T (S n) -> tuple T n := @fst _ _.
Definition hd {T n} : tuple T (S n) -> T.
Proof. intros t. destruct t. trivial. Defined.

Section ToFromList.

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

Program Fixpoint 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 _ => tt
    | _ => _ (* impossible *)
    end
  | S n' =>
    match xs return (length xs = S n' -> tuple T (S n')) with
    | List.cons x xs' => fun _ => (from_list n' xs' _, x)
    | _ => _ (* impossible *)
    end
  end.

Definition from_list' {T} (xs: list T) : tuple T (length xs).
Proof. induction xs; simpl. exact tt. auto. Defined.

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 as [|t 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) = n.
Proof using Type. induction n; simpl in *; trivial; destruct t; simpl; congruence. Qed.

Lemma from_list_to_list : forall {T n} (xs:tuple T n) pf, from_list n (to_list n xs) pf = xs.
Proof using Type.
  induction n as [|n]; auto; intros xs pf.
  simpl in *. destruct xs. auto.
  simpl. destruct xs. simpl in *. rewrite IHn. reflexivity.
Qed.

End ToFromList.

Fixpoint repeat {T} (x: T) (n: nat) : tuple T n :=
  match n with
  | O => tt
  | S n' => cons x (repeat x n')
  end.

Fixpoint nth_default {T n} (d: T) (i: nat) : tuple T n -> T :=
  match n with
  | O => fun _ => d
  | S n' => fun '(xs',x) =>
    match i with
    | O => x
    | S i' => nth_default d i' xs'
    end
  end.

Definition nth {n T} i (xs: tuple T n) d := nth_default d i xs.

Lemma nth_default_to_list {A} n (xs : tuple A n) (d : A) :
  forall i, List.nth_default d (to_list n xs) i = @nth_default A n d i xs.
Proof using Type.
  revert xs; induction n, i; cbn; break_match; intros;
    rewrite ?ListUtil.nth_default_cons_S; try reflexivity; rewrite ?IHn; eauto using ListUtil.nth_default_nil.
Qed.

Lemma nth_default_oblivious: forall {A n} (xs: tuple A n) (i: nat) (d1 d2: A),
  i < n ->
  nth_default d1 i xs = nth_default d2 i xs.
Proof.
  induction n; simpl; intros. lia.
  destruct xs; destruct i. auto. apply IHn. lia.
Qed.

Definition nth_Default {T n} `{Default T} i (xs: tuple T n) := nth i xs default.

Lemma nth_Default_nth_default {T n} `{H: Default T}: forall i (xs: tuple T n),
  nth_Default i xs = nth_default default i xs.
Proof.
  induction n; intros; firstorder || destruct i; firstorder.
Qed.

Lemma nth_Default_to_list {A} `{Default A} n (xs : tuple A n) (d: A):
  forall i, i < n ->
    List.nth_default d (to_list n xs) i = nth_Default i xs.
Proof using Type.
  intros. unfold nth_Default, nth. erewrite nth_default_oblivious.
  apply nth_default_to_list. lia.
Qed.

Section tforall.

  Context {T: Type} (P: T -> Prop).

  Fixpoint tforall {n} : tuple T n -> Prop :=
    match n return tuple T n -> Prop with
    | O => fun _ => True
    | S n' => fun '(xs',x) => P x /\ tforall xs'
    end.

  Lemma tforall_Forall: forall n (xs: tuple T n), tforall xs <-> List.Forall P (to_list n xs).
  Proof.
    induction n; simpl; split; intros; auto;
    destruct xs as [x xs].
    - constructor; firstorder.
    - invert H. firstorder.
  Qed.

  Lemma tforall_inv : forall n (xs: tuple T n) x, @tforall (S n) (xs, x) -> P x.
  Proof. firstorder. Qed.

  Theorem tforall_inv_tail : forall n (xs: tuple T n) x, @tforall (S n) (xs, x) -> @tforall n xs.
  Proof. firstorder. Qed.

  Lemma tforall_nth_default: forall n (xs: tuple T n),
    tforall xs <-> forall i d, i < n -> P (nth_default d i xs).
  Proof.
    split; induction n; simpl; intros; auto; try lia;
    destruct xs as [x xs].
    - destruct i. firstorder. apply IHn. firstorder. lia.
    - firstorder. specialize (H 0). apply H. auto. lia.
      apply IHn. intros. specialize (H (S i)). apply H. lia.
  Qed.

  Lemma tforall_nth_Default `{H: Default T}: forall n (xs: tuple T n),
    tforall xs <-> forall i, i < n -> P (nth_Default i xs).
  Proof.
    intros. unfold nth_Default, nth. split; intros.
    apply tforall_nth_default; auto.
    apply tforall_nth_default. intros.
    erewrite nth_default_oblivious.
    eauto. lia.
  Qed.

End tforall.

Lemma firstn_to_list {T}: forall m (x: tuple T m),
  firstn m (to_list m x) = to_list m x.
Proof.
  intros. apply firstn_all2. rewrite length_to_list; lia.
Qed.

Fixpoint map {n A B} (f:A -> B) : tuple A n -> tuple B n
  := match n return tuple A n -> tuple B n with
     | 0 => fun _ => tt
     | S n' => fun '(xs,x) => (map f xs, f x)
     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.

Fixpoint fold_right {A B: Type} (n:nat) (f: A -> B -> B) (b0: B) : tuple A n -> B :=
  match n return tuple A n -> B with
  | O => fun _ => b0
  | S n' => fun '(aa,a) => fold_right n' f (f a b0) aa
  end.

(*

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 using Type. 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.

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

Definition 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 using Type.
  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 using Type.
  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 using Type.
  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 using Type.
  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 using Type.
  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 using Type.
  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 using Type.
  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 using Type.
  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 using Type.
  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 using Type.
  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 using Type. 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 using Type.
  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 using Type.
  tuple_maps_to_list_maps.
  let lxs := match goal with lxs : list _ |- _ => lxs end in
  destruct lxs as [|x' lxs']; [simpl in *; discriminate|].
  let x0 := match goal with H : _ = _ |- _ => H end in
  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 using Type.
  tuple_maps_to_list_maps.
  let lxs := match goal with lxs : list A |- _ => lxs end in
  destruct lxs as [|x' lxs']; [simpl in *; discriminate|].
  let lys := match goal with lxs : list B |- _ => lxs end in
  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 using Type.
  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 using Type.
  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 using Type. 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 using Type.
  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 using Type.
  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 using Type. Equivalence_fieldwise'_t. Qed.
  Global Instance Symmetric_fieldwise' {R_Symmetric:Symmetric R} {n:nat} : Symmetric (fieldwise' n R) | 5.
  Proof using Type. Equivalence_fieldwise'_t. Qed.
  Global Instance Transitive_fieldwise' {R_Transitive:Transitive R} {n:nat} : Transitive (fieldwise' n R) | 5.
  Proof using Type. Equivalence_fieldwise'_t. Qed.
  Global Instance Equivalence_fieldwise' {R_equiv:Equivalence R} {n:nat} : Equivalence (fieldwise' n R).
  Proof using Type. constructor; exact _. Qed.

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

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

Global Instance dec_fieldwise' {A B R} {H : forall a b, Decidable (R a b)} : forall {n}, DecidableRel (@fieldwise' A B n R) | 10.
Proof.
  induction n; simpl @fieldwise'.
  { exact _. }
  { intros ??.
    exact _. }
Defined.

Global Instance dec_fieldwise {A B R} {H : forall a b, Decidable (R a b)} : forall {n}, DecidableRel (@fieldwise A B n R) | 10.
Proof.
  destruct n; unfold fieldwise; exact _.
Defined.

Global Instance dec_eq' {A} {HA : DecidableRel (@eq A)} : forall {n}, DecidableRel (@eq (tuple' A n)) | 10.
Proof.
  induction n; typeclasses eauto.
Defined.

Global Instance dec_eq {A} {HA : DecidableRel (@eq A)} : forall {n}, DecidableRel (@eq (tuple A n)) | 10.
Proof.
  destruct n; typeclasses eauto.
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 using Type.
    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 using Type.
    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 using Type. 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 using Type. rewrite fieldwise_map_eq; reflexivity. Qed.
End fieldwise_map.

Lemma fieldwise'_eq_iff {A n} x y : fieldwise' (@eq A) x y <-> @eq (tuple' A n) x y.
Proof using Type.
  induction n as [|n IHn]; [ reflexivity | ].
  simpl; rewrite IHn; split; [ destruct x, y | ]; simpl; intuition (subst; auto).
Qed.

Lemma fieldwise_eq_iff {A n} x y : fieldwise (@eq A) x y <-> @eq (tuple A n) x y.
Proof using Type.
  destruct n; [ destruct x, y | apply fieldwise'_eq_iff ]; simpl.
  tauto.
Qed.

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 using Type.
  intros A B n R Rb a b H.
  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 using Type.
  intros A B n R Rb a b H; destruct n; simpl @tuple in *;
    simpl @fieldwiseb; simpl @fieldwise; try tauto.
  auto using fieldwiseb'_fieldwise'.
Qed.

Lemma map_ext {A B} (f g : A -> B) n (t : tuple A n) :
  (forall x : A, f x = g x) ->
  map f t = map g t.
Proof using Type.
  destruct n; [reflexivity|]; cbn in *.
  induction n; cbn in *; intro H; auto; [ ].
  rewrite IHn by assumption.
  rewrite H; reflexivity.
Qed.

Lemma map_ext_In {A B} (f g : A -> B) n (t : tuple A n) :
  (forall x, In x (to_list n t) -> f x = g x) ->
  map f t = map g t.
Proof using Type.
  destruct n; [reflexivity|]; cbn in *.
  induction n; cbn in *; intro H; auto; [ ].
  destruct t.
  rewrite IHn by auto using in_cons.
  rewrite H; auto using in_eq.
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 using Type.
  induction xs as [|?? IHxs]; 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 using Type.
  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.

Lemma fieldwise_to_list_iff : forall {T T' n} R (s : tuple T n) (t : tuple T' n),
    (fieldwise R s t <-> Forall2 R (to_list _ s) (to_list _ t)).
Proof using Type.
  induction n as [|n IHn]; intros R s t; 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.

Lemma fieldwise_map_from_list_iff
      {T0 T T'} R ls {n} pf1 pf2 (f : T0 -> T) (g : T0 -> T')
  : ((fieldwise R (map f (from_list n ls pf1))
                (map g (from_list n ls pf2)))
     <-> List.Forall (fun x => R (f x) (g x)) ls).
Proof using Type.
  split; intro H; revert H; revert dependent n;
    (induction ls as [|x xs IHxs]; intro n; [ | specialize (IHxs (pred n)) ]);
    destruct n as [|[|n]]; try destruct xs; simpl in *; auto;
      try congruence; intros; destruct_head'_and; eauto.
  { inversion H; auto. }
  { inversion H; 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 using Type.
  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 using Type. 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 using Type. 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 using Type. 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 using Type.
  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 using Type. 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 using Type. 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 using Type. 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 using Type. destruct n; reflexivity. Qed.

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

Lemma subst_append {A n} (x : tuple A (S n)) : x = append (hd x) (tl x).
Proof using Type. destruct n; try destruct x; reflexivity. Qed.

Lemma to_list_append {A n} (x : tuple A n) (a : A) :
  to_list (S n) (append a x) = a :: to_list n x.
Proof using Type. 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 using Type. 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 using Type.
  destruct n; intros xs a H; 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 using Type. 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 using Type. destruct n; auto using map_append'. Qed.

Lemma map2_append n A B C f xs ys x y :
  @map2 (S n) A B C f (append x xs) (append y ys)
  = append (f x y) (map2 f xs ys).
Proof using Type. destruct n; [reflexivity|]. apply map2_S'. Qed.

Fixpoint nth_default {A m} (d:A) n : tuple A m -> A :=
  match m, n with
  | O, _ => fun _ => d
  | S m', O => hd
  | S m', S n' => fun x => nth_default d n' (tl x)
  end.

Fixpoint left_tl {T n} : tuple T (S n) -> tuple T n :=
  match n with
  | O => fun _ => tt
  | S n' => fun xs => append (hd xs) (left_tl (tl xs))
  end.

Fixpoint left_hd {T n} : tuple T (S n) -> T :=
  match n with
  | O => fun x => x
  | S n' => fun xs => left_hd (tl xs)
  end.

Fixpoint left_append {T n} (x : T) : tuple T n -> tuple T (S n) :=
  match n with
  | O => fun _ => x
  | S n' => fun xs => append (hd xs) (left_append x (tl xs))
  end.

Lemma left_append_left_hd {T n} (xs : tuple T n) x :
  left_hd (left_append x xs) = x.
Proof using Type. induction n; [reflexivity | apply IHn]. Qed.

Lemma left_append_left_tl {T n} (xs : tuple T n) x :
  left_tl (left_append x xs) = xs.
Proof using Type.
  induction n; [destruct xs; reflexivity|].
  simpl. rewrite IHn.
  symmetry; apply subst_append.
Qed.

Lemma left_append_append {T n} (xs : tuple T n) r l :
  left_append l (append r xs) = append r (left_append l xs).
Proof using Type. destruct n; reflexivity. Qed.

Lemma left_tl_append {T n} (xs : tuple T (S n)) x:
  left_tl (append x xs) = append x (left_tl xs).
Proof using Type. reflexivity. Qed.

Lemma left_hd_append {T n} (xs : tuple T (S n)) x:
  left_hd (append x xs) = left_hd xs.
Proof using Type. reflexivity. Qed.

Lemma tl_left_append {T n} (xs : tuple T (S n)) x :
  tl (left_append x xs) = left_append x (tl xs).
Proof using Type. destruct n; reflexivity. Qed.

Lemma hd_left_append {T n} (xs : tuple T (S n)) x :
  hd (left_append x xs) = hd xs.
Proof using Type. destruct n; reflexivity. Qed.

Lemma map'_left_append {A B n} f xs x0 :
    @map' A B f (S n) (left_append (n:=S n) x0 xs)
    = left_append (n:=S n) (f x0) (map' f xs).
Proof using Type.
    induction n; try reflexivity.
    transitivity (map' f (tl (left_append x0 xs)), f (hd (left_append x0 xs))); [reflexivity|].
    rewrite tl_left_append, IHn. reflexivity.
Qed.

Lemma map_left_append {A B n} f xs x0 :
  @map (S n) A B f (left_append x0 xs)
  = left_append (f x0) (map f xs).
Proof using Type.
  destruct n; [ destruct xs; reflexivity| apply map'_left_append].
Qed.

Lemma subst_left_append {T n} (xs : tuple T (S n)) :
  xs = left_append (left_hd xs) (left_tl xs).
Proof using Type.
  induction n; [reflexivity|].
  simpl tuple in *; destruct xs as [xs x0].
  simpl; rewrite hd_append, tl_append.
  rewrite <-IHn; reflexivity.
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.

Definition 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'_step {T A B n} i f start inp :
  @mapi_with' T A B (S n) i f start inp =
  (fst (mapi_with' (S i) f (fst (f i start (hd inp))) (tl inp)),
   (snd (mapi_with'(S i) f (fst (f i start (hd inp))) (tl inp)), snd (f i start (hd inp)))).
Proof using Type. reflexivity. Qed.

Lemma mapi_with'_left_step {T A B n} f a0:
  forall i start (xs : tuple' A n),
    @mapi_with' T A B (S n) i f start (left_append (n:=S n) a0 xs)
    = (fst (f (i + S n)%nat (fst (mapi_with' i f start xs)) a0),
       left_append (n:=S n)
                   (snd (f (i + S n)%nat
                           (fst (mapi_with' i f start xs)) a0))
                   (snd (mapi_with' i f start xs))).
Proof using Type.
  induction n as [|? IHn]; intros; [subst; simpl; repeat f_equal; lia|].
  rewrite mapi_with'_step; autorewrite with cancel_pair.
  rewrite tl_left_append, hd_left_append.
  erewrite IHn by reflexivity; subst; autorewrite with cancel_pair.
  match goal with |- context [(?xs ,?x0)] =>
                  change (xs, x0) with (append x0 xs) end.
  rewrite <-left_append_append.
  repeat (f_equal; try lia).
Qed.

Lemma mapi_with'_linvariant {T A B n} start f
      (P : forall n, T -> tuple A n -> tuple B n -> Prop)
      (P_holds : forall n st x0 xs ys,
          (st = fst (mapi_with f start xs)) ->
          (ys = snd (mapi_with f start xs)) ->
          P n st xs ys ->
          P (S n) (fst (f n st x0))
            (left_append x0 xs)
            (left_append (snd (f n st x0)) ys))
      (P_base : P 0%nat start tt tt) (inp : tuple A n):
  P n (fst (mapi_with f start inp)) inp (snd (mapi_with f start inp)).
Proof using Type.
  induction n; [destruct inp; apply P_base |].
  rewrite (subst_left_append inp).
  cbv [mapi_with]. specialize (P_holds n).
  destruct n.
  { apply (P_holds _ inp tt tt (eq_refl _) (eq_refl _)).
    apply P_base. }
  { rewrite mapi_with'_left_step.
    autorewrite with cancel_pair natsimplify.
    apply P_holds; try apply IHn; reflexivity. }
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 using Type.
  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 using Type. induction n as [|n]; [reflexivity|destruct n; simpl in *; congruence]. Qed.

Local Ltac fieldwise_t :=
  repeat first [ progress simpl in *
               | apply conj
               | intro
               | progress subst
               | assumption
               | solve [ auto ]
               | match goal with
                 | [ H : _ * _ |- _ ] => destruct H
                 | [ H : _ /\ _ |- _ ] => destruct H
                 | [ H : _ <-> _ |- _ ] => destruct H
                 | [ H : False |- _ ] => exfalso; assumption
                 | [ H : Forall2 _ (_::_) (_::_) |- _ ] => inversion H; clear H
                 | [ |- Forall2 _ (_::_) (_::_) ] => constructor
                 | [ H : _ \/ _ |- _ ] => destruct H
                 | [ H : tuple' _ ?n, IH : forall x : tuple' _ ?n, _ |- _ ]
                   => specialize (IH H)
                 end ].
Lemma fieldwise_In_to_list_repeat_l_iff {T T' n} R (s : tuple T n) (t : T')
  : fieldwise R (repeat t n) s <-> (forall x, List.In x (to_list _ s) -> R t x).
Proof using Type.
  rewrite fieldwise_to_list_iff; destruct n as [|n]; [ | induction n ]; fieldwise_t.
Qed.
Lemma fieldwise_In_to_list_repeat_r_iff {T T' n} R (s : tuple T n) (t : T')
  : fieldwise R s (repeat t n) <-> (forall x, List.In x (to_list _ s) -> R x t).
Proof using Type.
  rewrite fieldwise_to_list_iff; destruct n as [|n]; [ | induction n ]; fieldwise_t.
Qed.

Global Instance map'_Proper : forall {n A B}, Proper (pointwise_relation _ eq ==> eq ==> eq) (fun f => @map' A B f n) | 10.
Proof using Type.
  induction n as [|n IHn]; intros.
  { compute; intros; subst; auto. }
  { cbv [pointwise_relation Proper respectful] in *.
    intros f g Hfg x y ?; subst y.
    simpl; erewrite IHn by first [ eassumption | eauto ].
    congruence. }
Qed.

Global Instance map_Proper : forall {n A B}, Proper (pointwise_relation _ eq ==> eq ==> eq) (@map n A B) | 10.
Proof using Type.
  destruct n; intros; [ | apply map'_Proper ].
  { repeat (intros [] || intro); auto. }
Qed.

Lemma fieldwise'_lift_and {n A B R1 R2} x y
  : (@fieldwise' A B n R1 x y /\ @fieldwise' A B n R2 x y)
    <-> (@fieldwise' A B n (fun a b => R1 a b /\ R2 a b) x y).
Proof using Type.
  induction n as [|n IHn]; intros.
  { compute; intros; subst; auto. }
  { simpl; rewrite <- IHn; tauto. }
Qed.

Lemma fieldwise_lift_and {n A B R1 R2} x y
  : (@fieldwise A B n R1 x y /\ @fieldwise A B n R2 x y)
    <-> (@fieldwise A B n (fun a b => R1 a b /\ R2 a b) x y).
Proof using Type.
  destruct n; [ compute; tauto | apply fieldwise'_lift_and ].
Qed.

Lemma fieldwise'_Proper_gen_dep {A B A' B'} {RA RB : _ -> _ -> Prop} {R}
       {R_Proper_and : Proper (R ==> R ==> R) and}
  : forall {n},
    forall
      (f : A -> B -> Prop)
      (g : A' -> B' -> Prop)
      (Hfg : forall a a', RA a a' -> forall b b', RB b b' -> R (f a b) (g a' b'))
      x x'
      (Hx : fieldwise' RA x x')
      y y'
      (Hy : fieldwise' RB y y'),
      R (@fieldwise' A B n f x y) (@fieldwise' A' B' n g x' y').
Proof using Type.
  induction n as [|n IHn].
  { compute; intros; subst; auto. }
  { cbv [pointwise_relation Proper respectful] in *.
    intros f g Hfg x y H x' y' H'.
    simpl in *; apply R_Proper_and; destruct H, H'; auto. }
Qed.

Lemma fieldwise_Proper_gen_dep {A B A' B'} {RA RB : _ -> _ -> Prop} {R}
      {R_Proper_and : Proper (R ==> R ==> R) and}
      (R_True : R True True)
  : forall {n},
    forall
      (f : A -> B -> Prop)
      (g : A' -> B' -> Prop)
      (Hfg : forall a a', RA a a' -> forall b b', RB b b' -> R (f a b) (g a' b'))
      x x'
      (Hx : fieldwise RA x x')
      y y'
      (Hy : fieldwise RB y y'),
      R (@fieldwise A B n f x y) (@fieldwise A' B' n g x' y').
Proof using Type.
  destruct n; intros; [ | eapply fieldwise'_Proper_gen_dep; eauto ].
  compute; trivial.
Qed.

Global Instance fieldwise'_Proper_gen {A B RA RB R}
       {R_Proper_and : Proper (R ==> R ==> R) and}
  : forall {n}, Proper ((RA ==> RB ==> R) ==> fieldwise' RA ==> fieldwise' RB ==> R) (@fieldwise' A B n) | 10.
Proof using Type.
  cbv [Proper respectful].
  eapply (@fieldwise'_Proper_gen_dep A B A B RA RB R); assumption.
Qed.

Global Instance fieldwise_Proper_gen {A B RA RB R}
       {R_Proper_and : Proper (R ==> R ==> R) and}
       (R_True : R True True)
  : forall {n}, Proper ((RA ==> RB ==> R) ==> fieldwise RA ==> fieldwise RB ==> R) (@fieldwise A B n) | 10.
Proof using Type.
  cbv [Proper respectful].
  eapply (@fieldwise_Proper_gen_dep A B A B RA RB R); assumption.
Qed.

Global Instance fieldwise'_Proper_gen_eq {A B R}
       {R_Proper_and : Proper (R ==> R ==> R) and}
  : forall {n}, Proper (pointwise_relation _ (pointwise_relation _ R) ==> eq ==> eq ==> R) (@fieldwise' A B n) | 10.
Proof using Type.
  cbv [pointwise_relation].
  repeat intro; subst; apply (@fieldwise'_Proper_gen A B eq eq); try assumption;
    repeat intro; subst; auto; reflexivity.
Qed.

Global Instance fieldwise_Proper_gen_eq {A B R}
       {R_Proper_and : Proper (R ==> R ==> R) and}
       (R_True : R True True)
  : forall {n}, Proper (pointwise_relation _ (pointwise_relation _ R) ==> eq ==> eq ==> R) (@fieldwise A B n) | 10.
Proof using Type.
  cbv [pointwise_relation].
  repeat intro; subst; apply (@fieldwise_Proper_gen A B eq eq); try assumption;
    repeat intro; subst; auto; reflexivity.
Qed.

Lemma nth_default_to_list' {A} n (xs : tuple' A n) (d : A) :
  forall i, List.nth_default d (to_list' n xs) i = @nth_default A (S n) d i xs.
Proof using Type.
  revert xs; induction n, i; cbn; break_match; intros;
    rewrite ?ListUtil.nth_default_cons_S; try reflexivity; rewrite ?IHn; eauto using ListUtil.nth_default_nil.
Qed.
Lemma nth_default_to_list {A} n (xs : tuple A n) (d : A) :
  forall i, List.nth_default d (to_list _ xs) i = nth_default d i xs.
Proof using Type.
  destruct n; cbv [Tuple.tuple Tuple.to_list] in *.
  { destruct i; reflexivity. }
  eapply nth_default_to_list'.
Qed.

Require Import Coq.Lists.SetoidList.

Global Instance fieldwise'_Proper
  : forall {n A B}, Proper (pointwise_relation _ (pointwise_relation _ impl) ==> eq ==> eq ==> impl) (@fieldwise' A B n) | 10.
Proof using Type. intros; apply fieldwise'_Proper_gen_eq. Qed.

Global Instance fieldwise_Proper
  : forall {n A B}, Proper (pointwise_relation _ (pointwise_relation _ impl) ==> eq ==> eq ==> impl) (@fieldwise A B n) | 10.
Proof using Type. intros; now apply fieldwise_Proper_gen_eq. Qed.

Global Instance fieldwise'_Proper_iff
  : forall {n A B}, Proper (pointwise_relation _ (pointwise_relation _ iff) ==> eq ==> eq ==> iff) (@fieldwise' A B n) | 10.
Proof using Type. intros; apply fieldwise'_Proper_gen_eq. Qed.

Global Instance fieldwise_Proper_iff
  : forall {n A B}, Proper (pointwise_relation _ (pointwise_relation _ iff) ==> eq ==> eq ==> iff) (@fieldwise A B n) | 10.
Proof using Type. intros; now apply fieldwise_Proper_gen_eq. Qed.

Global Instance fieldwise'_Proper_flip_impl
  : forall {n A B}, Proper (pointwise_relation _ (pointwise_relation _ (flip impl)) ==> eq ==> eq ==> flip impl) (@fieldwise' A B n) | 10.
Proof using Type. intros; apply @fieldwise'_Proper_gen_eq; compute; tauto. Qed.

Global Instance fieldwise_Proper_flip_impl
  : forall {n A B}, Proper (pointwise_relation _ (pointwise_relation _ (flip impl)) ==> eq ==> eq ==> flip impl) (@fieldwise A B n) | 10.
Proof using Type. intros; apply @fieldwise_Proper_gen_eq; compute; tauto. Qed.
 *)

(* right-assciated by default *)
(* Fixpoint tuple (T: Type) n : Type :=
  match n with
  | O => unit
  | S n' => T * tuple T n'
  end.

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

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

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

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

Fixpoint assoc_right {n T} {struct n} : ltuple T n -> tuple T n :=
  match n return ltuple T n -> tuple 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
    cons x xs
  end.

Definition tl {T n} : tuple T (S n) -> tuple T n := @snd _ _.
Definition hd {T n} : tuple T (S n) -> T.
Proof. intros t. destruct t. trivial. Defined.

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

Program Fixpoint 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 _ => tt
    | _ => _ (* impossible *)
    end
  | S n' =>
    match xs return (length xs = S n' -> tuple T (S n')) with
    | List.cons x xs' => fun _ => (x, from_list n' xs' _)
    | _ => _ (* impossible *)
    end
  end.
Definition from_list' {T} (xs: list T) : tuple T (length xs).
Proof. induction xs; simpl. exact tt. auto. Defined.
Compute (from_list' (1::2::3::nil)). *)

Declare Scope tuple_scope.
Delimit Scope tuple_scope with tuple.
Global Notation "T ^ n" := (tuple T n) : type_scope.
Global Notation "w [ i ]" := (Tuple.nth_Default i w) (at level 20) : tuple_scope.
Global Notation "' xs" := (to_list _ xs) (at level 19) : tuple_scope.

Require Import Circom.Circom.
Ltac pose_lengths :=
  repeat match goal with
    | [ _: context[?xs] |- _ ] =>
    lazymatch type of xs with
    | tuple Circom.F ?k =>
      let t := type of (length_to_list xs) in
      lazymatch goal with
      (* already posed *)
      | [ _: t |- _] => fail
      | _ =>
        let Hlen := fresh "_Hlen" in
        pose proof (length_to_list xs) as Hlen;
        move Hlen at top
      end
    | _ => fail
    end
  end.


Require Export Pig.Relations.

Definition filter (s: schema_ty) : Type := (support s) -> bool.

Definition is_filtered (s:schema_ty) (r: relation s) (f:filter s) (r': relation s) :=
  let m  := (relation_data s r) in
  let m' := (relation_data s r') in
  forall tup: (support s),
    multiplicity m tup = match (f tup) with
                         | true => multiplicity m' tup
                         | false => 0
                         end.

Inductive filtered (s: schema_ty): relation s -> filter s -> relation s -> Prop :=
  | Filtered : forall (f: filter s) (r r': relation s),
     is_filtered s r f r' ->
     filtered s r f r'.


From Domains Require Import Preamble.

Declare Scope preorder_scope.
Delimit Scope preorder_scope with P.

Open Scope preorder_scope.

HB.mixin Record PreorderOfType A :=
  {lt : A → A → Prop;
   ltR : ∀ x, lt x x;
   ltT : ∀ x y z, lt x y → lt y z → lt x z}.

HB.structure Definition Preorder := {A of PreorderOfType A}.

Lemma ltT' {A : Preorder.type} : ∀ x y z : A, lt y z → lt x y → lt x z.
Proof. by move=>???/[swap]; exact: ltT. Qed.

Infix "≤" := lt : preorder_scope.


Require Export GeoCoq.Elements.OriginalProofs.proposition_20.
Require Export GeoCoq.Elements.OriginalProofs.lemma_TGflip.
Require Export GeoCoq.Elements.OriginalProofs.lemma_TGsymmetric.
Require Export GeoCoq.Elements.OriginalProofs.proposition_22.
Require Export GeoCoq.Elements.OriginalProofs.lemma_10_12.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_Euclid4 :
   forall A B C a b c,
   Per A B C -> Per a b c ->
   CongA A B C a b c.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists D, (BetS A B D /\ Cong A B D B /\ Cong A C D C /\ neq B C)) by (conclude_def Per );destruct Tf as [D];spliter.
let Tf:=fresh in
assert (Tf:exists d, (BetS a b d /\ Cong a b d b /\ Cong a c d c /\ neq b c)) by (conclude_def Per );destruct Tf as [d];spliter.
assert (neq a b) by (forward_using lemma_betweennotequal).
assert (neq b a) by (conclude lemma_inequalitysymmetric).
assert (neq A B) by (forward_using lemma_betweennotequal).
assert (neq B A) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists p, (Out b a p /\ Cong b p B A)) by (conclude lemma_layoff);destruct Tf as [p];spliter.
let Tf:=fresh in
assert (Tf:exists q, (Out b c q /\ Cong b q B C)) by (conclude lemma_layoff);destruct Tf as [q];spliter.
assert (Per a b q) by (conclude lemma_8_3).
assert (Per q b a) by (conclude lemma_8_2).
assert (Per q b p) by (conclude lemma_8_3).
assert (Per p b q) by (conclude lemma_8_2).
let Tf:=fresh in
assert (Tf:exists r, (BetS p b r /\ Cong p b r b /\ Cong p q r q /\ neq b q)) by (conclude_def Per );destruct Tf as [r];spliter.
assert (Cong q p q r) by (forward_using lemma_congruenceflip).
assert (nCol p b q) by (conclude lemma_rightangleNC).
assert (~ Col b q p).
 {
 intro.
 assert (Col p b q) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (~ Col q p b).
 {
 intro.
 assert (Col p b q) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (Triangle p b q) by (conclude_def Triangle ).
assert (Triangle b q p) by (conclude_def Triangle ).
assert (Triangle q p b) by (conclude_def Triangle ).
assert (TG b p p q b q) by (conclude proposition_20).
assert (TG q b b p q p) by (conclude proposition_20).
assert (TG p q q b p b) by (conclude proposition_20).
assert (TG b q b p q p) by (forward_using lemma_TGflip).
assert (TG b q b p p q) by (forward_using lemma_TGflip).
assert (TG q b p q p b) by (conclude lemma_TGsymmetric).
assert (TG b q p q p b) by (forward_using lemma_TGflip).
assert (TG b q p q b p) by (forward_using lemma_TGflip).
assert (TG b p p q q b) by (forward_using lemma_TGflip).
let Tf:=fresh in
assert (Tf:exists E F, (Cong B E b p /\ Cong B F b q /\ Cong E F p q /\ Out B A E /\ Triangle B E F)) by (conclude proposition_22);destruct Tf as [E[F]];spliter.
assert (BetS D B A) by (conclude axiom_betweennesssymmetry).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (Out B A A) by (conclude lemma_ray4).
assert (Cong B E B A) by (conclude lemma_congruencetransitive).
assert (eq E A) by (conclude lemma_layoffunique).
assert (Cong B A b p) by (conclude cn_equalitysub).
assert (Cong A F p q) by (conclude cn_equalitysub).
assert (~ eq p b).
 {
 intro.
 assert (Col p b q) by (conclude_def Col ).
 assert (nCol p b q) by (conclude lemma_rightangleNC).
 contradict.
 }
assert (Cong r b p b) by (conclude lemma_congruencesymmetric).
assert (Cong b r p b) by (forward_using lemma_congruenceflip).
assert (Cong b p B E) by (conclude lemma_congruencesymmetric).
assert (neq b p) by (conclude lemma_inequalitysymmetric).
assert (Cong B A A B) by (conclude cn_equalityreverse).
assert (Cong p b b r) by (conclude lemma_congruencesymmetric).
assert (Cong p q r q) by (conclude lemma_rightreverse).
assert (Cong p b A B) by (forward_using lemma_doublereverse).
assert (Cong b r p b) by (conclude lemma_congruencesymmetric).
assert (Cong b r A B) by (conclude lemma_congruencetransitive).
assert (Cong A B B D) by (forward_using lemma_congruenceflip).
assert (Cong b r B D) by (conclude lemma_congruencetransitive).
assert (Cong b q B F) by (conclude lemma_congruencesymmetric).
assert (Cong p q A F) by (conclude lemma_congruencesymmetric).
assert (Cong q r F D) by (conclude axiom_5_line).
assert (Cong A F r q) by (conclude lemma_congruencetransitive).
assert (Cong A F q r) by (forward_using lemma_congruenceflip).
assert (Cong A F F D) by (conclude lemma_congruencetransitive).
assert (Cong A F D F) by (forward_using lemma_congruenceflip).
assert (neq b q) by (conclude_def Per ).
assert (Cong q b b q) by (conclude cn_equalityreverse).
assert (Cong q b B F) by (conclude lemma_congruencetransitive).
assert (neq B F) by (conclude axiom_nocollapse).
assert (Per A B F) by (conclude_def Per ).
assert (Cong b q B F) by (conclude lemma_congruencesymmetric).
assert (Cong B C b q) by (conclude lemma_congruencesymmetric).
assert (Cong B C B F) by (conclude lemma_congruencetransitive).
assert (Cong A C A F) by (conclude lemma_10_12).
assert (eq F F) by (conclude cn_equalityreflexive).
assert (eq C C) by (conclude cn_equalityreflexive).
assert (Out B F F) by (conclude lemma_ray4).
assert (Out B C C) by (conclude lemma_ray4).
assert (Out B A A) by (conclude lemma_ray4).
assert (Cong B A B A) by (conclude cn_congruencereflexive).
assert (nCol A B C) by (conclude lemma_rightangleNC).
assert (CongA A B C A B F) by (conclude_def CongA ).
assert (CongA A B C A B C) by (conclude lemma_equalanglesreflexive).
assert (CongA A B C A B F) by (conclude lemma_equalanglestransitive).
assert (eq p p) by (conclude cn_equalityreflexive).
assert (eq q q) by (conclude cn_equalityreflexive).
assert (Out b p p) by (conclude lemma_ray4).
assert (Out b q q) by (conclude lemma_ray4).
assert (Out B F F) by (conclude lemma_ray4).
assert (Out B A A) by (conclude lemma_ray4).
assert (Cong B A b p) by (conclude lemma_congruencesymmetric).
assert (Cong B A p b) by (forward_using lemma_congruenceflip).
assert (nCol A B F) by (conclude lemma_rightangleNC).
assert (CongA A B F p b q) by (conclude_def CongA ).
assert (CongA A B C p b q) by (conclude lemma_equalanglestransitive).
assert (nCol a b c) by (conclude lemma_rightangleNC).
assert (Out b p p) by (conclude lemma_ray4).
assert (Out b q q) by (conclude lemma_ray4).
assert (Cong b p b p) by (conclude cn_congruencereflexive).
assert (Cong b q b q) by (conclude cn_congruencereflexive).
assert (Cong p q p q) by (conclude cn_congruencereflexive).
assert (CongA a b c p b q) by (conclude_def CongA ).
assert (CongA p b q a b c) by (conclude lemma_equalanglessymmetric).
assert (CongA A B C a b c) by (conclude lemma_equalanglestransitive).
close.
Qed.

End Euclid.


Load "Example9".

(***************************************************************)

Theorem Example10_M: forall (x  F z : message), [msg x] ~ [msg (const F z )] ->    x # (const F z) .
 Proof.
intros.
simpl in H.
unfold const in H.
unfold const.
apply FUNCApp_const with (a := [msg F])(ml1 := ([msg x]))(ml2 := [msg F]) in H.

unfold const in H.
unfold app_mylist in H.

apply FUNCApp_EQ_M with (p1 := 1) (p2:=2) in H.
simpl in H.
 unfold EQ_M_at_pos in H.
unfold chkmsg_os in H. unfold getelt_at_pos in H.
simpl in H.
unfold app_mylist in H.
restr_proj_in 1 H.
restr_proj_in 1 H.

assert (J:[bol (EQ_M F F) ] ~[bol TRue]) .
assert(K: (EQI_msg F F)).
reflexivity.
apply K.
assert (K:[bol (EQ_M x F)] ~[bol TRue]) .
apply EQI_trans with (ml2 := [bol (EQ_M F F)]).
assumption. assumption. assumption.

Qed.

(*************x~f -> x=f******************************************************)

Theorem Example10_B: forall (x  F z : Bool), [bol x] ~ [bol (const F z )] ->  x ## (const F  z) .
 Proof.

intros.
simpl in H.
unfold const in H.
unfold const.
apply FUNCApp_const with (a := [bol F])(ml1 := ([bol x]))(ml2 := [bol F]) in H.
unfold const in H.
simpl in H.
pose proof (FUNCApp_EQ_B).
apply FUNCApp_EQ_B with ( p1:=1)(p2:=2) in H.

unfold app_mylist in H.
unfold EQ_B_at_pos in H.
simpl in H.
restr_proj_in 1 H.
restr_proj_in 1 H.

assert (J:[bol (EQ_B F F) ] ~[bol TRue]) .
assert(K: (EQI_bol F F)).
reflexivity.

apply K.
assert (K:[bol (EQ_B x F)] ~[bol TRue]) .
apply EQI_trans with (ml2 := [bol (EQ_B F F)]).
apply H.
apply J.
apply K.
Qed.


Require Import FP.CoreClasses.

Import CoreClassesNotation.

Class GTimes T := { gtimes : T -> T -> T }.
Class GUnit T := { gunit : T }.
Class GDiv T := { gdiv : T -> T -> T }.
Class GInv T := { ginv : T -> T }.

Module MonoidNotation.
  Infix "**" := gtimes (at level 46, right associativity).
  Infix "//" := gdiv (at level 45, right associativity).
End MonoidNotation.
Import MonoidNotation.

Definition div_from_inv {T} (times:T -> T -> T) (inv:T -> T) (t1:T) (t2:T) : T :=
  times t1 (inv t2).

Class Semigroup T `{! Eqv T ,! GTimes T } :=
  { semigroup_associativity : forall {x y z}, (x ** y) ** z ~= x ** y ** z }.

Class CommutativeSemigroup T `{! Eqv T ,! GTimes T } :=
  { commutative_semigroup_semigroup :> Semigroup T
  ; commutative_semigroup_commutativity : forall {x y}, x ** y ~= y ** x
  }.

Class MonoidUnit T `{! Eqv T ,! GTimes T ,! GUnit T } :=
  { monoid_unit_left : forall {x}, gunit ** x ~= x
  ; monoid_unit_right : forall {x}, x ** gunit ~= x
  }.

Class Monoid T `{! Eqv T ,! GTimes T ,! GUnit T } :=
  { monoid_semigroup :> Semigroup T
  ; monoid_monoid_unit :> MonoidUnit T
  }.

Class CommutativeMonoid T `{! Eqv T ,! GTimes T ,! GUnit T } :=
  { commutative_monoid_commutative_semigroup :> CommutativeSemigroup T
  ; commutative_monoid_monoid_unit :> MonoidUnit T
  }.

Class GroupInverse T `{! Eqv T ,! GTimes T ,! GUnit T ,! GDiv T ,! GInv T } :=
  { group_inverse_left : forall {x}, ginv x ** x ~= gunit
  ; group_inverse_right : forall {x}, x ** ginv x ~= gunit
  ; group_inverse_div : forall {x}, gunit // x ~= ginv x
  }.

Class Group T `{! Eqv T ,! GTimes T ,! GUnit T ,! GDiv T ,! GInv T }:=
  { group_moniod :> Monoid T
  ; group_group_inverse :> GroupInverse T
  }.

Class AlbelianGroup T `{! Eqv T ,! GTimes T ,! GUnit T ,! GDiv T ,! GInv T } :=
  { albelian_group_commutative_monoid :> CommutativeMonoid T
  ; albelian_group_group_inverse :> GroupInverse T
  }.


Require Import init.

Require Import linear_extend.
Require Export tensor_algebra_defs.
Require Import tensor_algebra_traditional_base.
Require Import tensor_algebra_traditional_scalar.
Require Import tensor_algebra_traditional_vector.
Require Import tensor_algebra_traditional_mult.
Require Import tensor_product_universal.
Require Import tensor_power_universal.
Require Import linear_grade_sum.
Require Import module_category.
Require Import algebra_category.
Require Import category_initterm.

Require Import set.
Require Import list.
Require Import unordered_list.

(* begin hide *)
Section TensorAlgebraObjCategory.

(* end hide *)
Context {F : CRingObj} (V : ModuleObj F).

Let f := make_module_homomorphism F V (algebra_module (tensor_algebra_object V))
    (vector_to_tensor V)
    (vector_to_tensor_plus V)
    (vector_to_tensor_scalar V).

Definition tensor_to_algebra_base := make_to_algebra _ _ f.

Lemma tensor_algebra_ex_base : @initial (TO_ALGEBRA V) tensor_to_algebra_base.
Proof.
    pose (UP := cring_plus F).
    pose (UZ := cring_zero F).
    pose (UN := cring_neg F).
    pose (UPC := cring_plus_comm F).
    pose (UPZ := cring_plus_lid F).
    pose (UPN := cring_plus_linv F).
    pose (UM := cring_mult F).
    pose (UO := cring_one F).
    pose (VP := module_plus V).
    pose (VSM := module_scalar V).
    pose (TAG := tensor_grade V).
    pose (TAGM := tensor_grade_mult V).
    pose (TAP := tensor_algebra_plus V).
    pose (TAZ := tensor_algebra_zero V).
    pose (TAN := tensor_algebra_neg V).
    pose (TAPC := tensor_algebra_plus_comm V).
    pose (TAPA := tensor_algebra_plus_assoc V).
    pose (TAPZ := tensor_algebra_plus_lid V).
    pose (TAPN := tensor_algebra_plus_linv V).
    pose (TASM := tensor_algebra_scalar_mult V).
    pose (TASO := tensor_algebra_scalar_id V).
    pose (TASC := tensor_algebra_scalar_comp V).
    pose (TASL := tensor_algebra_scalar_ldist V).
    pose (TASR := tensor_algebra_scalar_rdist V).
    pose (TAM := tensor_mult_class V).
    pose (TAO := tensor_one V).
    pose (TAL := tensor_mult_ldist V).
    pose (TAR := tensor_mult_rdist V).
    unfold tensor_to_algebra_base, initial; cbn.
    intros [A g].
    pose (AP := algebra_plus A).
    pose (AZ := algebra_zero A).
    pose (AN := algebra_neg A).
    pose (APC := algebra_plus_comm A).
    pose (APA := algebra_plus_assoc A).
    pose (APZ := algebra_plus_lid A).
    pose (APN := algebra_plus_linv A).
    pose (ASM := algebra_scalar A).
    pose (ASO := algebra_scalar_id A).
    pose (ASC := algebra_scalar_comp A).
    pose (ASL := algebra_scalar_ldist A).
    pose (ASR := algebra_scalar_rdist A).
    pose (AM := algebra_mult A).
    pose (AO := algebra_one A).
    pose (AL := algebra_ldist A).
    pose (AR := algebra_rdist A).
    pose (AMA := algebra_mult_assoc A).
    pose (AML := algebra_mult_lid A).
    pose (AMR := algebra_mult_rid A).
    pose (ASML := algebra_scalar_lmult A).
    pose (ASMR := algebra_scalar_rmult A).
    unfold to_algebra_set; cbn.
    apply singleton_ex; [>split|].
    -   apply ex_set_type.
        pose (h1 n (l : list (module_V V)) (eq : list_size l = n)
            := rfold mult 1 (list_image g l)).
        assert (∀ n, ∀ l1 a b l2 eq1 eq2 eq3,
            h1 n (l1 + (a + b) ꞉ l2) eq1 =
            h1 n (l1 + a ꞉ l2) eq2 + h1 n (l1 + b ꞉ l2) eq3) as h1_plus.
        {
            intros n l1 a b l2 eq1 eq2 eq3.
            unfold h1.
            clear eq1 eq2 eq3.
            induction l1.
            -   unfold list_conc; cbn.
                do 3 rewrite list_image_add.
                rewrite (module_homo_plus _ _ g).
                apply rdist.
            -   do 3 rewrite list_conc_add.
                do 3 rewrite list_image_add.
                do 3 rewrite rfold_add.
                rewrite IHl1; clear IHl1.
                apply ldist.
        }
        assert (∀ n, ∀ l1 a v l2 eq1 eq2,
            h1 n (l1 + (a · v) ꞉ l2) eq1 =
            a · h1 n (l1 + v ꞉ l2) eq2) as h1_scalar.
        {
            intros n l1 a v l2 eq1 eq2.
            unfold h1.
            clear eq1 eq2.
            induction l1.
            -   unfold list_conc; cbn.
                do 2 rewrite list_image_add.
                rewrite (module_homo_scalar _ _ g).
                apply scalar_lmult.
            -   do 2 rewrite list_conc_add.
                do 2 rewrite list_image_add.
                do 2 rewrite rfold_add.
                rewrite IHl1; clear IHl1.
                apply scalar_rmult.
        }
        pose (h2 n := make_multilinear _ n _ (h1 n) (h1_plus n) (h1_scalar n)).
        pose (h3 n := ex_singleton (tensor_power_universal V n (h2 n))).
        cbn in h3.
        pose (h4 i v (H : of_grade i v) := [h3 i|] (ex_val H)).
        assert (∀ n, ∀ l eq li,
            h4 n (power_to_tensor V (vectors_to_power V l)) li = h1 n l eq)
            as h4_eq2.
        {
            intros n l eq li.
            unfold h4.
            unfold h3.
            pose proof [|ex_singleton (tensor_power_universal V n (h2 n))]
                as h2_eq.
            unfold multilinear_from_set in h2_eq; cbn in h2_eq.
            specialize (h2_eq _ eq).
            rewrite_ex_val a a_eq.
            subst n.
            destruct (Logic.eq_refl); cbn in h2_eq.
            apply power_to_tensor_eq in a_eq.
            subst a.
            exact h2_eq.
        }
        assert (linear_extend_plus_base h4) as h_plus_base.
        {
            intros u v i H1 H2.
            unfold h4.
            pose proof (of_grade_plus u v i H1 H2) as H3.
            rewrite (proof_irrelevance _ H3).
            unfold ex_val.
            destruct (ex_to_type _) as [uv' uv_eq]; cbn in *.
            destruct (ex_to_type _) as [u' u_eq]; cbn in *.
            destruct (ex_to_type _) as [v' v_eq]; cbn in *.
            clear H1 H2 H3.
            rewrite <- u_eq, <- v_eq in uv_eq.
            rewrite <- (power_to_tensor_plus V) in uv_eq.
            apply power_to_tensor_eq in uv_eq.
            rewrite uv_eq.
            apply module_homo_plus.
        }
        assert (linear_extend_scalar_base h4) as h_scalar_base.
        {
            intros a v i H.
            unfold h4.
            unfold ex_val.
            destruct (ex_to_type _) as [av' av_eq]; cbn in *.
            destruct (ex_to_type _) as [v' v_eq]; cbn in *.
            rewrite <- v_eq in av_eq.
            rewrite <- (power_to_tensor_scalar V) in av_eq.
            apply power_to_tensor_eq in av_eq.
            rewrite av_eq.
            apply module_homo_scalar.
        }
        pose (h := linear_extend h4).
        assert (∀ u v, h (u + v) = h u + h v) as h_plus.
        {
            apply linear_extend_plus; assumption.
        }
        assert (∀ a v, h (a · v) = a · h v) as h_scalar.
        {
            apply linear_extend_scalar; assumption.
        }
        assert (h 0 = 0) as h_zero.
        {
            rewrite <- (scalar_lanni 0).
            rewrite h_scalar.
            apply scalar_lanni.
        }
        assert (h 1 = 1) as h_one.
        {
            assert (of_grade 0 1) as o_homo.
            {
                exists 1.
                reflexivity.
            }
            unfold h.
            rewrite (linear_extend_homo h4 h_scalar_base _ _ o_homo).
            pose (o := power_to_tensor V (vectors_to_power V list_end)).
            change (one (U := tensor_algebra_base V)) with o.
            unfold o.
            cbn.
            rewrite (h4_eq2 0 list_end Logic.eq_refl).
            cbn.
            reflexivity.
        }
        assert (∀ u v, h (u * v) = h u * h v) as h_mult.
        {
            intros u v.
            rewrite (grade_decomposition_eq u).
            rewrite (grade_decomposition_eq v).
            remember (grade_decomposition u) as ul.
            remember (grade_decomposition v) as vl.
            clear u v Hequl Heqvl.
            induction ul as [|u ul] using ulist_induction.
            {
                rewrite ulist_image_end, ulist_sum_end.
                rewrite mult_lanni.
                rewrite h_zero.
                rewrite mult_lanni.
                reflexivity.
            }
            rewrite ulist_image_add, ulist_sum_add.
            rewrite rdist.
            do 2 rewrite h_plus.
            rewrite IHul; clear IHul.
            rewrite rdist.
            apply rplus; clear ul.
            induction vl as [|v vl] using ulist_induction.
            {
                rewrite ulist_image_end, ulist_sum_end.
                rewrite mult_ranni.
                rewrite h_zero.
                rewrite mult_ranni.
                reflexivity.
            }
            rewrite ulist_image_add, ulist_sum_add.
            rewrite ldist.
            do 2 rewrite h_plus.
            rewrite IHvl; clear IHvl.
            rewrite ldist.
            apply rplus; clear vl.
            destruct u as [u' [i [u u_eq]]]; cbn.
            destruct v as [v' [j [v v_eq]]]; cbn.
            subst u' v'.
            pose proof (tensor_power_sum V u) as [ul u_eq]; subst u.
            induction ul as [|u ul] using ulist_induction.
            {
                rewrite ulist_image_end, ulist_sum_end.
                rewrite single_to_grade_sum_zero.
                unfold TAZ, tensor_algebra_base in *.
                rewrite h_zero.
                do 2 rewrite mult_lanni.
                apply h_zero.
            }
            rewrite ulist_image_add, ulist_sum_add.
            rewrite single_to_grade_sum_plus.
            rewrite rdist.
            do 2 rewrite h_plus.
            rewrite rdist.
            rewrite IHul; clear IHul.
            apply rplus; clear ul.
            pose proof (tensor_power_sum V v) as [vl v_eq]; subst v.
            induction vl as [|v vl] using ulist_induction.
            {
                rewrite ulist_image_end, ulist_sum_end.
                rewrite single_to_grade_sum_zero.
                unfold TAZ, tensor_algebra_base in *.
                rewrite h_zero.
                do 2 rewrite mult_ranni.
                apply h_zero.
            }
            rewrite ulist_image_add, ulist_sum_add.
            rewrite single_to_grade_sum_plus.
            rewrite ldist.
            do 2 rewrite h_plus.
            rewrite ldist.
            rewrite IHvl; clear IHvl.
            apply rplus; clear vl.
            assert (∀ n (x : module_V (tensor_power V n)),
                of_grade n (power_to_tensor V x)) as ln.
            {
                intros n x.
                exists x.
                reflexivity.
            }
            unfold h.
            assert (∀ n x, linear_extend h4 (power_to_tensor V x) =
                h4 n (power_to_tensor V x) (ln n x)) as h4_eq.
            {
                intros n x.
                rewrite (linear_extend_homo _ h_scalar_base n _ (ln n x)).
                reflexivity.
            }
            do 2 rewrite h4_eq.
            rewrite (tensor_mult_homo _ i j _ _ (ln i [u|]) (ln j [v|])).
            rewrite power_to_tensor_tm.
            rewrite h4_eq; clear h4_eq.
            destruct u as [u [α [[ul ul_eq] u_eq]]].
            destruct v as [v [β [[vl vl_eq] v_eq]]].
            cbn in *.
            destruct ul_eq; cbn in *.
            destruct vl_eq; cbn in *.
            subst u v.
            pose (VuSM := module_scalar (tensor_power V (list_size ul))).
            pose (VvSM := module_scalar (tensor_power V (list_size vl))).
            pose (VuvSM := module_scalar (tensor_power V (list_size (ul+vl)))).
            assert (of_grade (list_size ul + list_size vl)
                (power_to_tensor V (α * β · vectors_to_power V (ul + vl))))
                as uv_grade.
            {
                rewrite power_to_tensor_scalar.
                apply of_grade_scalar.
                rewrite <- list_size_conc.
                apply ln.
            }
            rewrite (linear_extend_base_eq _ _ _ _ _ uv_grade).
            2: {
                rewrite (tensor_lscalar (tensor_power V (list_size ul))).
                rewrite (tensor_rscalar (tensor_power V (list_size ul))).
                do 2 rewrite module_homo_scalar.
                rewrite (vectors_to_power_mult V).
                do 3 rewrite (power_to_tensor_scalar V).
                rewrite scalar_comp.
                apply f_equal.
                symmetry; apply power_to_tensor_k_eq.
            }
            assert (∀ (γ : cring_U F) n l H1 H2, n = list_size l →
                h4 n (power_to_tensor V (scalar_mult (ScalarMult := module_scalar
                (tensor_power V (list_size l))) γ (vectors_to_power V l))) H1 =
                γ · h4 n (power_to_tensor V (vectors_to_power V l)) H2) as h4_eq.
            {
                intros γ n l γVl Vl l_eq.
                unfold h4.
                pose proof (ex_proof γVl) as eq1; cbn in eq1.
                pose proof (ex_proof Vl) as eq2; cbn in eq2.
                subst n.
                apply power_to_tensor_eq in eq1.
                apply power_to_tensor_eq in eq2.
                change (ex_type_val (ex_to_type γVl)) with (ex_val γVl) in eq1.
                change (ex_type_val (ex_to_type Vl)) with (ex_val Vl) in eq2.
                rewrite eq1, eq2.
                apply module_homo_scalar.
            }
            assert (∀ l, of_grade (list_size l)
                (power_to_tensor V (vectors_to_power V l))) as l_grade.
            {
                intros l.
                apply ln.
            }
            pose proof (l_grade (ul + vl)) as uvl_grade.
            rewrite (list_size_conc ul vl) in uvl_grade at 1.
            rewrite (h4_eq _ _ _ _ uvl_grade (Logic.eq_sym (list_size_conc ul vl))).
            rewrite (h4_eq _ _ _ _ (l_grade ul) Logic.eq_refl).
            rewrite (h4_eq _ _ _ _ (l_grade vl) Logic.eq_refl).
            rewrite scalar_lmult, scalar_rmult.
            rewrite scalar_comp.
            apply f_equal.
            rewrite (h4_eq2 (list_size ul + list_size vl) (ul + vl) (list_size_conc ul vl)).
            rewrite (h4_eq2 (list_size ul) ul Logic.eq_refl).
            rewrite (h4_eq2 (list_size vl) vl Logic.eq_refl).
            unfold h1; cbn.
            rewrite list_image_conc.
            clear l_grade uv_grade uvl_grade ln VuSM VvSM VuvSM.
            induction ul.
            -   cbn.
                rewrite mult_lid.
                reflexivity.
            -   rewrite list_image_add.
                rewrite list_conc_add.
                rewrite rfold_add.
                rewrite IHul.
                apply mult_assoc.
        }
        exists (make_algebra_homomorphism _ (tensor_algebra_object V) _
            h h_plus h_scalar h_mult h_one).
        cbn.
        intros v.
        assert (of_grade 1 (vector_to_tensor V v)) as v_grade.
        {
            exists (vectors_to_power V (v ꞉ list_end)).
            reflexivity.
        }
        unfold h.
        rewrite (linear_extend_homo _ h_scalar_base _ _ v_grade).
        change (vector_to_tensor V v)
            with (power_to_tensor V (vectors_to_power V (v ꞉ list_end))).
        assert (list_size (v ꞉ list_end) = 1) as eq by reflexivity.
        rewrite (h4_eq2 1 (v ꞉ list_end) eq).
        unfold h1; cbn.
        apply mult_rid.
    -   intros [f1 f1_eq] [f2 f2_eq].
        apply set_type_eq; cbn.
        apply algebra_homomorphism_eq.
        intros v.
        rewrite (grade_decomposition_eq v).
        remember (grade_decomposition v) as l.
        clear v Heql.
        induction l as [|v l] using ulist_induction.
        {
            rewrite ulist_image_end, ulist_sum_end.
            unfold TAZ.
            pose proof (algebra_homo_zero f1) as eq1.
            pose proof (algebra_homo_zero f2) as eq2.
            cbn in *.
            rewrite eq1, eq2.
            reflexivity.
        }
        rewrite ulist_image_add, ulist_sum_add.
        do 2 rewrite algebra_homo_plus.
        rewrite IHl; clear IHl.
        apply rplus; clear l.
        destruct v as [v' [n [v v_eq]]]; subst v'; cbn.
        pose proof (tensor_power_sum V v) as [l v_eq]; subst v.
        induction l as [|v l] using ulist_induction.
        {
            rewrite ulist_image_end, ulist_sum_end.
            rewrite single_to_grade_sum_zero.
            unfold TAZ.
            pose proof (algebra_homo_zero f1) as eq1.
            pose proof (algebra_homo_zero f2) as eq2.
            cbn in *.
            unfold tensor_algebra_base in *.
            rewrite eq1, eq2.
            reflexivity.
        }
        rewrite ulist_image_add, ulist_sum_add.
        rewrite single_to_grade_sum_plus.
        do 2 rewrite algebra_homo_plus.
        rewrite IHl; clear IHl.
        apply rplus; clear l.
        destruct v as [v [α [[l l_eq] v_eq]]]; cbn; subst v.
        rewrite single_to_grade_sum_scalar.
        do 2 rewrite algebra_homo_scalar.
        apply f_equal.
        cbn.
        destruct l_eq; cbn.
        induction l as [|v l].
        {
            cbn.
            assert (scalar_to_tensor V 1 = 1) as eq by reflexivity.
            unfold scalar_to_tensor in eq.
            unfold UO in eq.
            cbn in *.
            unfold zero in eq; cbn in eq.
            unfold zero; cbn.
            unfold power_to_tensor in eq.
            rewrite eq.
            do 2 rewrite algebra_homo_one.
            reflexivity.
        }
        cbn.
        assert (@power_to_tensor F V (nat_suc (list_size l)) (tensor_mult
            V (tensor_power V (list_size l)) v (vectors_to_power V l)) =
            vector_to_tensor V v * power_to_tensor V (vectors_to_power V l))
            as eq.
        {
            assert (of_grade 1 (vector_to_tensor V v)) as v_homo.
            {
                exists (vectors_to_power V (v ꞉ list_end)).
                cbn.
                unfold vector_to_tensor.
                reflexivity.
            }
            assert (of_grade (list_size l) (power_to_tensor V (vectors_to_power V l)))
                as l_homo.
            {
                exists (vectors_to_power V l).
                reflexivity.
            }
            rewrite (tensor_mult_homo _ _ _ _ _ v_homo l_homo).
            rewrite (power_to_tensor_tm V).
            change (tensor_mult V (cring_module F) v 1) with
                (vectors_to_power V (v ꞉ list_end)).
            change 1 with (list_size (v ꞉ list_end)).
            rewrite (vectors_to_power_mult V).
            rewrite <- power_to_tensor_k_eq.
            cbn.
            reflexivity.
        }
        unfold power_to_tensor in eq.
        rewrite eq; clear eq.
        do 2 rewrite algebra_homo_mult.
        apply f_equal2; [>clear IHl|exact IHl].
        rewrite f1_eq, f2_eq.
        reflexivity.
Qed.

Theorem tensor_algebra_ex : ∃ T, @initial (TO_ALGEBRA V) T.
Proof.
    exists tensor_to_algebra_base.
    exact tensor_algebra_ex_base.
Qed.

Definition to_tensor_algebra := ex_val tensor_algebra_ex.
Definition tensor_algebra := (to_algebra_algebra V) to_tensor_algebra.
Definition vector_to_tensor_homo := (to_algebra_homo V) to_tensor_algebra.
Definition vector_to_tensor := module_homo_f vector_to_tensor_homo.

Theorem tensor_algebra_universal : @initial (TO_ALGEBRA V) to_tensor_algebra.
Proof.
    apply (ex_proof tensor_algebra_ex).
Qed.

(* begin hide *)
End TensorAlgebraObjCategory.

(* end hide *)
Arguments vector_to_tensor {F V}.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List Arith Lia.

From Undecidability.Shared.Libs.DLW
  Require Import utils_tac utils_nat pos vec sss.

From Undecidability.MinskyMachines
  Require Import mm_defs.

From Undecidability.MuRec
  Require Import recalg ra_mm.

Set Implicit Arguments.

Local Notation "'⟦' f '⟧'" := (@ra_rel _ f) (at level 0).

Local Notation "P // s -+> t" := (sss_progress (@mm_sss _) P s t).
Local Notation "P // s ->> t" := (sss_compute (@mm_sss _) P s t).
Local Notation "P // s ~~> t" := (sss_output (@mm_sss _) P s t).
Local Notation "P // s ↓"     := (sss_terminates (@mm_sss _) P s).

Theorem ra_mm_simulator n (f : recalg n) :
      { m & { P : list (mm_instr (pos (n+S m))) | forall v, ex (⟦f⟧ v) <-> (1,P) // (1,vec_app v vec_zero) ↓ } }.
Proof.
  destruct (ra_mm_compiler f) as (m & P & H1 & H2).
  exists m, P; split.
  + intros (x & Hx).
    exists (1+length P,vec_app v (x##vec_zero)); split; auto.
    simpl; lia.
  + intros H; apply H2; eq goal H; do 2 f_equal.
Qed.

Corollary ra_mm_simulator_0 (f : recalg 0) :
      { m & { P : list (mm_instr (pos (S m))) | ex (⟦f⟧ vec_nil) <-> (1,P) // (1,vec_zero) ↓ } }.
Proof.
  destruct (ra_mm_simulator f) as (m & P & HP).
  exists m, P; rewrite (HP vec_nil), vec_app_nil; tauto.
Qed.


From Coq Require Import
  Bool.
From FunProofs.Lib Require Import
  Tactics.

Fact iff_not_true b P : (b = true <-> P) -> (b = false <-> ~P).
Proof. destruct b; intuition simplify. Qed.

Fact iff_not_false b P : (b = false <-> P) -> (b = true <-> ~P).
Proof. destruct b; intuition simplify. Qed.

Fact not_exist A (P : A -> Prop) : ~(exists x, P x) <-> (forall x, ~P x).
Proof. intuition (destr *; eauto). Qed.

Fact reflect_not b P : reflect P b -> reflect (~P) (negb b).
Proof.
  intros Hb%reflect_iff; apply iff_reflect.
  destruct b; cbn; intuition simplify.
Qed.