From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A C G X X0 : Universe, ((wd_ A G /\ (wd_ G C /\ (wd_ A C /\ (wd_ X0 A /\ (wd_ X0 C /\ (wd_ X G /\ (wd_ X C /\ (col_ G A X /\ (col_ X0 A C /\ col_ X G C))))))))) -> col_ A G C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj24synthconj2 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus (mult lv0 lv1) (plus lv1 lv2)) (mult lv3 (Succ Zero))).
Admitted.
QuickChick conj24synthconj2.


Require Export D.

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


Require Import Definitions Algebra.Monoid  Algebra.SetoidCat Algebra.SetoidCat.MaybeUtils Algebra.Monad.Maybe  Tactics Algebra.SetoidCat.ListUtils Algebra.Functor Algebra.Applicative Algebra.Alternative Algebra.FoldableFunctor Algebra.SetoidCat.PairUtils Algebra.Monad Algebra.Lens.Lens ListLens MaybeLens Utils SetoidUtils Algebra.SetoidCat.BoolUtils Algebra.SetoidCat.NatUtils Pointed Lista Matrixp ListaLens MatrixpLens GenUtils Algebra.Monoid.MaybeUtils.
Require Import Coq.Structures.DecidableTypeEx List  SetoidClass PeanoNat FMapWeakList Basics Coq.Init.Specif.

Module FMapNat := FMapWeakList.Make Nat_as_DT.
Module NatNat_as_DT := PairDecidableType Nat_as_DT Nat_as_DT.
Module FMapNatNat := FMapWeakList.Make NatNat_as_DT.

Definition singleton {T} (k : nat) (v : T) : FMapNat.t T :=
  FMapNat.add k v (FMapNat.empty T).

Open Scope type_scope.
Definition sqlPred := nat (* table index *) * nat (* col index *).

Instance sqlPredS : Setoid sqlPred := natS ~*~ natS.

Definition sqlType := nat (* table index *).

Instance sqlTypeS : Setoid sqlType := natS.

Definition sqlAddr := nat (* table index *) * nat (* row index *).

Instance sqlAddrS : Setoid sqlAddr := natS ~*~ natS.

(* define a list of builtin function values *)
Inductive sqlFunc :=
| sqlSuccFunc : sqlFunc
.

Instance sqlFuncS : Setoid sqlFunc :=
  {
    equiv := eq
  }
.

Inductive sqlVal :=
| vNat : nat -> sqlVal
| vAddr : sqlAddr -> sqlVal
| vNil : sqlVal
| vRow : sqlVal -> sqlVal -> sqlVal
| vFunc : sqlFunc -> sqlVal
.

Instance sqlValS : Setoid sqlVal :=
  {
    equiv := eq
  }
.

Module SQLValType <: ValType.
  Definition val := sqlVal.

  Instance valS : Setoid sqlVal := sqlValS.

  Definition storable v :=
    match v with
      | vNat _ => true
      | vAddr _ => true
      | vNil => true (* null *)
      | vRow _ _ => false
      | vFunc _ => false
    end.

  Instance storable_Proper : Proper (equiv ==> equiv) storable.
  Proof.
    solve_properS storable.
  Qed.

  Definition storableS := injF storable _.

  Definition _appVal v1 v2 :=
    match v1, v2 with
      | vFunc sqlSuccFunc, vNat n => Some (vNat (S n))
      | _, _ => None
    end
  .

  Instance _appVal_Proper : Proper (equiv ==> equiv) _appVal.
  Proof.
    solve_properS _appVal.
  Qed.

  Definition appVal := injF2 _appVal _.

  Fixpoint equiv_dec val1 val2 : {val1 == val2} + {~ val1 == val2}.
  Proof.
    destruct val1, val2.
    destruct (Nat.eq_dec n n0). left. congruence.
    right. congruence.
    right. intro. inversion H.
    right. intro. inversion H.
    right. intro. inversion H.
    right. intro. inversion H.
    right. intro. inversion H.
    destruct s as [n n0], s0 as [n1 n2].
    destruct (Nat.eq_dec n n1), (Nat.eq_dec n0 n2).
    left. congruence.
    right. congruence.
    right. congruence.
    right. congruence.
    right. intro. inversion H.
    right. intro. inversion H.
    right. intro. inversion H.
    right. intro. inversion H.
    right. intro. inversion H.
    left. congruence.
    right. intro. inversion H.
    right. intro. inversion H.
    right. intro. inversion H.
    right. intro. inversion H.
    right. intro. inversion H.
    destruct (equiv_dec val1_1 val2_1) as [n| n0], (equiv_dec val1_2 val2_2) as [n1| n2].
    left. congruence.
    right. intro. inversion H. tauto.
    right. intro. inversion H. tauto.
    right. intro. inversion H. tauto.
    right. intro. inversion H.
    right. intro. inversion H.
    right. intro. inversion H.
    right. intro. inversion H.
    right. intro. inversion H.
    destruct s, s0.    left. congruence.
  Qed.
End SQLValType.

Section SQLSyntax.

  Context
    (sqlBuiltInExprT : Type)
    (sqlBuiltInFormulaT : Type).

  Inductive sqlExpr :=
  | sqlValExpr : sqlBuiltInExprT -> sqlExpr
  | sqlVarExpr : var -> sqlExpr
  | sqlAppExpr : sqlExpr -> sqlExpr -> sqlExpr
  | sqlColExpr : sqlExpr -> nat (* col index *) -> sqlExpr
  .

  Instance sqlExprS : Setoid sqlExpr :=
    {
      equiv := eq
    }
  .

  Inductive sqlFormula :=
  | sqlBuiltIn : sqlBuiltInFormulaT -> sqlExpr -> sqlExpr -> sqlFormula
  | sqlAnd : sqlFormula -> sqlFormula -> sqlFormula
  | sqlOr : sqlFormula -> sqlFormula -> sqlFormula
  | sqlNot : sqlFormula -> sqlFormula
  | sqlExists : sql -> sqlFormula
  with
  sql :=
  | sqlQuery : list (sqlExpr * var) -> list (nat (* table index *) * var) -> sqlFormula -> sql
  .

  Instance sqlFormulaS : Setoid sqlFormula :=
    {
      equiv := eq
    }
  .

  Instance sqlS : Setoid sql :=
    {
      equiv := eq
    }
  .

  Inductive sqlStmt :=
  | sqlQueryStmt : sql -> sqlStmt
  | sqlInsertStmt : nat (* table index *) -> sql -> sqlStmt
  | sqlUpdateStmt : nat (* table index *) -> var -> list (nat (* col index *) * sqlExpr) -> sqlFormula -> sqlStmt
  | sqlDeleteStmt : nat (* table index *) -> var -> sqlFormula -> sqlStmt
  .

  Program Instance sqlStmtS : Setoid sqlStmt :=
    {
      equiv := eq
    }
  .

Section SQLFormulaDoubleInductionPrinciple.
  Variables
    (p : sqlFormula -> sqlFormula -> Prop)
    (q : sql -> sql -> Prop)
  .

  Hypothesis
    (pbibi : forall bi e1 e2 bi2 e3 e4, p (sqlBuiltIn bi e1 e2) (sqlBuiltIn bi2 e3 e4))
    (pbiand : forall bi e1 e2 a b, p (sqlBuiltIn bi e1 e2) (sqlAnd a b))
    (pbior : forall bi e1 e2 a b, p (sqlBuiltIn bi e1 e2) (sqlOr a b))
    (pbinot : forall bi e1 e2 a, p (sqlBuiltIn bi e1 e2) (sqlNot a))
    (pbiexi : forall bi e1 e2 s, p (sqlBuiltIn bi e1 e2) (sqlExists s))
    (pandbi : forall x y bi2 e3 e4, p (sqlAnd x y) (sqlBuiltIn bi2 e3 e4))
    (pandand : forall x y a b, p x a -> p y b -> p (sqlAnd x y) (sqlAnd a b))
    (pandor : forall x y a b, p (sqlAnd x y) (sqlOr a b))
    (pandnot : forall x y a, p (sqlAnd x y) (sqlNot a))
    (pandexi : forall x y s, p (sqlAnd x y)  (sqlExists s))
    (porbi : forall x y bi2 e3 e4, p (sqlOr x y) (sqlBuiltIn bi2 e3 e4))
    (porand : forall x y a b, p (sqlOr x y) (sqlAnd a b))
    (poror : forall x y a b, p x a -> p y b -> p (sqlOr x y) (sqlOr a b))
    (pornot : forall x y a, p (sqlOr x y) (sqlNot a))
    (porexi : forall x y s, p (sqlOr x y)  (sqlExists s))
    (pnotbi : forall x bi2 e3 e4, p (sqlNot x) (sqlBuiltIn bi2 e3 e4))
    (pnotand : forall x a b, p (sqlNot x) (sqlAnd a b))
    (pnotor : forall x a b, p (sqlNot x) (sqlOr a b))
    (pnotnot : forall x a, p x a -> p (sqlNot x) (sqlNot a))
    (pnotexi : forall x s, p (sqlNot x)  (sqlExists s))
    (pexibi : forall r bi2 e3 e4, p (sqlExists r) (sqlBuiltIn bi2 e3 e4))
    (pexiand : forall r a b, p (sqlExists r) (sqlAnd a b))
    (pexior : forall r a b, p (sqlExists r) (sqlOr a b))
    (pexinot : forall r a, p (sqlExists r) (sqlNot a))
    (pexiexi : forall r s, q r s -> p (sqlExists r)  (sqlExists s))
    (qqueque : forall es1 es2 tel1 tel2 a b, p a b -> q (sqlQuery es1 tel1 a) (sqlQuery es2 tel2 b))
  .

    Fixpoint sqlFormula_ind_2 f1 f2 : p f1 f2 :=
      match f1 in sqlFormula return p f1 f2 with
        | sqlBuiltIn bi e1 e2 =>
          match f2  in sqlFormula return p (sqlBuiltIn bi e1 e2) f2 with
            | sqlBuiltIn bi2 e3 e4 => pbibi bi e1 e2 bi2 e3 e4
            | sqlAnd a b => pbiand bi e1 e2 a b
            | sqlOr a b => pbior bi e1 e2 a b
            | sqlNot a => pbinot bi e1 e2 a
            | sqlExists s => pbiexi bi e1 e2 s
          end
        | sqlAnd x y =>
          match f2 in sqlFormula return p (sqlAnd x y) f2 with
            | sqlBuiltIn bi2 e3 e4 => pandbi x y bi2 e3 e4
            | sqlAnd a b => pandand x y a b (sqlFormula_ind_2 x a) (sqlFormula_ind_2 y b)
            | sqlOr a b => pandor x y a b
            | sqlNot a => pandnot x y a
            | sqlExists s => pandexi x y s
          end
        | sqlOr x y =>
          match f2 in sqlFormula return p (sqlOr x y) f2 with
            | sqlBuiltIn bi2 e3 e4 => porbi x y bi2 e3 e4
            | sqlAnd a b => porand x y a b
            | sqlOr a b => poror x y a b (sqlFormula_ind_2 x a) (sqlFormula_ind_2 y b)
            | sqlNot a => pornot x y a
            | sqlExists s => porexi x y s
          end
        | sqlNot x =>
          match f2 in sqlFormula return p (sqlNot x) f2 with
            | sqlBuiltIn bi2 e3 e4 => pnotbi x bi2 e3 e4
            | sqlAnd a b => pnotand x a b
            | sqlOr a b => pnotor x a b
            | sqlNot a => pnotnot x a (sqlFormula_ind_2 x a)
            | sqlExists s => pnotexi x s
          end
        | sqlExists r =>
          match f2 in sqlFormula return p (sqlExists r) f2 with
            | sqlBuiltIn bi2 e3 e4 => pexibi r bi2 e3 e4
            | sqlAnd a b => pexiand r a b
            | sqlOr a b => pexior r a b
            | sqlNot a => pexinot r a
            | sqlExists s =>
              pexiexi r s ((fix h' (q1 q2 : sql) : q q1 q2 :=
                              match q1 in sql, q2 in sql return q q1 q2 with
                                | sqlQuery es1 tel1 a, sqlQuery es2 tel2 b =>
                                  qqueque es1 es2 tel1 tel2 a b (sqlFormula_ind_2 a b)
                              end) r s)
          end
    end.

End SQLFormulaDoubleInductionPrinciple.
End SQLSyntax.

Section SQLSemanticsDefs.
  Instance sqlVal_Pointed : Pointed sqlVal :=
    {
      point := vNil
    }.

  Definition row := lista sqlVal.
  Instance rowS : Setoid row := listaS sqlValS.
  Definition col := lista (maybe sqlVal).
  Instance colS : Setoid col := listaS (maybeS sqlValS).

  Definition table := matrixp sqlVal.
  Instance tableS : Setoid table := matrixpS sqlValS.
  Definition database := list table.
  Instance databaseS : Setoid database := listS tableS.

  Definition store := lista (maybe sqlVal).

  Section Getters.

    Existing Instance ComposeP_Preview.
    Definition _cellGetter (t ri ci : nat) : databaseS ~> maybeS sqlValS := preview @ (nthPreview t >>>? matrixCellPreview ri ci).

    Instance _cellGetter_Proper : Proper (equiv ==> equiv ==> equiv ==> equiv) _cellGetter.
    Proof.
      solve_proper.
    Qed.

    Definition cellGetter := injF3 _cellGetter _.

    Definition _rowGetter (t ri: nat) : databaseS ~> maybeS (rowS) := preview @ (nthPreview t >>>? matrixRowsLens >>>? listaNthLens ri >>>? maybePreview).

    Instance _rowGetter_Proper : Proper (equiv ==> equiv ==> equiv) _rowGetter.
    Proof.
      solve_proper.
    Qed.

    Definition rowGetter := injF2 _rowGetter _.

    Definition _colGetter (t ci: nat) : databaseS ~>  maybeS (colS) :=
      (caseMaybeS
        @ (SomeS ∘ readMatrixCol @ ci)
        @ None)
        ∘ (preview @ (nthPreview t)).

    Instance _colGetter_Proper : Proper (equiv ==> equiv ==> equiv) _colGetter.
    Proof.
      solve_proper.
    Qed.

    Definition colGetter := injF2 _colGetter _.

    Definition _rowsGetter t : databaseS ~> maybeS (listaS (maybeS (rowS))) :=
      preview @ (nthPreview t >>>? matrixRowsLens).

    Instance _rowsGetter_Proper : Proper (equiv ==> equiv) _rowsGetter.
    Proof.
      solve_proper.
    Qed.

    Definition rowsGetter := injF _rowsGetter _.

    Definition _tableGetter t : databaseS ~> maybeS tableS := preview @ (nthPreview t).

    Instance _tableGetter_Proper : Proper (equiv ==> equiv) _tableGetter.
    Proof.
      solve_proper.
    Qed.

    Definition tableGetter := injF _tableGetter _.

    (*Definition _widthGetter t : databaseS ~> maybeS (natS) :=
      (caseMaybeS
        @ (SomeS ∘ width)
        @ None)
        ∘ (preview @ (nthPreview t)).

    Instance _widthGetter_Proper : Proper (equiv ==> equiv) _widthGetter.
    Proof.
      solve_proper.
    Qed.

    Definition widthGetter := injF _widthGetter _.*)

    Definition tableRowsGetter : tableS ~> listaS (maybeS (rowS)) := view @ (matrixRowsLens).

    Definition tableColGetter : natS ~> tableS ~~> listaS (optionS sqlValS) := readMatrixCol.

(*    Definition tableWidthGetter : tableS ~>  (natS) :=
      view (matrixWidthLens).*)

    Definition _tableCellGetter ri ci : tableS ~> (maybeS sqlValS) :=
      preview @ (matrixCellPreview ri ci).

    Instance _tableCellGetter_Proper : Proper (equiv ==> equiv ==> equiv) _tableCellGetter.
    Proof.
      solve_proper.
    Qed.

    Definition tableCellGetter := injF2 _tableCellGetter  _.

    Definition rowColGetter n : rowS ~> sqlValS := view @ (listaNthLens n).

    Definition _maybeRowGetter (t: nat) (ri: nat) : databaseS ~>  maybeS (maybeS rowS) :=
      preview @ (nthPreview t >>>? matrixRowsLens >>>? listaNthLens ri).

    Instance _maybeRowGetter_Proper : Proper (equiv ==> equiv ==> equiv) _maybeRowGetter.
    Proof.
      autounfold. intros. unfold _maybeRowGetter. rewritesr.
    Qed.

    Definition maybeRowGetter : natS ~> natS ~~> databaseS ~~> maybeS (maybeS rowS) := injF2 _maybeRowGetter _.

(*    Lemma tableWidthGetter_1 : forall n (l : lista (maybe (lista sqlVal))), tableWidthGetter @ (matrixpCons _ n l) = n.
    Proof.
      intros. reflexivity.
    Qed.

    Lemma widthGetter_0 : forall tab h, widthGetter @ 0 @ (tab :: h) = Some (tableWidthGetter @ tab).
    Proof.
      intros. simpl. auto.
    Qed.*)

(*    Section Comps.

      Lemma cellGetter_comp :
        forall t ri ci h,
          (tableGetter @ t @ h) >>= tableCellGetter @ ri @ ci == cellGetter @ t @ ri @ ci @ h.
      Proof.
        intros. unfold cellGetter. normalize. unfold _cellGetter. rewrite nthTraversal_comp_preview. reflexivity.
      Qed.

    End Comps.*)

  End Getters.

  Section Setters.

    Existing Instance ComposeP_Preview.
    Definition _cellSetter t (ri: nat) (ci: nat) (n : sqlVal) : databaseS ~> databaseS :=
      set @ (nthPreview t >>>? matrixCellPreview ri ci) @ n.

    Instance _cellSetter_Proper : Proper (equiv ==> equiv ==> equiv ==> equiv ==> equiv) _cellSetter.
    Proof.
      solve_proper.
    Qed.

    Definition cellSetter := injF4 _cellSetter _.

    Definition _rowSetter (t ri: nat) (r : row) : databaseS ~> databaseS :=
      set @ (nthPreview t >>>? matrixRowPreview ri) @ r.

    Instance _rowSetter_Proper : Proper (equiv ==> equiv ==> equiv ==> equiv) _rowSetter.
    Proof.
      autounfold. intros. unfold _rowSetter, set. rewritesr.
    Qed.

    Definition rowSetter := injF3 _rowSetter _.

    Definition _maybeRowSetter (t: nat) (ri: nat) (r : maybe row) : databaseS ~>  databaseS :=
      set @ (nthPreview t >>>? matrixMaybeRowLens ri) @ r.

    Instance _maybeRowSetter_Proper : Proper (equiv ==> equiv ==> equiv ==> equiv) _maybeRowSetter.
    Proof.
      autounfold. intros. unfold _maybeRowSetter, set. rewritesr.
    Qed.

    Definition maybeRowSetter := injF3 _maybeRowSetter _.

    Definition _rowsSetter (t: nat) (rows : lista (maybe row)) : databaseS ~>  databaseS :=
      set @ (nthPreview t >>>? matrixRowsLens ) @ rows.

    Instance _rowsSetter_Proper : Proper (equiv ==> equiv ==> equiv) _rowsSetter.
    Proof.
      autounfold. intros. unfold _rowsSetter, set. rewritesr.
    Qed.

    Definition rowsSetter := injF2 _rowsSetter _.

  End Setters.

  Instance FMapNat_Equal_Equivalence A : Equivalence (@FMapNat.Equal A).
  Proof.
    split.
    autounfold. unfold FMapNat.Equal. intros. reflexivity.
    autounfold. unfold FMapNat.Equal. intros. symmetry. auto.
    autounfold. unfold FMapNat.Equal. intros. transitivity (FMapNat.find y0 y). auto. auto.
  Qed.

  Instance storeS : Setoid store := listaS (maybeS sqlValS).
  Definition colLookup row colind : option sqlVal :=
    nth_error row colind.

  Existing Instance maybe_first_Monoid.
  Existing Instance maybe_mappend_PointedFunction2.
  Definition storeProd (s1 s2 : store) : store :=
    lista_zipWith mappend s2 s1.

  Definition storesProd (ss1 ss2 : list store) : list store :=
    concat (map (fun s => map (fun s2 => storeProd s s2) ss2) ss1).

End SQLSemanticsDefs.


Require Import Primitives Simulation Layer1.
Require Import Omega FunctionalExtensionality.
Import ListNotations.
Close Scope pred_scope.
Set Implicit Arguments.

Section Layer2.

  Inductive token:=
  | BlockNum : addr -> token
  | DiskFull : token
  | Cont : token
  | Crash1 : token
  | Crash2 : token
  | CrashAlloc: addr -> token.

  Definition oracle := list token.

  Definition state := disk value.

  Inductive prog : Type -> Type :=
  | Read : addr -> prog (option value)
  | Write : addr -> value -> prog (option unit)
  | Alloc : value -> prog (option addr)
  | Free : addr -> prog unit
  | Ret : forall T, T -> prog T
  | Bind : forall T T', prog T -> (T -> prog T') -> prog T'.

  Inductive exec :
    forall T, oracle -> state -> prog T -> @Result state T -> Prop :=
  | ExecRead :
      forall d a,
        exec [Cont] d (Read a) (Finished d (d a))

  | ExecWriteSucc :
      forall d a v,
        d a <> None ->
        exec [Cont] d (Write a v) (Finished (upd d a v) (Some tt))

  | ExecWriteFail :
      forall d a v,
        d a = None ->
        exec [Cont] d (Write a v) (Finished d None)

  | ExecAllocSucc :
      forall d a v,
        d a = None ->
        exec [BlockNum a] d (Alloc v) (Finished (upd d a v) (Some a))

  | ExecAllocFail :
      forall d v,
        exec [DiskFull] d (Alloc v) (Finished d None)

  | ExecFree :
      forall d a,
        exec [Cont] d (Free a) (Finished (delete d a) tt)

  | ExecRet :
      forall d T (v: T),
        exec [Cont] d (Ret v) (Finished d v)

  | ExecBind :
      forall T T' (p1: prog T) (p2: T -> prog T')
        o1 o2 d d1 r ret,
        exec o1 d p1 (Finished d1 r) ->
        exec o2 d1 (p2 r) ret ->
        exec (o1 ++ o2) d (Bind p1 p2) ret

  | ExecReadCrash :
      forall d a,
        exec [Crash1] d (Read a) (Crashed d)

  | ExecWriteCrashBefore :
      forall d a v,
        exec [Crash1] d (Write a v) (Crashed d)

  | ExecWriteCrashAfter :
      forall d a v,
        exec [Crash2] d (Write a v) (Crashed (upd d a v))

  | ExecAllocCrashBefore :
      forall d v,
        exec [Crash1] d (Alloc v) (Crashed d)

  | ExecAllocCrashAfter :
      forall d a v,
        d a = None ->
        exec [CrashAlloc a] d (Alloc v) (Crashed (upd d a v))

  | ExecFreeCrashBefore :
      forall d a,
        exec [Crash1] d (Free a) (Crashed d)

  | ExecFreeCrashAfter :
      forall d a,
        exec [Crash2] d (Free a) (Crashed (delete d a))

  | ExecRetCrash :
      forall T d (a: T),
        exec [Crash1] d (Ret a) (Crashed d)

  | ExecBindCrash :
      forall T T' (p1: prog T) (p2: T -> prog T')
        o d d1,
        exec o d p1 (Crashed d1) ->
        exec o d (Bind p1 p2) (Crashed d1)
.

  Definition layer2_lts := Build_LTS oracle state prog exec.

End Layer2.

Notation "x <- p1 ; p2" := (Bind p1 (fun x => p2))(right associativity, at level 60).
Hint Constructors exec.


From fae_gtlc_mu.stlc_mu Require Import lang typing typing_lemmas types_notations.

(** Factorisations *)

Definition factorization (f g : expr) : val :=
  LamV (
      g.[ren (+1)] (f.[ren (+1)] (Var 0))
    ).

Lemma factorization_subst_rewrite (f g : expr) σ : (of_val (factorization f g)).[σ] = factorization f.[σ] g.[σ].
Proof. by asimpl. Qed.

Lemma factorization_typed Γ {f g : expr} τ1 τ2 τ3
      (df : Γ ⊢ₛ f : TArrow τ1 τ2)
      (dg : Γ ⊢ₛ g : TArrow τ2 τ3) :
  Γ ⊢ₛ factorization f g : TArrow τ1 τ3.
Proof.
  apply Lam_typed; auto.
  apply (TArrow_closed1 (typed_closed df)).
  apply App_typed with (τ1 := τ2).
  apply up_type_one. apply dg.
  apply App_typed with (τ1 := τ1).
  apply up_type_one. apply df.
  apply Var_typed; auto.
  apply (TArrow_closed1 (typed_closed df)).
Qed.


Require Import Fiat.Common Fiat.Computation Fiat.ADT Coq.Sets.Ensembles.

Generalizable All Variables.
Set Implicit Arguments.

Section MethodRefinement.

  (** Old and new representations **)
  Variables oldRep newRep : Type.

  (** Abstraction Relation *)
  Variable AbsR : oldRep -> newRep -> Prop.

  Notation "ro ≃ rn" := (AbsR ro rn) (at level 70).

  (** Refinement of a constructor: the computation produced by
   a constructor [newConstructor] should be a refinement
   of the computation produced by the old constructor [oldObserver] on
   [d].  That is, the following diagram should commute:
<<
           old constructor
       Dom --------------> old rep
        ∥                      |
        ∥ id              AbsR |
        ∥                      |
       Dom --------------> new rep
          new constructor
>>
   *)

  Fixpoint refineConstructor
           {dom : list Type}
    : constructorType oldRep dom
      -> constructorType newRep dom
      -> Prop :=
    match dom return
          constructorType oldRep dom
          -> constructorType newRep dom
          -> Prop
    with
    | nil => fun oldConstructor newConstructor =>
               refine (r_o' <- oldConstructor;
                       {r_n | r_o' ≃ r_n})
                      (newConstructor)
    | cons D dom' =>
      fun oldConstructor newConstructor =>
        forall d : D,
          @refineConstructor dom' (oldConstructor d)
                             (newConstructor d)
    end.

  (* Variant for use in tactics. *)
    Fixpoint refineConstructor_eq
           {dom : list Type}
    : constructorType oldRep dom
      -> constructorType oldRep dom
      -> Prop :=
    match dom return
          constructorType oldRep dom
          -> constructorType oldRep dom
          -> Prop
    with
    | nil => fun oldConstructor newConstructor =>
               refine oldConstructor newConstructor
    | cons D dom' =>
      fun oldConstructor newConstructor =>
        forall d : D,
          @refineConstructor_eq dom' (oldConstructor d)
                                (newConstructor d)
    end.

  (** Refinement of a method : the values of the computation
      produced by applying a new method [newMethod] to any new
      state [r_n] related to an old state [r_o] by the abstraction
      relation [AbsR] are related by [AbsR] to some value produced by
      the corresponding old method on [r_o]. Related values
      are taken to related values (with the new method potentially
      producing more deterministic computations). That is, the
      following diagram commutes:
<<
                   old method
       old rep --------------> old rep
          |                         |
     AbsR |                         | AbsR
          ↓                         ↓
       new rep --------------> new rep
                   new method
>>  *)

  Fixpoint refineMethod'
           {dom : list Type}
           {cod : option Type}
    : methodType' oldRep dom cod
      -> methodType' newRep dom cod
      -> Prop :=
    match dom return
          methodType' oldRep dom cod
          -> methodType' newRep dom cod
          -> Prop
    with
    | nil =>
      match cod return
            methodType' oldRep [] cod
            -> methodType' newRep [] cod
            -> Prop
      with
      | Some cod' =>
        fun oldMethod newMethod =>
          refine (r_o' <- oldMethod;
                  r_n' <- {r_n | fst r_o' ≃ r_n};
                  ret (r_n', snd r_o'))
                 newMethod
      | _ =>
        fun oldMethod newMethod =>
          refine (r_o' <- oldMethod;
                  {r_n | r_o' ≃ r_n})
                 newMethod
      end
    | cons D dom' =>
      fun oldMethod newMethod =>
        forall d : D,
          @refineMethod' dom' cod (oldMethod d)
                        (newMethod d)
    end.

  Definition refineMethod
             {dom : list Type}
             {cod : option Type}
             (oldMethod : methodType oldRep dom cod)
             (newMethod : methodType newRep dom cod)
    := forall r_o r_n,
      r_o ≃ r_n ->
      @refineMethod' dom cod (oldMethod r_o) (newMethod r_n).

    Fixpoint refineMethod_eq'
           {dom : list Type}
           {cod : option Type}
    : methodType' oldRep dom cod
      -> methodType' oldRep dom cod
      -> Prop :=
    match dom return
          methodType' oldRep dom cod
          -> methodType' oldRep dom cod
          -> Prop
    with
    | nil =>
      match cod return
            methodType' oldRep [] cod
            -> methodType' oldRep [] cod
            -> Prop
      with
      | Some cod' =>
        fun oldMethod newMethod =>
          refine oldMethod newMethod
      | _ =>
        fun oldMethod newMethod =>
          refine oldMethod newMethod
      end
    | cons D dom' =>
      fun oldMethod newMethod =>
        forall d : D,
          @refineMethod_eq' dom' cod (oldMethod d)
                        (newMethod d)
    end.

  Definition refineMethod_eq
             {dom : list Type}
             {cod : option Type}
             (oldMethod : methodType oldRep dom cod)
             (newMethod : methodType oldRep dom cod)
    := forall r_o,
      @refineMethod_eq' dom cod (oldMethod r_o) (newMethod r_o).

End MethodRefinement.

Record refineADT {Sig} (A B : ADT Sig) :=
  refinesADT {
      AbsR : _;
      ADTRefinementPreservesConstructors
      : forall idx : ConstructorIndex Sig,
          @refineConstructor
            (Rep A) (Rep B) AbsR
            (ConstructorDom Sig idx)
            (Constructors A idx)
            (Constructors B idx);
      ADTRefinementPreservesMethods
      : forall idx : MethodIndex Sig,
          @refineMethod
            (Rep A) (Rep B) AbsR
            (fst (MethodDomCod Sig idx))
            (snd (MethodDomCod Sig idx))
            (Methods A idx)
            (Methods B idx) }.
(** We should always just unfold [refineMethod] and [refineConstructor]
    into [refine], so that we can rewrite with lemmas about [refine]. *)

Notation "ro ≃ rn" := (@AbsR _ _ _ _ ro rn) (at level 70).


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Section Equivalence.
  Context {A} {R:relation A}.
  Global Instance Reflexive_fieldwise' {R_Reflexive:Reflexive R} {n:nat} : Reflexive (fieldwise' n R) | 5.
  Proof 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} {n:nat} : Reflexive (fieldwise n R) | 5.
  Proof using Type. destruct n; (repeat constructor || exact _). Qed.
  Global Instance Symmetric_fieldwise {R_Symmetric:Symmetric R} {n:nat} : Symmetric (fieldwise n R) | 5.
  Proof using Type. destruct n; (repeat constructor || exact _). Qed.
  Global Instance Transitive_fieldwise {R_Transitive:Transitive R} {n:nat} : Transitive (fieldwise n R) | 5.
  Proof using Type. destruct n; (repeat constructor || exact _). Qed.
  Global Instance Equivalence_fieldwise {R_equiv:Equivalence R} {n:nat} : Equivalence (fieldwise n R).
  Proof using Type. constructor; exact _. Qed.
End Equivalence.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Require Import Coq.Lists.SetoidList.

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

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

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

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

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

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

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

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

Lemma subst_append {A n} (x : tuple A (S n)) : x = append (hd x) (tl x).
Proof. 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. destruct n; try destruct x; reflexivity. Qed.

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

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

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

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

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. 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.
  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. 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. reflexivity. Qed.

Lemma left_hd_append {T n} (xs : tuple T (S n)) x:
  left_hd (append x xs) = left_hd xs.
Proof. 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. destruct n; reflexivity. Qed.

Lemma hd_left_append {T n} (xs : tuple T (S n)) x :
  hd (left_append x xs) = hd xs.
Proof. 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.
    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.
  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.
  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.

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

Lemma mapi_with'_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. 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.
  induction n; intros; [subst; simpl; repeat f_equal; omega|].
  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 omega).
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.
  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.
  induction n; simpl repeat; [reflexivity|rewrite map_append; congruence].
Qed.

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

Global Instance map'_Proper {n A B} : Proper (pointwise_relation _ eq ==> eq ==> eq) (fun f => @map' A B f n) | 10.
Proof.
  induction n.
  { 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 {n A B} : Proper (pointwise_relation _ eq ==> eq ==> eq) (@map n A B) | 10.
Proof.
  destruct n; [ | apply map'_Proper ].
  { repeat (intros [] || intro); auto. }
Qed.


(** * Functoriality of functor composition *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Functor.Composition.Core NaturalTransformation.Composition.Core.
Require Import Category.Prod FunctorCategory.Core NaturalTransformation.Composition.Functorial NaturalTransformation.Composition.Laws ExponentialLaws.Law4.Functors.
Require Import NaturalTransformation.Paths.
Require ProductLaws.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

(** * Construction of the functor [_∘_ : (C → D) × (D → E) → (C → E)] and it's curried variant *)
Section functorial_composition.
  Context `{Funext}.
  Variables C D E : PreCategory.

  Local Open Scope natural_transformation_scope.

  Definition compose_functor_morphism_of
             s d (m : morphism (C -> D) s d)
  : morphism ((D -> E) -> (C -> E))
             (whiskerR_functor _ s)
             (whiskerR_functor _ d)
    := Build_NaturalTransformation
         (whiskerR_functor E s)
         (whiskerR_functor E d)
         (fun x => x oL m)
         (fun _ _ _ => exchange_whisker _ _).

  Definition compose_functor : object ((C -> D) -> ((D -> E) -> (C -> E))).
  Proof.
    refine (Build_Functor
              (C -> D) ((D -> E) -> (C -> E))
              (@whiskerR_functor _ _ _ _)
              compose_functor_morphism_of
              _
              _);
    abstract (
        path_natural_transformation;
        rewrite ?composition_of, ?identity_of;
        reflexivity
      ).
  Defined.

  Definition compose_functor_uncurried
  : object ((C -> D) * (D -> E) -> (C -> E))
    := ExponentialLaws.Law4.Functors.functor _ _ _ compose_functor.

  Definition compose_functor' : object ((D -> E) -> ((C -> D) -> (C -> E)))
    := ExponentialLaws.Law4.Functors.inverse
         _ _ _ (compose_functor_uncurried o ProductLaws.Swap.functor _ _)%functor.
End functorial_composition.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
Section S.
Inductive T (U : Type) : Type :=
    c : U -> T U.
End S.


Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrbool ssrnat eqtype.
Require Import Show Sets Generators Producer RoseTrees Checker Classes.

Import QcDefaultNotation.
Local Open Scope set_scope.

Definition resultSuccessful (r : Result) : bool :=
  match r with
    | MkResult (Some res) expected _ _ _ _ _ =>
      res == expected
    | _ => true
  end.

Definition successful qp :=
  match qp with
    | MkProp (MkRose res _) => resultSuccessful res
  end.

(* Maps a Checker to a Prop *)

(* begin semCheckerSize *)
Definition semCheckerSize (c : Checker) (s : nat): Prop :=
  successful @: semProdSize c s \subset [set true].
(* end semCheckerSize *)

(* ZP: Do we want to define semChecker in terms of semCheckerSize? *)

(* begin semChecker *)
Definition semChecker (c : Checker) : Prop := forall s, semCheckerSize c s.
(* end semChecker *)

(* Maps a Checkable to a Prop i.e. gives an equivalent proposition to the
   property under test *)

(* begin semCheckableSize *)
Definition semCheckableSize {A} `{Checkable A} (a : A) (s : nat) : Prop :=
  semCheckerSize (checker a) s.
(* end semCheckableSize *)

(* begin semCheckable *)
Definition semCheckable {A} `{Checkable A} (a : A) : Prop := semChecker (checker a).
(* end semCheckable *)

(* another characterization of semChecker *)
Lemma semChecker_def2 c :
  semChecker c <-> (forall qp, semProd c qp -> successful qp = true).
Proof.
  rewrite /semChecker /semCheckerSize /semProd. split; intro H.
  - intros. destruct H0 as [s [H0 Ho']]. symmetry; eapply (H s). eexists.
    split; eauto.  reflexivity.
  - intros n b [qp [H1 H2]]. symmetry in H2.
    rewrite H2. symmetry. apply H.
    eexists; eauto. split; eauto. reflexivity.
Qed.

(* CH: This is the definition of Checker I would like to use *)
(* ZP : For now semCheckerSize has a similar definition and
        semChecker is defined in terms of semCheckerSize *)
Lemma semChecker_def3 c :
  semChecker c <-> (successful @: semProd c \subset [set true]).
Proof.
  rewrite semChecker_def2. split; intro H.
(*  CH: why can't I rewrite with semFmap directly? See tentative instances below *)
  - intros b H'. unfold imset, bigcup in H'.
    destruct H' as [qp [H1 H2]]. apply H in H1. by rewrite H1 in H2.
  - intros. specialize (H (successful qp)).
    unfold set1 in H. symmetry. apply: H.
    by eapply imset_in.
Qed.

Definition genChecker c := @fmap G _ _ _ successful c.

Class UnsizedChecker (c : Checker) :=
  {
    unsizedChecker :
      forall s1 s2 : nat, semProdSize (genChecker c) s1 <--> semProdSize (genChecker c) s2
  }.

Class SizeMonotonicChecker (c : Checker) :=
  {
    monotonicChecker :
      forall s1 s2, s1 <= s2 ->
                    semProdSize (genChecker c) s1 \subset semProdSize (genChecker c) s2

  }.

Lemma unsizedChecker_alt_def (c : Checker) `{UnsizedChecker c} :
  forall s1 s2, semCheckerSize c s1 <-> semCheckerSize c s2.
Proof.
  rewrite /semCheckerSize => s1 s2; split;
  move : H => [/(_ s1 s2) H];
  rewrite /genChecker in H; setoid_rewrite semFmapSize in H; eauto with typeclass_instances;
  by rewrite H.
Qed.

Lemma monotonicChecker_alt_def (c : Checker) `{SizeMonotonicChecker c} :
  forall s1 s2, s1 <= s2 -> semCheckerSize c s2 -> semCheckerSize c s1.
Proof.
  rewrite /semCheckerSize => s1 s2 Hle.
  move : H => [/(_ s1 s2 Hle) H].
  rewrite /genChecker in H;
    setoid_rewrite semFmapSize in H;
    eauto with typeclass_instances.
  move => H1 b H2. apply H1. eauto.
Qed.

#[global]
Program Instance unsizedMonotonicChecker (c : Checker) `{UnsizedChecker c} :
  SizeMonotonicChecker c.
Next Obligation.
  move => b Hb.
  pose proof (@unsizedChecker c H s1 s2) as HU.
  apply HU.
  apply Hb.
Qed.

Lemma mapTotalResult_idSize {C} `{Checkable C} (f : Result -> Result) (c : C) s :
    (forall res, resultSuccessful res = resultSuccessful (f res)) ->
    (semCheckerSize (mapTotalResult f c) s <-> semCheckableSize c s).
Proof.
  move=> eq_res.
  rewrite /mapTotalResult /mapRoseResult /mapProp/semCheckableSize /semCheckerSize.
  split; rewrite semFmapSize.
  - move => H1 b [[[res l]] /= [H2 H3]].
    rewrite -H3 eq_res. apply H1.
    repeat (eexists; split; eauto).
  - move => /= H1 b [[[res l]] /= [[[[res' l'] [/= H2 [H3 H4]]] H5]]]; subst.
    rewrite <- H5, <- eq_res in *.  apply H1.
    eexists. split; eauto. reflexivity.
Qed.

Lemma mapTotalResult_id {C} `{Checkable C} (f : Result -> Result) (c : C) :
    (forall res, resultSuccessful res = resultSuccessful (f res)) ->
    (semChecker (mapTotalResult f c) <-> semCheckable c).
Proof.
  move=> eq_res; split => H' s; eapply mapTotalResult_idSize; eauto.
  by apply H'.
Qed.

Lemma semCallback_idSize {C} `{Checkable C} (cb : Callback) (c : C) (s : nat) :
    semCheckerSize (callback cb c) s <-> semCheckableSize c s.
Proof.
  rewrite /callback.
  split; move => H'.
  - apply mapTotalResult_idSize in H' => //;
    by move => [? ? ? ? ? ?].
  - apply mapTotalResult_idSize => //;
    by move => [? ? ? ? ? ?].
Qed.

Lemma semCallback_id {C} `{Checkable C} (cb : Callback) (c : C) :
    semChecker (callback cb c) <-> semCheckable c.
Proof.
  split => H' s; eapply semCallback_idSize; eauto.
  by apply H'.
Qed.

Lemma semWhenFail_idSize {C} `{Checkable C} (str : String.string) (c : C) s :
    semCheckerSize (whenFail str c) s <-> semCheckableSize c s.
Proof.
  by rewrite /whenFail semCallback_idSize.
Qed.

Lemma semWhenFail_id {C} `{Checkable C} (str : String.string) (c : C) :
    semChecker (whenFail str c) <-> semCheckable c.
Proof.
  by rewrite /whenFail semCallback_id.
Qed.

Lemma semPrintTestCase_idSize {C} `{Checkable C} (str : String.string) (c : C) s :
    semCheckerSize (printTestCase str c) s <-> semCheckableSize c s.
Proof.
  by rewrite /printTestCase semCallback_idSize.
Qed.

Lemma semPrintTestCase_id {C} `{Checkable C} (str : String.string) (c : C) :
    semChecker (printTestCase str c) <-> semCheckable c.
Proof.
  by rewrite /printTestCase semCallback_id.
Qed.

Lemma semShrinking_idSize {C A} {HCheck : Checkable C}
         (sh : A -> list A) (x : A) (pf : A -> C) (s : nat) :
    semCheckerSize (shrinking sh x pf) s <->
    semCheckableSize (pf x) s.
Proof.
  unfold semCheckableSize, shrinking, semCheckerSize, semProdSize, props.
  have [n <-] : exists n, S n  = 1000 by eexists; reflexivity.
  split.
  - move => H b [[[res [l]]] [/= [seed Hgen] H']]; subst.
    + destruct (RandomQC.randomSplitAssumption seed seed)
        as [seed' Hseed'].
      suff :
        successful
          (run
             (@fmap _ (@Functor_Monad G (@super _ (ProducerGen))) _ _
                (fun x0 => {| unProp := joinRose (fmapRose unProp x0) |})
                (promote (@props' _ _ HCheck (S n) pf sh x))) s seed').
      setoid_rewrite runFmap.
      rewrite runPromote. simpl.
      rewrite Hseed'. simpl. rewrite Hgen -H' /=.
      move => -> //.
      rewrite <- H => //. eexists. split; try by reflexivity.
      eexists. reflexivity.
  - move => H b [[[r [l]]] /= [[seed H1] <-]]. apply H.
    simpl in *.
    destruct (RandomQC.randomSplit seed) as [s1 s2].
    destruct ((run (checker (pf x)) s s1)) as [[res [l']]] eqn:Heq=> //=.
    simpl in *. move : H1 => [H1 H2]; subst.
    eexists. eexists. exists s1. reflexivity.
    rewrite Heq.
    reflexivity.
Qed.

Lemma semShrinking_id {C A} {HCheck : Checkable C}
         (sh : A -> list A) (x : A) (pf : A -> C)  :
    semChecker (shrinking sh x pf) <->
    semCheckable (pf x).
Proof.
  split; move => H s; eapply semShrinking_idSize; first by eauto.
  by apply H.
Qed.

(* Program #[global] Instance shrinkingUnsized {C A} `{Checkable C} *)
(*         (sh : A -> list A) (x : A) (pf : A -> C)  *)
(*         `{UnsizedChecker (checker (pf x))} : UnsizedChecker (shrinking sh x pf). *)
(* Next Obligation.  *)
(* Abort. *)

Lemma semCover_idSize {C} `{Checkable C} (b: bool) (n: nat)
      (str : String.string) (c : C) (s : nat) :
  semCheckerSize (cover b n str c) s <-> semCheckableSize c s.
Proof.
  split.
  - rewrite /cover. case: b => //.
    move => H1. apply mapTotalResult_idSize in H1 => //.
      by move => [? ? ? ? ? ?].
  - move => H1. rewrite /cover. case: b => //.
    apply mapTotalResult_idSize => //.
      by move => [? ? ? ? ? ?].
Qed.

Lemma semCover_id {C} `{Checkable C} (b: bool) (n: nat)
      (str : String.string) (c : C) :
  semChecker (cover b n str c) <-> semCheckable c.
Proof.
  split; move => H' s; eapply semCover_idSize; first by eauto.
  by apply H'.
Qed.

Lemma semClassify_idSize {C} `{Checkable C} (b: bool) (str : String.string)
          (c : C) (s : nat) :
    semCheckerSize (classify b str c) s <-> semCheckableSize c s.
Proof.
  by rewrite /classify semCover_idSize.
Qed.

Lemma semClassify_id {C} `{Checkable C} (b: bool) (str : String.string) (c : C) :
    semChecker (classify b str c) <-> semCheckable c.
Proof.
  by rewrite /classify semCover_id.
Qed.

Lemma semLabel_idSize {C} `{Checkable C} (str : String.string) (c : C) (s : nat) :
    semCheckerSize (label str c) s <-> semCheckableSize c s.
Proof.
  by rewrite /label semClassify_idSize.
Qed.

Lemma semLabel_id {C} `{Checkable C} (str : String.string) (c : C) :
    semChecker (label str c) <-> semCheckable c.
Proof.
  by rewrite /label semClassify_id.
Qed.

Lemma semCollect_idSize {C} `{Checkable C} (str : String.string) (c : C) (s : nat) :
    semCheckerSize (collect str c) s <-> semCheckableSize c s.
Proof.
  by rewrite /collect semLabel_idSize.
Qed.

Lemma semCollect_id {C} `{Checkable C} (str : String.string) (c : C) :
    semChecker (collect str c) <-> semCheckable c.
Proof.
  by rewrite /collect semLabel_id.
Qed.

Open Scope Checker_scope.

Lemma semImplicationSize {C} `{Checkable C} (c : C) (b : bool) s :
  semCheckerSize (implication b c) s <-> (b -> semCheckableSize c s).
Proof.
  case: b; split=> //=; first by move/(_ refl_equal).
  by move => _ b [x [/semReturnSize <- <-]].
Qed.

(* begin semImplication *)
Lemma semImplication {C} `{Checkable C} (c : C) (b : bool) :
  semChecker (implication b c) <-> (b -> semCheckable c).
(* end semImplication *)
Proof.
  split; [move => H1 b' s' | move => H1 s b'];
  eapply semImplicationSize; try by eauto.
  move => b''. by apply H1.
Qed.

Lemma implication_unsized :
(forall (C : Type) (H : Checkable C) (b : bool) (c : C),
 UnsizedChecker (checker c) ->
 forall s1 s2 : nat,
 semProdSize (genChecker (implication b c)) s1 <-->
 semProdSize (genChecker (implication b c)) s2).
Proof.
  move => C H b c HC s1 s2. move: HC => [/(_ s1 s2) H0].
  rewrite /genChecker in H0 *. rewrite -> !semFmapSize in H0; eauto with typeclass_instances.
  rewrite !semFmapSize.
  rewrite /implication. case : b; eauto.
  apply imset_eq. rewrite !semReturnSize. reflexivity.
Qed.

#[global]
Instance implicationUnsized
        {C} `{H: Checkable C} b (c : C) `{HC : UnsizedChecker (checker c)} :
  UnsizedChecker (implication b c) :=
  {| unsizedChecker := implication_unsized C H b c HC |}.

Opaque semProdSize.

#[global]
Program Instance implicationMonotonic
        {C} `{Checkable C} b (c : C) `{SizeMonotonicChecker (checker c)} :
  SizeMonotonicChecker (implication b c).
Next Obligation.
  move : H0 => [/(_ s1 s2 H1) H0].
  rewrite /genChecker in H0 *. rewrite -> !semFmapSize in H0; eauto with typeclass_instances.
  rewrite !semFmapSize.
  rewrite /implication. case : b; eauto.
  apply imset_incl. rewrite !semReturnSize. by move => ? ?; eauto.
Qed.

(* equivalences for other combinators *)

Lemma semReturnGenSize (qp : QProp) (s: nat) :
    semCheckerSize (ret qp) s <-> semCheckableSize qp s.
Proof.
  rewrite /semCheckerSize. split.
  - move =>  H qp' [x [H1 H2]]. apply H. eexists; split; eauto.
  - move => H b [x [H1 H2]] //. apply H => //=. eexists; split; eauto.
Qed.

Lemma semReturnGen (qp : QProp) :
    semChecker (ret qp) <-> semCheckable qp.
Proof.
  split; move => H s.
  - by move /(_ s) /semReturnGenSize : H => //.
  - apply semReturnGenSize; eauto. by apply H.
Qed.

Opaque bind.
Lemma semBindGenSize {A} (gen : G A) (f : A -> Checker) (s: nat):
    semCheckerSize (bind gen f) s <->
    forall a, semProdSize gen s a -> semCheckerSize (f a) s.
Proof.
  unfold semCheckerSize. split.
  - move => H a Hsize b [qp [H1 <-]]. apply H.
    exists qp; split => //=.
    apply (@semBindSize G ProducerGen ProducerSemanticsGen). eexists; split; eauto.
  - move => H b [qp [/semBindSize [a [H1 H2]] <-]]. eapply H; try eassumption.
    eexists; split => //; eauto.
Qed.

Lemma semBindGenUsinzed1 {A} (gen : G A) (f : A -> Checker) `{@Unsized _ _ ProducerGen gen} :
    (semChecker (bindGen gen f) <->
     forall a, semProd gen a -> semChecker (f a)).
Proof.
  split; move => Hgen a.
  - move => [s [_ H']] s'. eapply unsized in H'.
    eapply semBindGenSize in Hgen; eauto.
  - by eapply semBindGenSize; intros; apply Hgen; eexists; split => //; eauto.
Qed.

Lemma semBindGenUsinzed2 {A} (gen : G A) (f : A -> Checker)
      `{forall a, UnsizedChecker (f a)} :
    (semChecker (bindGen gen f) <->
     forall a, semProd gen a -> semChecker (f a)).
Proof.
  split; move => Hgen a.
  - move => [s [_ H']] s'.
    eapply semBindGenSize in Hgen; last by eauto.
    eapply unsizedChecker_alt_def; eauto.
  - by eapply semBindGenSize; intros; apply Hgen; eexists; split => //; eauto.
Qed.

Lemma semBindGenSizeMonotonic {A} (gen : G A) (f : A -> Checker)
  `{@SizeMonotonic _ _ ProducerGen gen}
  `{forall a, SizeMonotonicChecker (f a)} :
  (semChecker (bindGen gen f) <->
   forall a, semProd gen a -> semChecker (f a)).
Proof.
  split; move => Hgen a.
  - move => [s [_ H']] s'. case_eq (s <= s') => [/leP Hleq |
                                                 /leP/Compare_dec.not_le/ltP/ltnW Hleq].
    + specialize (Hgen s').
      eapply semBindGenSize in Hgen; eauto.
      eapply monotonic; eauto.
    + specialize (Hgen s). eapply semBindGenSize in Hgen; eauto.
      eapply monotonicChecker_alt_def; eauto.
  - by eapply semBindGenSize; intros; apply Hgen; eexists; split => //; eauto.
Qed.

Lemma semPredQPropSize (c : Checker) (s : nat) :
    semCheckableSize c s <-> (semCheckerSize c s).
Proof.
  rewrite /semCheckableSize /checker
          /testChecker /checker /testProp /semCheckerSize.
  split; move => Hqp qp Hsize; auto.
Qed.

Lemma semPredQProp (c : Checker) :
    semCheckable c <-> semChecker c.
Proof.
  split => H s; eapply semPredQPropSize; eauto.
Qed.

#[global]
Instance forAllMonotonic {A C} {_ : Checkable C} `{Show A} (g : G A) (f : A -> C)
        `{@SizeMonotonic _ _ ProducerGen g} `{forall x, SizeMonotonicChecker (checker (f x))} :
  SizeMonotonicChecker (forAll g f).
Proof.
Admitted.

Lemma semForAllSize {A C} `{Show A, Checkable C} (g : G A) (f : A -> C) (s:nat) :
  semCheckerSize (forAll g f) s <->
  forall (a : A), a \in semProdSize g s -> semCheckableSize (f a) s.
Proof.
  split=> H'.
  - rewrite /forAll in H'. move/semBindGenSize : H' => H' a /H' Hgen.
      by apply semPrintTestCase_idSize in Hgen.
  - rewrite /forAll in H' *. apply semBindGenSize => g' Hgen.
    rewrite semPrintTestCase_idSize. by apply H'.
Qed.

Lemma semForAllUnsized1 {A C} `{Show A, Checkable C} (g : G A) (f : A -> C)
      `{@Unsized _ _ ProducerGen g} :
  (semChecker (forAll g f) <->
   forall (a : A), a \in semProd g -> semCheckable (f a)).
Proof.
  split=> H'.
  - move => a [s' [_ Hgen]] s. specialize (H' s).
    eapply semForAllSize in H'; first by eauto.
    eapply unsized; eauto.
  - move => s; eapply semForAllSize; move => a Hgen.
    apply H'; eexists; split => //; eauto.
Qed.

Lemma semForAllUnsized2 {A C} `{Show A, Checkable C} (g : G A) (f : A -> C)
      `{forall a, UnsizedChecker (checker (f a))} :
  (semChecker (forAll g f) <->
   forall (a : A), a \in semProd g -> semCheckable (f a)).
Proof.
  split=> H'.
  - move => a [s' [_ Hgen]] s. specialize (H' s').
    eapply semForAllSize in H'; last by eauto.
    by eapply unsizedChecker_alt_def; eauto.
  - move => s; eapply semForAllSize; move => a Hgen.
    apply H'; eexists; split => //; eauto.
Qed.

(* begin semForAllSizeMonotonic *)
Lemma semForAllSizeMonotonic {A C} `{Show A, Checkable C} (g : G A) (f : A -> C)
    `{@SizeMonotonic _ _ ProducerGen g} `{forall a, SizeMonotonicChecker (checker (f a))} :
  (semChecker (forAll g f) <-> forall (a:A), a \in semProd g -> semCheckable (f a)).
(* end semForAllSizeMonotonic *)
Proof.
  split; move => Hcheck a.
  - move => [s [_ H']] s'. case_eq (s <= s') => [/leP Hleq |
                                                 /leP/Compare_dec.not_le/ltP/ltnW Hleq].
    + specialize (Hcheck s').
      rewrite -> semForAllSize in Hcheck. apply Hcheck.
      eapply monotonic; eauto.
    + specialize (Hcheck s). eapply semForAllSize in Hcheck; eauto.
      by eapply monotonicChecker_alt_def; eauto.
  - by eapply semForAllSize; intros; apply Hcheck; eexists; split => //; eauto.
Qed.

Lemma unsized_printTestCase {A C} `{Checkable C} `{Show A} (c : A -> C) :
  (forall a, Unsized (checker (c a))) ->
  (forall a, Unsized (printTestCase (String.append (Show.show a) newline) (c a))).
Proof.
(*   rewrite /UnsizedChecker /unsized. setoid_rewrite semFmapSize. *)
(*   move => H' a s1 s2. specialize (H' a s1 s2). *)
(*   by do 2 rewrite semPrintTestCase_idSize. *)
(* Qed. *)
Abort.

(* alternative definitions
Definition unsizedChecker (c : Checker) : Prop :=
  forall s1 s2, semCheckerSize c s1 <-> semCheckerSize c s2.

(* another characterization of unsizedChecker *)
Lemma unsizedChecker_def2 {A : Type} : forall (c : Checker),
  unsizedChecker c ->
  forall s, semCheckerSize c s <-> semChecker c.
Proof.
  intros. split; intro H'.
  - intro s'. rewrite H. eassumption.
  - by apply H'.
Qed.
*)

(* CH: We could create a super class UCheckable that includes the
       unsized assumption. And we could use sections to hide all the
       type class stuff from the paper. *)
(* CH: This will be affected by upcoming refactoring;
       proving it like this only because it appears in ITP submission *)

(*
Require Import FunctionalExtensionality.

Lemma curry_uncurry {A B C : Type} (f : A -> B -> C) :
  curry (uncurry f) = f.
Proof. apply functional_extensionality => x. reflexivity. Qed.

Lemma uncurry_curry {A B C : Type} (f : A * B -> C) :
  uncurry (curry f) = f.
Proof. apply functional_extensionality. by intros [a b]. Qed.

Lemma mergeBinds' :
  forall A B C (ga : G A) (gb : G B) (f : A * B -> G C),
    semGen (bindGen ga (fun x => bindGen gb ((curry f) x))) <-->
    semGen (bindGen (genPair ga gb) f).
Proof. setoid_rewrite mergeBinds. by setoid_rewrite uncurry_curry. Qed.

Lemma eq_to_impl : forall (a b : Prop), a = b -> a -> b.
Proof. move => a b H. by rewrite H. Qed.

(* CH: could we get rid of this in the RBTree example if we used
   semBindSizeMonotonic instead of semBindUnsized2?  *)
(* CH: The problem with proving this is the silly print in the middle of things.
   There are also some technical problems with setoid_rewriting taking ages,
   and requiring an useless split beforehand.
   ZP: Got rid of setoid_rewrite. The proof goes through instantly now.
*)
Lemma mergeForAlls {A B C : Type} `{Checkable C} `{Show A} `{Show B}
         (ga : G A) (gb : G B) (f : A -> B -> C) :
     semChecker (forAll ga (fun a => forAll gb (f a))) <->
     semChecker (forAll (genPair ga gb) (uncurry f)).
Proof.
  (* ZP : I know that this proof lacks nice point-free reasoning, but it is
          significantly smaller and typechecks much faster that the previous one *)
  split.
  - move => HforAll s. apply semForAllSize;
    move  => [a b] /= /semLiftGen2Size [[a' b'] [[/= Hg1 Hg2] [Heq1 Heq2]]]; subst.
    specialize (HforAll s). eapply semForAllSize in HforAll.
    by eapply semForAllSize in HforAll; eauto. by eauto.
  - move => HforAll s. apply semForAllSize => a Hgena.
    apply semForAllSize => b Hgenb.
    specialize (HforAll s).
    move /semForAllSize/(_ (a, b)) : HforAll => /= HforAll. apply HforAll.
    apply semLiftGen2Size. exists (a, b); split => //; eauto.
Qed.
 *)

Lemma semForAllShrinkSize:
  forall {A C} `{Checkable C} `{Show A}
         (gen : G A) (f : A -> C) shrinker (size: nat),
    semCheckerSize (forAllShrink gen shrinker f) size <->
    forall a : A, semProdSize gen size a -> semCheckableSize (f a) size.
Proof.
  move => A C H show gen pf shrink. split.
  - rewrite /forAllShrink semBindGenSize.
    move=> H' a /H' Hgen. setoid_rewrite semShrinking_idSize in Hgen.
    setoid_rewrite semPredQPropSize in Hgen.
    by apply semPrintTestCase_idSize in Hgen.
  - move=> H'. rewrite /forAllShrink semBindGenSize. move => a g.
    rewrite semShrinking_idSize. apply semPredQPropSize.
    rewrite semPrintTestCase_idSize. by auto.
Qed.

Lemma semForAllShrinkUnsized1 :
  forall {A C} `{Checkable C} `{Show A}
         (gen : G A) (f : A -> C) shrinker `{@Unsized _ _ ProducerGen gen},
    (semChecker (forAllShrink gen shrinker f) <->
     forall a : A, semProd gen a -> semCheckable (f a)).
Proof.
  split=> H'.
  - move => a [s' [_ Hgen]] s. specialize (H' s).
    eapply semForAllShrinkSize in H'; first by eauto.
    eapply H1; eauto.
 - move => s; eapply semForAllShrinkSize; move => a Hgen.
    apply H'; eexists; split => //; eauto.
Qed.

Lemma semForAllShrinkUnsized2 :
  forall {A C} `{Checkable C} `{Show A}
         (gen : G A) (f : A -> C) shrinker
  `{forall a, UnsizedChecker (checker (f a))},
  (semChecker (forAllShrink gen shrinker f) <->
     forall a : A, semProd gen a -> semCheckable (f a)).
Proof.
  split=> H'.
  - move => a [s' [_ Hgen]] s. specialize (H' s').
    eapply semForAllShrinkSize in H'; last by eauto.
    eapply unsizedChecker_alt_def; eauto.
  - move => s; eapply semForAllShrinkSize; move => a Hgen.
    apply H'; eexists; split => //; eauto.
Qed.

Lemma semForAllShrinkMonotonic :
  forall {A C} `{Checkable C} `{Show A}
         (gen : G A) (f : A -> C) shrinker `{@SizeMonotonic _ _ ProducerGen gen},
  (forall a, SizeMonotonicChecker (checker (f a))) ->
  (semChecker (forAllShrink gen shrinker f) <->
     forall a : A, semProd gen a -> semCheckable (f a)).
Proof.
  move => A C H1 H2 gen f sh Hmon1 Hmon2.
  split; move => Hcheck a.
  - move => [s [_ H']] s'. case_eq (s <= s') => [/leP Hleq |
                                                 /leP/Compare_dec.not_le/ltP/ltnW Hleq].
    + specialize (Hcheck s').
      rewrite -> semForAllShrinkSize in Hcheck. apply Hcheck.
      by eapply Hmon1; eauto.
    + specialize (Hcheck s). eapply semForAllShrinkSize in Hcheck; eauto.
      by eapply monotonicChecker_alt_def; eauto.
  - by eapply semForAllShrinkSize; intros; apply Hcheck; eexists; split => //; eauto.
Qed.

Lemma bool_successful :
  forall b, resultSuccessful (liftBool b) = b.
Proof.
  intros. destruct b; auto.
Qed.

Lemma semCheckableBoolSize (b : bool) size : semCheckableSize b size <-> b.
Proof.
  rewrite /semCheckableSize /semCheckerSize /checker /testBool.
  split.
  - move => /(_ b) H.
    suff : [set true] b by move => <- //.
    eapply H. eexists (MkProp (MkRose (liftBool b) (lazy nil))).
    split. simpl. by rewrite -> (semReturnSize _ _ _). by eapply bool_successful.
  - move => Hb b' [qp [/semReturnSize <- <-]] /=.
    by rewrite bool_successful.
Qed.

(* begin semCheckableBool *)
Lemma semCheckableBool (b : bool) : semCheckable b <-> b.
(* end semCheckableBool *)
Proof.
  (* CH: brute-force, please fix
     ZP : better now? We do case analysis on b bun in a lemma;
          I don't think we can avoid it *)
  split; [move => /(_ 0) H | move => H s];
    eapply semCheckableBoolSize; eauto.
  (* LEO: TODO: Why? *)
  Unshelve.
  constructor.
Qed.

#[global]
Program Instance boolUnsized (b : bool) : UnsizedChecker (checker b).
Next Obligation.
  rewrite !semFmapSize !semReturnSize. apply imset_eq. reflexivity.
Qed.

Opaque ret.
Lemma semCheckableResultSize:
  forall (res: Result) (size: nat),
    semCheckableSize res size <-> resultSuccessful res.
Proof.
  rewrite /semCheckableSize.
  rewrite /checker.
  rewrite /testResult.
  move => res size. split.
  - move => /(_ (resultSuccessful res)) H.
    suff : [set true] (resultSuccessful res) by move <-.
    apply H. eexists.
    split.
    + apply @semReturnSize; eauto with typeclass_instances.
      reflexivity.
    + reflexivity.
  - move => H b [qp' [/semReturnSize <- <-]] //=.
Qed.

Lemma semCheckableResult :
  forall (res: Result),
    semCheckable res  <-> resultSuccessful res.
Proof.
  split; [move => /(_ 0) H | move => H s]; eapply semCheckableResultSize; eauto.
  Unshelve.
  constructor.
Qed.

#[global]
Program Instance resultUnsized (r : Result) : UnsizedChecker (checker r).
Next Obligation.
  rewrite !semFmapSize !semReturnSize. apply imset_eq. reflexivity.
Qed.

Lemma semCheckableUnitSize (t : unit) size : semCheckableSize t size <-> True.
Proof.
  split => // _ qp [qp' [/semReturnSize <- <-]] //.
Qed.

Lemma semCheckableUnit (t : unit) : semCheckable t <-> True.
Proof.
  split; [move => /(_ 0) H | move => H s]; eapply semCheckableUnitSize; eauto.
  Unshelve.
  constructor.
  constructor.
Qed.

#[global]
Program Instance unitUnsized : UnsizedChecker (checker tt).
Next Obligation.
  rewrite !semFmapSize !semReturnSize. apply imset_eq. reflexivity.
Qed.

Lemma semCheckableQPropSize (qp : QProp) size :
  semCheckableSize qp size <-> successful qp.
Proof.
  rewrite /semCheckableSize /checker /testProp.
  split.
  - move => /(_ (successful qp)) H.
    suff : ([set true] (successful qp)) by move => <-.
    apply H. eexists. split ; last by reflexivity.
    apply @semReturnSize; eauto with typeclass_instances.
    reflexivity.
  - move => H b [qp' [/semReturnSize <- <-]] //=.
Qed.

Lemma semCheckableQProp (qp : QProp) :
  semCheckable qp  <-> successful qp.
Proof.
  split; [move => /(_ 0) H | move => H s]; eapply semCheckableQPropSize; eauto.
  Unshelve.
  constructor.
Qed.

#[global]
Program Instance qpUnsized (qp : QProp) : UnsizedChecker (checker qp).
Next Obligation.
  rewrite !semFmapSize !semReturnSize. apply imset_eq. reflexivity.
Qed.

Lemma semCheckableGenSize:
  forall (P : Type) {H : Checkable P} (gen: G P) (size : nat),
    (semCheckableSize gen size) <->
    (forall p, semProdSize gen size p -> semCheckableSize p size).
Proof.
  move=> P H gen s. rewrite /semCheckableSize /checker /testGenProp. split.
  - move => /semBindGenSize Hcheck p Hgen //=; eauto.
  - move => Hcheck. apply semBindGenSize => a Hgen; eauto.
Qed.

(* Leo: Finish.
Lemma semCheckableFunSize:
  forall {A C} {H1 : Show A} `{H2 : Arbitrary A} {H3 : Checkable C}
         (f : A -> C) (size: nat),
    semCheckableSize f size <->
    forall (a : A), semProdSize arbitrary size a -> semCheckableSize (f a) size.
Proof.
  move=> A C H1 H2 H3 f.
  rewrite /semCheckable /checker /testFun.
  split.
  - move => /semForAllShrinkSize H' a' /H' Gen. by auto.
  - move => H'.

    apply (@semForAllShrinkSize _ _ H0 H1 (@arbitrary _ H2) (@shrink _ H3)). => a' /H' Hgen. by auto.
Qed.

Lemma semCheckablePolyFunSize:
  forall {C : Type -> Type} {H : Checkable (C nat)} (f : forall T, C T)
         (size : nat),
    (semCheckableSize f size) <-> (semCheckableSize (f nat) size).
Proof.
  move => C H f s. rewrite /semCheckableSize {2}/checker /testPolyFun.
  by rewrite semPrintTestCase_idSize.
Qed.

Lemma semCheckablePolyFunSetSize:
  forall {C : Set -> Type} {H : Checkable (C nat)} (f : forall T, C T) (size: nat),
    (semCheckableSize f size) <->  (semCheckableSize (f nat) size).
Proof.
  move => C H f s. rewrite /semCheckableSize {2}/checker /testPolyFun.
  by rewrite semPrintTestCase_idSize.
Qed.

#[global]
Program Instance uncurryUsized {A B} (f : A -> B -> Checker) p
        `{UnsizedChecker (f (fst p) (snd p))} : UnsizedChecker (uncurry f p).
Next Obligation. by apply unsizedChecker. Qed.

(* A typeclass so we can automate the application of the previous theorems
   and get a readable Prop *)

Class Provable (A : Type) {H: Checkable A} : Type :=
 {
    proposition : nat -> A -> Prop;
    proposition_equiv : forall a s, proposition s a <-> semCheckableSize a s
  }.

#[global]
Program Instance proveResult : Provable Result :=
  {|
    proposition s r := resultSuccessful r
  |}.
Next Obligation.
  by rewrite semCheckableResultSize.
Qed.

#[global]
Program Instance proveUnit : Provable unit :=
  {|
    proposition := fun _ _ => True
  |}.
Next Obligation.
  by rewrite semCheckableUnitSize.
Qed.

#[global]
Program Instance proveQProp : Provable QProp :=
  {|
    proposition s qp := successful qp = true
  |}.
Next Obligation.
  by rewrite semCheckableQPropSize.
Qed.

#[global]
Program Instance proveBool : Provable bool :=
  {|
    proposition s b :=  b = true
  |}.
Next Obligation.
  by rewrite semCheckableBoolSize.
Qed.

#[global]
Program Instance proveGenProp {C} `{Provable C} :
  Provable (G C) :=
  {|
    proposition s g := (forall p, semProdSize g s p -> proposition s p)
  |}.
Next Obligation.
  destruct H0 as [semP proof]. rewrite /proposition. split.
  - move => H'. apply semCheckableGenSize => p Hgen. apply proof. eapply H'. eassumption.
  - move => /semCheckableGenSize H' p Hgen. eapply proof. apply H'. by auto.
Qed.

#[global]
Program Instance proveChecker : Provable Checker :=
  {|
    proposition s g := semCheckerSize g s
  |}.
Next Obligation.
  split; intros H; by apply semPredQPropSize.
Qed.

#[global]
Program Instance proveFun {A C: Type} `{Arbitrary A} `{Show A}
        `{Provable C}: Provable (A -> C) :=
  {|
    proposition s p :=
      (forall a,
         semProdSize arbitrary s a ->
         proposition s (p a))
  |}.
Next Obligation.
  match goal with
    | [ Hyp : Provable _ |- _ ] => destruct Hyp as [semP proof]
  end. rewrite /proposition. split.
  - move=> H'. apply semCheckableFunSize => a' /H' Hgen.
    by apply proof.
  - move=> H' a' Hgen. apply proof. by apply semCheckableFunSize.
Qed.

#[global]
Program Instance provePolyFun {C : Type -> Type} `{Provable (C nat)} :
  Provable (forall T, C T) :=
  {
    proposition s f := proposition s (f nat)
  }.
Next Obligation.
  destruct H0 as [semP proof]. rewrite /proposition. split.
  - move=> /proof H'. by apply semCheckablePolyFunSize.
  - move=> /semCheckablePolyFunSize H'. by apply proof.
Qed.

#[global]
Program Instance provePolyFunSet {C : Set -> Type} `{Provable (C nat)} :
  Provable (forall T, C T) :=
  {
    proposition s f := proposition s (f nat)
  }.
Next Obligation.
  destruct H0 as [semP proof]. rewrite /proposition. split.
  - move=> /proof H'. by apply semCheckablePolyFunSetSize.
  - move=> /semCheckablePolyFunSetSize H'. by apply proof.
Qed.
*)