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 B C D Aprime Bprime Cprime Dprime X Y E Z Eprime : Universe, ((wd_ X A /\ (wd_ X Aprime /\ (wd_ X C /\ (wd_ X Cprime /\ (wd_ Y B /\ (wd_ Y Bprime /\ (wd_ Y D /\ (wd_ Y Dprime /\ (wd_ A C /\ (wd_ B D /\ (wd_ A Aprime /\ (wd_ B Bprime /\ (wd_ C Cprime /\ (wd_ D Dprime /\ (wd_ Aprime Cprime /\ (wd_ Bprime Dprime /\ (wd_ A E /\ (wd_ Aprime Eprime /\ (wd_ B E /\ (wd_ Bprime Eprime /\ (wd_ Y A /\ (wd_ A B /\ (wd_ X B /\ (wd_ Aprime Dprime /\ (wd_ Dprime Eprime /\ (wd_ A D /\ (wd_ D E /\ (wd_ A Eprime /\ (wd_ E Aprime /\ (wd_ E Eprime /\ (wd_ Y E /\ (wd_ Y Z /\ (wd_ B Z /\ (wd_ E Z /\ (wd_ X E /\ (wd_ X Z /\ (wd_ A Z /\ (wd_ X Y /\ (wd_ B C /\ (wd_ Bprime Cprime /\ (wd_ Aprime Bprime /\ (col_ X A C /\ (col_ X A Aprime /\ (col_ X A Cprime /\ (col_ Y B D /\ (col_ Y B Bprime /\ (col_ Y B Dprime /\ (col_ E A B /\ (col_ E C D /\ (col_ Eprime Aprime Bprime /\ (col_ Eprime E Z /\ (col_ B Bprime Eprime /\ col_ E Bprime Eprime)))))))))))))))))))))))))))))))))))))))))))))))))))) -> col_ Bprime Aprime B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Program.Basics.
Require Import Coq.Strings.String.
Require Import Setoid.
Require Import ZArith.
Require Import Coq.Program.Equality.
Require Import Lia.
Require Import Ascii.

Require Import FinProof.All.

Require Import UMLang.All.
Require Import UMLang.LocalClassGenerator.ClassGenerator.
Require Import UMLang.GlobalClassGenerator.ClassGenerator.

Require Import UrsusStdLib.Solidity.All.
Require Import UrsusStdLib.Solidity.unitsNotations.
Require Import UrsusTVM.Solidity.All.

Import UrsusNotations.
Local Open Scope xlist_scope.
Local Open Scope record.
Local Open Scope program_scope.
Local Open Scope glist_scope.
Local Open Scope ursus_scope.
Local Open Scope usolidity_scope.

From elpi Require Import elpi.

Local Open Scope struct_scope.
Local Open Scope N_scope.
Local Open Scope string_scope.
Require Import SetcodeMultisig.

Require Import UMLang.ExecGenerator.
Require Import UMLang.ExecGen.GenFlags.
Require Import UMLang.ExecGen.ExecGenDefs.
Require Import FinProof.CommonInstances.

Require Import CommonQCEnvironment.
Require Import SetcodeMultisig_LocalState.
Require Import CommonForProps.

Definition dummyTransaction : TransactionLRecord := Eval compute in default.

Definition REU_1 l id (codeHash :  option uint256) (owners :  optional (listArray uint256)) (reqConfirms : optional uint8) (lifetime :  optional   uint32) : Prop :=
  let m_lifetime := uint2N (toValue (eval_state (sRReader (m_lifetime_right rec def) ) l)) in
  let tvm_now := uint2N (toValue (eval_state (sRReader || now ||) l)) in
  let l' := exec_state (Uinterpreter (_removeExpiredTransactions rec def)) l in
  let ret_l := exec_state (Uinterpreter (_removeExpiredUpdateRequests rec def)) l in
  let m_updateRequests := toValue (eval_state (sRReader (m_updateRequests_right rec def) ) l) in
  let m_updateRequests' := toValue (eval_state (sRReader (m_updateRequests_right rec def) ) ret_l) in
  let m_updateRequestsMask := toValue (eval_state (sRReader (m_updateRequestsMask_right rec def) ) ret_l) in
  isError (eval_state (Uinterpreter (submitUpdate rec def codeHash owners reqConfirms lifetime)) l) = false ->
  hmapIsMember id m_updateRequests = true ->
  N.shiftr 32 (uint2N id) + m_lifetime <= tvm_now <->
  hmapIsMember id m_updateRequests = true /\
  hmapIsMember id m_updateRequests' = false /\
  N.shiftl (uint2N id) (uint2N m_updateRequestsMask) = 0.

Definition CUR_1 l (codeHash : optional uint256) (owners : optional (listArray uint256)) (reqConfirms : optional uint8) (lifetime :  optional   uint32) : Prop :=
  let custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
  let msgPubkey := toValue (eval_state (sRReader || msg->pubkey() ||) l) in
  correctState l ->
  isError (eval_state (Uinterpreter (submitUpdate rec def codeHash owners reqConfirms lifetime)) l) = false ->
  hmapIsMember msgPubkey custodians = true \/
  xMaybeIsSome owners = false.

Definition CUR_2 l (codeHash : optional uint256) (owners : optional (listArray uint256)) (reqConfirms : optional uint8) (lifetime :  optional   uint32) : Prop :=
  correctState l ->
  isError (eval_state (Uinterpreter (submitUpdate rec def codeHash owners reqConfirms lifetime)) l) = false ->
  (xMaybeIsSome codeHash = true ->
  xMaybeIsSome owners = true /\
  length_ (xMaybeMapDefault Datatypes.id owners default) > 0) \/
  (xMaybeIsSome owners = true ->
  length_ (xMaybeMapDefault Datatypes.id owners default) > 0).

Definition CUR_3 l (codeHash : optional uint256) (owners : optional (listArray uint256)) (reqConfirms : optional uint8) (lifetime :  optional   uint32) : Prop :=
  let MAX_CUSTODIAN_COUNT := uint2N (toValue (eval_state (sRReader (MAX_CUSTODIAN_COUNT_right rec def) ) l)) in
  correctState l ->
  isError (eval_state (Uinterpreter (submitUpdate rec def codeHash owners reqConfirms lifetime)) l) = false ->
  (xMaybeIsSome codeHash = true ->
  xMaybeIsSome owners = true /\
  length_ (xMaybeMapDefault Datatypes.id owners default) <= MAX_CUSTODIAN_COUNT) \/
  (xMaybeIsSome owners = true ->
  length_ (xMaybeMapDefault Datatypes.id owners default) <= MAX_CUSTODIAN_COUNT).

Definition CUR_4 id l (codeHash : optional uint256) (owners : optional (listArray uint256)) (reqConfirms : optional uint8) (lifetime :  optional   uint32) : Prop :=
  let MAX_CUSTODIAN_COUNT := uint2N (toValue (eval_state (sRReader (MAX_CUSTODIAN_COUNT_right rec def) ) l)) in
  let custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
  let msgPubkey := toValue (eval_state (sRReader || msg->pubkey() ||) l) in
  let l' := exec_state (Uinterpreter (submitUpdate rec def codeHash owners reqConfirms lifetime)) l in
  let transactions := toValue (eval_state (sRReader (m_transactions_right rec def) ) l') in
  correctState l ->
  xMaybeIsSome codeHash = true ->
  isError (eval_state (Uinterpreter (submitUpdate rec def codeHash owners reqConfirms lifetime)) l) = false ->
  hmapIsMember msgPubkey custodians = true ->
  xMaybeIsSome owners = true ->
  length_ (xMaybeMapDefault Datatypes.id owners default) > 0 ->
  length_ (xMaybeMapDefault Datatypes.id owners default) <= MAX_CUSTODIAN_COUNT ->
  hmapIsMember id transactions = true ->
  REU_1 l' id codeHash owners reqConfirms lifetime.

Definition CUR_5 l id (codeHash : optional uint256) (owners : optional (listArray uint256)) (reqConfirms : optional uint8) (lifetime :  optional   uint32) : Prop :=
  let MAX_CUSTODIAN_COUNT := uint2N (toValue (eval_state (sRReader (MAX_CUSTODIAN_COUNT_right rec def) ) l)) in
  let custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
  let msgPubkey := toValue (eval_state (sRReader || msg->pubkey() ||) l) in
  let l' := exec_state (Uinterpreter (submitUpdate rec def codeHash owners reqConfirms lifetime)) l in
  let m_updateRequestsMask := (uint2N (toValue (eval_state (sRReader (m_updateRequestsMask_right rec def) ) l'))) in
  let transactions := toValue (eval_state (sRReader (m_transactions_right rec def) ) l') in
  correctState l ->
  isError (eval_state (Uinterpreter (submitUpdate rec def codeHash owners reqConfirms lifetime)) l) = false ->
  hmapIsMember msgPubkey custodians = true ->
  xMaybeIsSome owners = true ->
  length_ (xMaybeMapDefault Datatypes.id owners default) > 0 ->
  length_ (xMaybeMapDefault Datatypes.id owners default) <= MAX_CUSTODIAN_COUNT ->
  hmapIsMember id transactions = true ->
  REU_1 l' id codeHash owners reqConfirms lifetime ->
  N.land m_updateRequestsMask (uint2N id) = 0.

(* CUR_6_1 checked as part of correctState *)

Definition CUR_6_2 l (codeHash : optional uint256) (owners : optional (listArray uint256)) (reqConfirms : optional uint8) (lifetime :  optional  ( uint32 )) : Prop :=
  let MAX_CUSTODIAN_COUNT := uint2N (toValue (eval_state (sRReader (MAX_CUSTODIAN_COUNT_right rec def) ) l)) in
  let custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
  let updateRequestMask := toValue (eval_state (sRReader (m_updateRequestsMask_right rec def) ) l) in
  let msgPubkey := toValue (eval_state (sRReader || msg->pubkey() ||) l) in
  let i := uint2N (hmapFindWithDefault (Build_XUBInteger 0) msgPubkey custodians) in
  let requests := toValue (eval_state (sRReader (m_updateRequests_right rec def) ) l) in
  let bit := N.land (N.shiftr (uint2N updateRequestMask) i) 1 in
  let lifetime' := uint2N (toValue (eval_state (sRReader (m_lifetime_right rec def) ) l)) in
  let tvm_now := uint2N (toValue (eval_state (sRReader || now ||) l)) in
  let expired := xHMapFilter (fun k v =>
    let index := uint2N (getPruvendoRecord UpdateRequest_ι_index v) in
    andb (N.eqb index i) (N.leb ((N.shiftr (uint2N k) 32) + lifetime') tvm_now)
  ) requests in
  correctState l ->
  hmapIsMember msgPubkey custodians = true ->
  (xMaybeIsSome owners = true ->
    length_ (xMaybeMapDefault Datatypes.id owners default) > 0 /\
    length_ (xMaybeMapDefault Datatypes.id owners default) <= MAX_CUSTODIAN_COUNT
  ) ->
  (xMaybeIsSome owners = false ->
   xMaybeIsSome codeHash = false) ->
  (bit = 0 \/ length_ expired > 0) ->
  isError (eval_state (Uinterpreter (submitUpdate rec def codeHash owners reqConfirms lifetime)) l) = false
  .

Definition dummyRequest : UpdateRequestLRecord := Eval compute in default.

Definition CUR_6_3 l (codeHash : optional uint256) (owners : optional (listArray uint256)) (reqConfirms : optional uint8) (lifetime :  optional  ( uint32 )) : Prop :=
  let l' := exec_state (Uinterpreter (submitUpdate rec def codeHash owners reqConfirms lifetime)) l in
  let custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
  let msgPubkey := toValue (eval_state (sRReader || msg->pubkey() ||) l) in
  let i := uint2N (hmapFindWithDefault (Build_XUBInteger 0) msgPubkey custodians) in
  let requests := toValue (eval_state (sRReader (m_updateRequests_right rec def) ) l) in
  let requests' := toValue (eval_state (sRReader (m_updateRequests_right rec def) ) l') in
  let lifetime_old := uint2N (toValue (eval_state (sRReader (m_lifetime_right rec def) ) l)) in
  let tvm_now := uint2N (toValue (eval_state (sRReader || now ||) l)) in
  let newRequests := xHMapFilter (fun k v =>
    negb (hmapIsMember k requests)
  ) requests' in
  let expiredRequests := xHMapFilter (fun k v =>
    N.leb ((N.shiftr (uint2N k) 32) + lifetime_old) tvm_now
  ) requests in
  let commonRequests := xHMapFilter (fun k v =>
    andb (hmapIsMember k requests)
    (Common.eqb v (hmapFindWithDefault dummyRequest k requests
  ))) requests' in
  let request := snd (hd (Build_XUBInteger 0, dummyRequest) (unwrap newRequests)) in
  let index := getPruvendoRecord UpdateRequest_ι_index request in
  let signs := getPruvendoRecord UpdateRequest_ι_signs request in
  let creator := getPruvendoRecord UpdateRequest_ι_creator request in
  let codeHash' := getPruvendoRecord UpdateRequest_ι_codeHash request in
  let owners' := getPruvendoRecord UpdateRequest_ι_custodians request in
  let reqConfirms' := getPruvendoRecord UpdateRequest_ι_reqConfirms request in
  let lifetime' := getPruvendoRecord UpdateRequest_ι_lifetime request in
  let mask := getPruvendoRecord UpdateRequest_ι_confirmationsMask request in
  let updateRequestMask := uint2N (toValue (eval_state (sRReader (m_updateRequestsMask_right rec def) ) l')) in
  correctState l ->
  isError (eval_state (Uinterpreter (submitUpdate rec def codeHash owners reqConfirms lifetime)) l) = false ->
  length_ newRequests = 1 /\
  uint2N index = i /\
  uint2N signs = 1 /\
  creator = msgPubkey /\
  (* TODO: codeHash' = codeHash /\ *) owners' = owners /\
  reqConfirms' = reqConfirms /\ lifetime' = lifetime /\
  uint2N mask = N.shiftl 1 i /\
  N.land (N.shiftr updateRequestMask i) 1 = 1 /\
  length_ requests' = length_ requests + 1 - length_ expiredRequests /\
  length_ commonRequests = length_ requests - length_ expiredRequests.

Definition CUR_7 l id (codeHash : optional uint256) (owners : optional (listArray uint256)) (reqConfirms : optional uint8) (lifetime :  optional   uint32) : Prop :=
  let custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
  let l' := exec_state (Uinterpreter (submitUpdate rec def codeHash owners reqConfirms lifetime)) l in
  let transactions := toValue (eval_state (sRReader (m_transactions_right rec def) ) l') in
  correctState l ->
  isError (eval_state (Uinterpreter (submitUpdate rec def codeHash owners reqConfirms lifetime)) l) = true ->
  hmapIsMember id transactions = true ->
  REU_1 l' id codeHash owners reqConfirms lifetime \/
  ledgerEqb l l' = true.


Require Import Coq.ZArith.ZArith.
Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Require Import Rewriter.Language.Wf.
Require Import Crypto.Language.WfExtra.
Require Import Crypto.Rewriter.AllTacticsExtra.
Require Import Crypto.Rewriter.RulesProofs.

Module Compilers.
  Import Language.Compilers.
  Import Language.API.Compilers.
  Import Language.Wf.Compilers.
  Import Language.WfExtra.Compilers.
  Import Rewriter.AllTacticsExtra.Compilers.RewriteRules.GoalType.
  Import Rewriter.AllTactics.Compilers.RewriteRules.Tactic.
  Import Compilers.Classes.

  Module Import RewriteRules.
    Section __.
      Definition VerifiedRewriterAddAssocLeft : VerifiedRewriter_with_args false false true add_assoc_left_rewrite_rules_proofs.
      Proof using All. make_rewriter. Defined.

      Definition default_opts := Eval hnf in @default_opts VerifiedRewriterAddAssocLeft.
      Let optsT := Eval hnf in optsT VerifiedRewriterAddAssocLeft.

      Definition RewriteAddAssocLeft (opts : optsT) {t : API.type} := Eval hnf in @Rewrite VerifiedRewriterAddAssocLeft opts t.

      Lemma Wf_RewriteAddAssocLeft opts {t} e (Hwf : Wf e) : Wf (@RewriteAddAssocLeft opts t e).
      Proof. now apply VerifiedRewriterAddAssocLeft. Qed.

      Lemma Interp_RewriteAddAssocLeft opts {t} e (Hwf : Wf e) : API.Interp (@RewriteAddAssocLeft opts t e) == API.Interp e.
      Proof. now apply VerifiedRewriterAddAssocLeft. Qed.
    End __.
  End RewriteRules.

  Module Export Hints.
#[global]
    Hint Resolve Wf_RewriteAddAssocLeft : wf wf_extra.
#[global]
    Hint Opaque RewriteAddAssocLeft : wf wf_extra interp interp_extra rewrite.
#[global]
    Hint Rewrite @Interp_RewriteAddAssocLeft : interp interp_extra.
  End Hints.
End Compilers.


(** * State and Error Monad *)

Require Import String.
Require Import List.
Require Import ListDep.

Section StateAndErrMonad.

  (* A state type *)

  Variable state : Type.

  (* The value returned by a state-and-error monad can either
     be an error with a message or a couple state-value.
   *)

  Inductive Res (A: Type) : Type :=
  | Error: string -> Res A
  | OK: A -> state -> Res A.

  Arguments OK {A}.
  Arguments Error {A}.

  Definition Mon (A : Type) : Type := forall s : state, Res A.

  Definition Ret {A : Type} : A -> Mon A := fun x s => OK x s.
  Definition Err {A: Type} (msg: string) : Mon A := fun (s: state) => Error msg.

  Definition Bind {A B : Type} : Mon A -> (A -> Mon B) -> Mon B :=
    fun c1 c2 s1 =>
      match c1 s1 with
      | Error msg => Error msg
      | OK x s2 =>
        match c2 x s2 with
        | Error msg => Error msg
        | OK y s3 => OK y s3
        end
      end.

  Definition Bind2 {A B C: Type} (f : Mon (A * B)) (g : A -> B -> Mon C) : Mon C :=
    Bind f (fun xy => g (fst xy) (snd xy)).

  Definition Get : Mon state := fun s => OK s s.
  Definition Put : state -> Mon unit := fun s _ => OK tt s.

End StateAndErrMonad.

Arguments OK {state A}.
Arguments Error {state A}.
Arguments Mon {state}.
Arguments Err {state A}.
Arguments Ret {state A}.
Arguments Bind {state A B}.
Arguments Get {state}.
Arguments Put {state}.

Notation "'do' X <- A ; B" := (Bind A (fun X => B))
                                (at level 200, X name, A at level 100, B at level 200).

Notation "'do' '|(' X , Y ')|' <- A ; B" := (Bind2 A (fun X Y => B))
   (at level 200, X name, Y name, A at level 100, B at level 200).

Notation "'RedS' r" := match r with
                     | OK _ s => inl s
                     | Error msg => inr msg
                       end (at level 0).

Notation "'RedV' r" := match r with
                     | OK v _ => inl v
                     | Error msg => inr msg
                     end (at level 0).


(*
 * Copyright (c) 2009-2010, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

Require Import msl.base.
Require Import msl.sepalg.
Require Import msl.sepalg_generators.
Require Import msl.psepalg.

(* This file defines a series of lemmas for proving functions from the carrier set
   of one SA to the carrier set of another are join homomorphisms, and then shows
   that some simple properties of SA elems, like identity, comparability, etc.,
   are preserved by join homs.  The idea is due to Rob.
*)

(* Two-argument join homomorphisms *)
Section join_hom2.
  Variables (A B C: Type)
            (JA: Join A)
            (JB: Join B)
            (JC: Join C)
            (f: A -> B -> C).

  Definition join_hom2 := forall (a1 a2 a3: A)(b1 b2 b3: B),
      join a1 a2 a3
      -> join b1 b2 b3
      -> join (f a1 b1) (f a2 b2) (f a3 b3).

  (* Two-argument join homomorphisms with a dummy argument *)
  Definition join_hom2' := forall (a1 a2 a3: A)(b1 b2 b3: B),
      join a1 a2 a3
      -> join (f a1 b1) (f a2 b2) (f a3 b3).
End join_hom2.

Arguments join_hom2 [A B C JA JB JC] _.
Arguments join_hom2' [A B C JA] _ _.

(* [id] is join hom *)
  Lemma join_hom_id (A: Type) (JA: Join A) : join_hom (fun x => x).
  Proof. unfold join_hom; auto. Qed.

(* Product SA
   Join hom functions on products *)
Section join_hom_prod.
  Variables (A A' B B': Type)
            (JA: Join A) (JA': Join A')
            (JB: Join B)  (JB': Join B')
            (f: A -> A') (g: B -> B')
            (join_hom_f: join_hom f)
            (join_hom_g: join_hom g).

  Lemma join_hom2_pair: join_hom2 (fun a b => (f a, g b)).
  Proof. firstorder. Qed.

  Lemma join_hom2_pair' : join_hom2 (fun (a: A) (b: B) => (a, b)).
  Proof. firstorder. Qed.

  (* The function from [(a,b)] to [(a',b')] *)
  Lemma join_hom_prod : join_hom (fun p => (f (fst p), g (snd p))).
  Proof. unfold join_hom; firstorder. Qed.

  (* The function from [a] to [(a', e)] *)
  Lemma join_hom_prodA
    : forall e: B', join e e e -> join_hom (fun a :A => (f a, e)).
  Proof.
    unfold join_hom in *; intros; simpl; split; auto.
    simpl; auto.
  Qed.

  Lemma join_hom_prodA'
    : forall e: B, join e e e -> join_hom (fun a :A'  => (a, e)).
  Proof.
    unfold join_hom in *; split; simpl; auto.
  Qed.

  (* The function from [b] to [(e, b')] *)
  Lemma join_hom_prodB
    : forall e: A', join e e e -> join_hom (fun b: B => (e, g b)).
  Proof.
    unfold join_hom in *; split; simpl; auto.
  Qed.

  Lemma join_hom_prodB'
    : forall e: A, join e e e -> join_hom (fun b : B' => (e, b)).
  Proof.
    unfold join_hom in *; simpl; split; auto.
  Qed.

  (* Projections are join hom. *)
  Lemma join_hom_proj1
    : join_hom (fun p: A*B => fst p).
  Proof. unfold join_hom; firstorder. Qed.

  Lemma join_hom_proj2
    : join_hom (fun p : A*B => snd p).
  Proof. unfold join_hom; firstorder. Qed.
End join_hom_prod.

Arguments join_hom2_pair [A A' B B' JA JA' JB JB'] _ _ _ _ _ _ _ _ _ _ _ _.
Arguments join_hom2_pair' [A B JA JB] _ _ _ _ _ _ _ _.
Arguments join_hom_prodA [A] _ [B' JA] _ [JB'] _ _ _ _ _ _ _ _.
Arguments join_hom_prodA' [A' B JA' JB] _ _ _ _ _ _.
Arguments join_hom_prodB [A' B] _ [JA' JB] _ _ _ _ _ _ _ _ _.
Arguments join_hom_prodB' [A B' JA JB'] _ _ _ _ _ _.
Arguments join_hom_proj1 [A B JA JB] _ _ _ _.
Arguments join_hom_proj2 [A B JA JB] _ _ _ _.

(* Disjoint Sum SA *)
Section join_hom_disjoint_sum.
  Variables (A A' B B': Type)
            (JA: Join A) (JA': Join A')
            (JB: Join B) (JB': Join B')
            (f: A -> A') (g: B -> B')
            (join_hom_f: join_hom f)
            (join_hom_g: join_hom g).
(*
   Definition saAorB := sa_sum saA saB.
  Definition saA'orB' := sa_sum saA' saB'.
*)
  Lemma join_hom_sum
    : join_hom (fun s: A+B =>
        match s with
          | inl x => inl _ (f x)
          | inr y => inr _ (g y)
        end).
  Proof.
    unfold join_hom.
    destruct x; destruct y; destruct z; firstorder.
  Qed.

  Lemma join_hom_sum_l
    : join_hom (fun s: A+B =>
        match s with
          | inl x => inl _ (f x)
          | inr y => inr _ y
        end).
  Proof.
    unfold join_hom.
    destruct x; destruct y; destruct z; firstorder.
  Qed.

  Lemma join_hom_sum_r
    : join_hom (fun s: A+B =>
        match s with
          | inl x => inl _ x
          | inr y => inr _ (g y)
        end).
  Proof.
    unfold join_hom.
    destruct x; destruct y; destruct z; firstorder.
  Qed.

  Lemma join_hom_inj_l
    : join_hom (fun a : A=> inl Void (f a)).
  Proof. firstorder. Qed.

  Lemma join_hom_inj_r
    : join_hom (fun b => inr Void (g b)).
  Proof. firstorder. Qed.

  (* Bijection between [A+unit] and [option A], for convenience later on *)
  Definition sa_sum_option (s: A+unit): option A :=
    match s with
      | inl s' => Some s'
      | inr _ => None
    end.

  Definition option_sa_sum (s: option A): A+unit :=
    match s with
      | Some s' => inl _ s'
      | None => inr _ tt
    end.

  Lemma sa_sum__option: forall s, sa_sum_option (option_sa_sum s) = s.
  Proof. destruct s; firstorder. Qed.

  Lemma option__sa_sum: forall s, option_sa_sum (sa_sum_option s) = s.
  Proof. destruct s; firstorder; destruct u; firstorder. Qed.

  Definition bij_sa_sum_option : bijection (A+unit) (option A) :=
    Bijection _ _ sa_sum_option option_sa_sum sa_sum__option option__sa_sum.
End join_hom_disjoint_sum.

(* List SA *)
Section join_hom_list.
  Variables (A: Type) (JA: Join A).

  Lemma join_hom_list_nil
    : join_hom (fun a => a :: nil).
  Proof.
    unfold join_hom;
      solve [constructor; auto || constructor].
  Qed.

  Lemma join_hom2_list_cons
    : join_hom2 (fun a l => a :: l).
  Proof.
    unfold join_hom2; constructor; auto.
  Qed.
End join_hom_list.

(* FPMs
   This section proves a join hom lemma specialized to finite partial maps
   producing [option]s.
*)
Section join_hom_fun.
  Variables (Key A: Type)
            (Key_dec_eq: forall k1 k2: Key, {k1=k2}+{~k1=k2})
            (JA: Join A).
(*
  Definition saKey := sa_equiv Key.
  Definition saKeyA := sa_prod saKey saA.
  Definition saKeyAList := sa_list saKeyA.
  Definition saSum := sa_sum saA sa_unit.
  Definition saRange := sa_bijection _ _ (bij_sa_sum_option A) _ saSum.
*)

  Fixpoint lookup k (rho: list (Key*A)) :=
    match rho with
      | nil => None
      | (k', a) :: rho' =>
          if Key_dec_eq k k' then Some a else lookup k rho'
    end.

  Instance Join_Key : Join Key := @Join_equiv Key.

  Lemma join_hom_fun
    : join_hom (fun env k => lookup k env).
  Proof.
    unfold join_hom; intros x y z H.
    induction H.

    (* env is nil *)
    simpl; auto. intro. constructor.

    (* env is cons *)
    simpl; intro x0.
    destruct x as [k1 a1]; destruct y as [k2 a2]; destruct z as [k3 a3].
    destruct H. simpl in *. destruct H. subst k2 k3.
    destruct (Key_dec_eq x0 k1); auto. constructor; auto.
  Qed.
End join_hom_fun.
Arguments lookup [Key A] _ _ _.

Lemma join_hom_bij {A: Type} `{Perm_alg A}
            {B: Type}
          (bij: bijection A B):
       @join_hom _ _ _ (Join_bij _ _ _ bij) (bij_f _ _ bij).
  Proof.
    unfold join_hom. intros. do 3 red.
    repeat rewrite bij_gf. auto.
  Qed.

(* Some simple properties preserved by join homs *)
  Lemma join_hom_join_sub {A}{B}`{Join A}`{Join B}:
     forall (f: A -> B) a1 a2, join_sub a1 a2 -> join_hom f -> join_sub (f a1) (f a2).
  Proof.
    intros.
    destruct H1 as [b H1].
    exists (f b).  auto.
  Qed.

  Lemma join_hom_identity  {A}{B}`{Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}`{Perm_alg B}{SB: Sep_alg B}{CB: Canc_alg B}:
      forall (f: A -> B) a1, identity a1 -> join_hom f -> identity (f a1).
  Proof.
    intros.
    rewrite identity_unit_equiv in H1.
    rewrite identity_unit_equiv.
    unfold unit_for in *. auto.
  Qed.

  Lemma join_hom2_identity  {A}{B}{C}
          `{Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}
          `{Perm_alg B}{SB: Sep_alg B}{CB: Canc_alg B}
          `{Perm_alg C}{SC: Sep_alg C}{CC: Canc_alg C}:
   forall (g: A -> B -> C) a1 b1,
      identity a1 -> identity b1 -> join_hom2 g -> identity (g a1 b1).
  Proof.
   intros.
    unfold join_hom2 in *.
    rewrite identity_unit_equiv in H2.
    rewrite identity_unit_equiv in H3.
    rewrite identity_unit_equiv.
    unfold unit_for in *. auto.
  Qed.

  Lemma join_hom_comparable {A}{B}`{Perm_alg A}{SA: Sep_alg A}`{Perm_alg B}{SB:Sep_alg B}:
      forall (f: A -> B) a1 a2, comparable a1 a2 -> join_hom f -> comparable (f a1) (f a2).
  Proof.
    intros.
    unfold join_hom in *.
    destruct (comparable_common_unit H1) as [e [? ?]].
    apply common_unit_comparable.
    exists (f e); split; auto.
  Qed.

  Lemma join_hom2_comparable {A}{B}{C}
          `{Perm_alg A}{SA: Sep_alg A}`{Perm_alg B}{SB: Sep_alg B}`{Perm_alg C}{SC: Sep_alg C}:
   forall (g: A -> B -> C) a1 a2 b1 b2,
     comparable a1 a2
      -> comparable b1 b2
      -> join_hom2 g
      -> comparable (g a1 b1) (g a2 b2).
  Proof.
    intros.
    unfold join_hom2 in *.
    destruct (comparable_common_unit H2) as [ea [? ?]].
    destruct (comparable_common_unit H3) as [eb [? ?]].
    apply common_unit_comparable.
    exists (g ea eb); auto.
  Qed.

(* EXamples: *)

(*  This example doesn't make so much sense, as "comparable"
  is not so well-defined for Pos_algs
(* Finite Partial Maps from [nat]s to [option]s *)
Section fpm_ex.
  Variables (A: Type)
            (JA: Join A) (saA: Pos_alg A)(CA: Canc_alg A)
            (a b: A)
            (l: list (nat*A)).

  Definition mkEnv := fun p:nat*A => p :: l.
  Definition env1 := mkEnv (1%nat, a).
  Definition env2 := mkEnv (1%nat, b).
  Definition fpm (env: list (nat*A)) := fun k:nat => lookup eq_nat_dec k env.

Check Sep_sum.

 Definition saOption := Perm_bij _ _ _ _ (bij_sa_sum_option A).
  Definition saB := Perm_fun nat _ _ saOption.
  Local Instance Join_nat : Join nat := @Join_equiv nat.
  Local Instance Sep_nat : Sep_alg nat := Sep_equiv nat.

  Local Instance Canc_B : Canc_alg (nat -> option A).
  Proof. auto with typeclass_instances. Qed.

  Lemma fpm_comparable_ex
    : comparable (fpm env1) (fpm env2).
  Proof.
    simpl.

Check (@join_hom_comparable (list (nat*A)) _ _ _ _ _ fpm).
Print join_hom_comparable.
A, B, J, H,  J0, H0

    apply join_hom_comparable with (f := fpm).

; [ | apply join_hom_fun; auto].
    eapply join_hom2_comparable.
    eapply join_hom2_comparable with (g := fun a b => (a,b)).
    eapply comparable_refl.
    eapply H.
    eapply join_hom2_pair'.
    eapply comparable_refl.
    eapply join_hom2_list_cons.
Qed.

End fpm_ex.
*)


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

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

Structure tProp := TProp {tProp_statement :> Prop; _ : tProp_statement}.
Lemma claim : forall tP : tProp, tP. Proof. by case. Qed.
Hint Resolve claim.

Canonical Structure True_tProp := TProp Logic.I.
Canonical Structure eq_tProp T (x : T) := TProp (erefl x).
Canonical Structure true_tProp := @TProp true (erefl _).
Canonical Structure and_tProp (P Q : tProp) :=
  TProp (conj (claim P) (claim Q)).

Structure postProp (P : Prop) := PostProp {postProp_statement :> tProp; _ : P}.
Canonical Structure tProp_postProp P claimP pP :=
  PostProp (@TProp P claimP) (claim pP).

Delimit Scope n_ary_op_scope with QOP.
Delimit Scope quote_scope with QT.

Fixpoint n_ary n T := if n is n'.+1 then T -> n_ary n' T else T.
Notation "n .-ary" := (n_ary n) (at level 2, format "n .-ary") : type_scope.

Module Quotation.

CoInductive n_ary_op T := NaryOp n of n.-ary T.
Notation "f / n" := (@NaryOp _ n f) : n_ary_op_scope.
Definition bind_op T R (op : n_ary_op T) ifun : R :=
  let: NaryOp n f := op in ifun n f.
Definition arity T op := @bind_op T nat op (fun n _ => n).

Structure type := Pack {sort :> Type; sym; _ : sym -> n_ary_op sort}.
Notation QuoteType sf := (Pack sf%QOP).
Definition symop T := let: Pack _ _ ops := T return sym T -> n_ary_op T in ops.

Inductive term S := Var of nat | App of S & seq (term S).

Lemma term_ind' : forall S (P : term S -> Type),
  (forall i, P (Var S i)) ->
  (forall s a, foldr prod True (map P a) -> P (App s a)) ->
  (forall t, P t).
Proof.
move=> S P P_V P_A; pose fix sz (t : term S) :=
  if t is App _ a then (foldr maxn 0 (map sz a)).+1 else 0.
move=> t; elim: {t}(sz t) {-2}t (leqnn (sz t)) => [|n IHn] [i | s a] //=.
rewrite ltnS => sz_a; apply: P_A; elim: a sz_a => //= t a IHa.
by rewrite geq_max; case/andP; move/IHn=> Pt; move/IHa.
Qed.

Bind Scope quote_scope with term.
Notation "''K_' i" := (Var _ i)
  (at level 8, i at level 2, format "''K_' i") : quote_scope.
Notation "''[' s x1 .. xn ]" := (App s (x1%QT :: .. [:: xn%QT] ..))
  (at level 0, s at level 2, x1, xn at level 8,
   format "''[' '[hv' s  x1  ..  xn ']' ]") : quote_scope.
Notation "''[' s ]" := (App s [::])
  (at level 0, s at level 2, format "''[' s ]") : quote_scope.

Section OneType.

Variable T : type.
Implicit Type P : Prop.
Implicit Type tP : tProp.

Definition Env := @id (seq T).

Fixpoint lookup i e : option T :=
  if i is i'.+1 then lookup i' (behead e) else ohead e.

Definition interp_app (iarg : term (sym T) -> option T) :=
  fix loop a n {struct a} : n.-ary T -> option T :=
  if n is n'.+1 return n.-ary T -> option T
  then fun f => if a is t :: a' then obind (loop a' n' \o f) (iarg t) else None
  else fun x => if a is [::] then Some x else None.

Fixpoint interp e t := match t with
 | Var i => lookup i e
 | App s a => bind_op (symop s) (interp_app (interp e) a)
 end.

Fixpoint wf (t : term (sym T)) :=
  match t with
  | App s a => let: NaryOp n _ := symop s in (n == size a) && all wf a
  | Var _ => true
  end.

Fixpoint eval x0 e t :=
  match t with
  | Var i => nth x0 e i
  | App s a =>
    odflt x0 (bind_op (symop s) (interp_app (fun x => Some (eval x0 e x)) a))
  end.

Lemma interp_wf_eval : forall y0 e t y,
  interp e t = Some y -> wf t /\ eval y0 e t = y.
Proof.
move=> y0 e t; elim/term_ind': t => [i|s a IHa] y /=.
  by elim: i e => [|i IHi] [|z e] //=; [case | elim: i {IHi} | apply: IHi].
case: symop => /= n x1.
elim: n x1 a IHa => [|n IHn] x1 [|f a] //=; first by move=> _  [].
by case: (interp e f) => //= x []; case/(_ x)=> // -> ->; apply: IHn.
Qed.

Definition var_val := @id T.
Definition op_val := var_val.

Structure form e t P := Form {fval; _ : P -> interp e t = Some fval}.
Lemma formP : forall e t tP f, interp e t = Some (@fval e t tP f).
Proof. by move=> e t tP [x <-]. Qed.

Structure store i x P := Store {stval; _ : P -> lookup i stval = Some x}.
Canonical Structure head_store x e :=
  @Store 0 x True (Env (x :: Env e)) (fun _ => erefl _).
Lemma tail_store_subproof : forall i x y e tP s,
  e = @stval i x tP s -> lookup i.+1 (y :: e) = Some x.
Proof. by move=> i x y _ tP [e /= <- //] ->. Qed.
Canonical Structure tail_store i x y e tP s :=
  Store (@tail_store_subproof i x y e tP s).

Lemma var_form_subproof : forall i x P (s : store i x P),
  P -> interp (stval s) 'K_i = Some (var_val x).
Proof. by move=> i x P []. Qed.
Canonical Structure var_form i x P s := Form (@var_form_subproof i x P s).

Lemma op_form_subproof : forall e t tP (f : form e t tP) x,
  x = @fval e t tP f -> interp e t = Some (op_val x).
Proof. by move=> e t tP f _ ->; apply: formP. Qed.

Canonical Structure op_form e t tP f x :=
  Form (@op_form_subproof e t tP f x).

Section OpForm.

Variables (s : sym T) (e : seq T).

Fixpoint OpForm_type a xa fa n :=
  if n is n'.+1 then
    forall x t tP f, OpForm_type (t :: a) (x :: xa) (@fval e t tP f :: fa) n'
  else form e (App s (rev a)) (map op_val (rev xa) = rev fa).

Definition OpForm_rechyp a (xa fa : seq T) n (x : n.-ary T) :=
  forall a', map op_val (rev xa) = rev fa ->
  interp e (App s (catrev a' a)) = interp_app (interp e) a' x.

Definition OpForm_rectype a xa fa n (x : n.-ary T) :=
  OpForm_rechyp a xa fa x -> OpForm_type a xa fa n.

Definition OpForm_basetype P x a :=
  (P -> interp e (App s a) = Some x) -> form e (App s a) P.

Lemma OpForm_recproof : forall a xa fa n (x1 : n.+1.-ary T),
  forall x t tP f, OpForm_rechyp a xa fa x1 ->
  OpForm_rechyp (t :: a) (x :: xa) (@fval e t tP f :: fa) (x1 x).
Proof.
move=> a xa fa n x1 x t tP f IHx a'; move/(_ (t :: a')): IHx => /=.
rewrite !map_id (formP f) /= => IHx; case/(can_inj (@revK _)) => -> eq_xa.
by rewrite {}IHx ?eq_xa.
Qed.

Fixpoint OpForm_rec a xa fa n : forall x, @OpForm_rectype a xa fa n x :=
  if n is _.+1 return forall x, @OpForm_rectype a xa fa n x then
  fun _ IHx _ _ _ _ => OpForm_rec (OpForm_recproof IHx) else
  fun x IHx =>
    (if rev a is (t :: a') as rev_a return OpForm_basetype _ _ rev_a then
     fun IHx => Form IHx else fun IHx => Form IHx) (IHx [::]).

Lemma OpForm_subproof : bind_op (symop s) (OpForm_rechyp [::] [::] [::]).
Proof. by case def_s: (symop s) => [n x] a _; rewrite /= def_s. Qed.

Definition OpForm :=
  (let: (op/n)%QOP as op_n := symop s
   return (bind_op op_n _ : Prop) -> @OpForm_type _ _ _ (arity op_n) in
   @OpForm_rec _ _ _ n op)
   OpForm_subproof.

End OpForm.

Section GenSimp.

Variable simp : seq T -> term (sym T) -> option T.

Definition simp_axiom := forall e t x y,
  interp e t = Some x -> simp e t = Some y -> x = y.

Hypothesis simpP : simp_axiom.

Structure closed := Closed {closed_val :> seq T}.
Canonical Structure head_closed := Closed (Env [::]).
Canonical Structure tail_closed x (ce : closed) := Closed (x :: ce).
Inductive close : seq T -> Prop := Close (ce : closed) : close ce.
Canonical Structure close_tProp ce := TProp (Close ce).

Lemma simp_form : forall e t y ptP,
  forall f : form (Env e) t
      (@postProp_statement (close (Env e) /\ simp e t = Some y) ptP),
  fval f = y.
Proof.
by move=> e t y [tP [_ def_y]] [x /= def_x]; apply: simpP def_y; apply: def_x.
Qed.

End GenSimp.

Definition Econs := Cons.
Definition Etag of nat := @idfun.
Definition Enil := Nil.

Fixpoint simp_env {T'} e i :=
  if e is x :: e' then omap (Econs (Etag i x)) (simp_env e' i.+1)
  else Some (Enil T').

Notation "' 'K_' i := x" := (Etag i x)
  (at level 200, format "' 'K_' i  :=  x") : quote_tag_scope.
Arguments Scope Econs [type_scope quote_tag_scope _].

Notation "[ 'env' d1 ; .. ; d_n ]" := (Econs d1 .. (Econs d_n (Enil _)) ..)
  (at level 0, format "[ 'env' '['  d1 ; '/'  .. ; '/'  d_n ] ']'")
   : quote_scope.

Notation "[ 'env' ]" := (Enil _)
  (at level 0, format "[ 'env' ]") : quote_scope.

Lemma unquote_default : false -> T. Proof. by []. Qed.
Definition unquote e t :=
  if interp e t is Some x as ox return ox -> T then fun _ => x else
  unquote_default.

Arguments Scope unquote [quote_scope quote_scope _].

Lemma end_unquote : true. Proof. by []. Qed.
Definition simp_quote e t :=
  obind (fun e' =>
   (if interp e' t as b return (b -> _) -> _ then
      fun wf_t' => Some (unquote (wf_t' end_unquote))
   else fun _ => None) id)
  (simp_env e 0).

Lemma simp_quoteP : simp_axiom simp_quote.
Proof.
rewrite /simp_quote => e t x y def_x.
suff ->: simp_env e 0 = Some e by rewrite /unquote /= def_x; case.
by elim: e {def_x} 0 => //= z e IHe i; rewrite IHe.
Qed.

Definition quote := simp_form simp_quoteP.

End OneType.

End Quotation.

Canonical Structure Quotation.head_store.
Canonical Structure Quotation.tail_store.
Canonical Structure Quotation.var_form.
Canonical Structure Quotation.op_form.
Canonical Structure Quotation.head_closed.
Canonical Structure Quotation.tail_closed.
Canonical Structure Quotation.close_tProp.

Notation QuoteType sf := (Quotation.Pack sf%QOP).
Notation "f / n" := (@Quotation.NaryOp _ n f) : n_ary_op_scope.

Notation OpForm := Quotation.OpForm.

Notation "''K_' i" := (Quotation.Var _ i)
  (at level 8, i at level 2, format "''K_' i") : quote_scope.
Notation "''[' s x1 .. xn ]" :=
  (Quotation.App s (x1%QT :: .. [:: xn%QT] ..))
  (at level 0, s at level 2, x1, xn at level 8,
   format "''[' s '[hv'  x1 '/'  .. '/'  xn ']' ]") : quote_scope.
Notation "''[' s ]" := (Quotation.App s [::])
  (at level 0, s at level 2, format "''[' s ]") : quote_scope.
Notation "' 'K_' i := x" := (Quotation.Etag i x)
  (at level 200, format "' 'K_' i  :=  x") : quote_tag_scope.
Arguments Scope Quotation.Econs [type_scope quote_tag_scope _].
Notation "[ 'env' d1 ; .. ; d_n ]" :=
  (Quotation.Econs d1 .. (Quotation.Econs d_n (Quotation.Enil _)) ..)
  (at level 0, format "[ 'env' '['  d1 ; '/'  .. ; '/'  d_n ] ']'")
   : quote_scope.
Notation "[ 'env' ]" := (Quotation.Enil _)
  (at level 0, format "[ 'env' ]") : quote_scope.

Arguments Scope Quotation.unquote [_ quote_scope quote_scope _].
Notation unquote e t := (@Quotation.unquote _ e t%QT _).

CoInductive bool_sym := bTrue | bAnd.
Canonical Structure bool_quoteType :=
  QuoteType (fun s => match s with bTrue => true/0 | bAnd => andb/2 end).
Canonical Structure and_form := Eval hnf in OpForm bAnd.
Canonical Structure true_form := Eval hnf in OpForm bTrue.

Lemma try_bquote : forall b1 b2 b3,
  false && b1 && (b2 && true && b3) && (b2 && b1 && b2) = false && b2.
Proof.
move=> b1 b2 b3.
Time rewrite Quotation.quote.
Time rewrite !Quotation.quote.
by [].
Qed.

Fixpoint bstore s bt := match bt with
| 'K_i => set_nth false s i true
| '[bAnd t1 t2] => bstore (bstore s t1) t2
| _ => s
end%QT.

Fixpoint bread ot i s := match s with
| [::] => odflt '[bTrue] ot
| true :: s' => bread (Some (oapp (fun t => '[bAnd t 'K_i]) 'K_i ot)) i.+1 s'
| false :: s' => bread ot i.+1 s'
end%QT.

Fixpoint bnormed t i := match t with
| '[bAnd t' 'K_j] => bnormed t' 1
| 'K_j => i > 0
| '[bTrue] => i == 0
| _ => false
end%QT.

Definition bsimp_fn e t :=
  if bnormed t 0 then None else
  Quotation.interp e (bread None 0 (bstore [::] t)).

Lemma bsimpP : Quotation.simp_axiom bsimp_fn.
Proof.
pose oand ob1 ob2 := obind (fun b1 => omap (andb b1) ob2) ob1.
have [oaC oaA oaI]: [/\ commutative oand, associative oand & idempotent oand].
  by split; do 6?case=> //.
have oa1: left_id (Some true) oand by case=> [[]|].
rewrite /bsimp_fn => e t b b'; case: bnormed => //=.
set ie := Quotation.interp e; set s := [::] => def_b.
pose ir j s := ie (bread None j s).
suff{b'} storeP: ir 0 (bstore s t) = oand (ir 0 s) (Some b).
  by rewrite [ie _]storeP => [[]].
elim/Quotation.term_ind': t s => [i | op a IHa] /= s in b def_b *; last first.
  case: op def_b; first by case: a {IHa} => //= <-; rewrite oaC oa1.
  case: a IHa => //= t1; rewrite /ie /= -/ie; case: (ie _) => //= b1 [] //= t2.
  case: (ie t2) => //= b2 [] //= [IHb1 [IHb2 _]] [<-].
  by rewrite (IHb2 _ b2) // (IHb1 _ b1) // -oaA.
have irT: forall s' j, ir j (true :: s') = oand (ie 'K_j)%QT (ir j.+1 s').
  rewrite /ir /= => s' j; move: s' j ('K_j)%QT.
  by elim=> [|[|] s' IHs] j u; first 1 [rewrite oaC oa1] || rewrite !IHs -?oaA.
rewrite -{}def_b -{2}[i]addn0; elim: i 0 s => [|i IHi] j.
  case=> [|bj s]; first by rewrite oa1.
  by case: bj; rewrite !irT oaC // -oaA oaI.
rewrite addSnnS; case=> [|[|] s]; last exact: IHi.
  by rewrite /= -set_nth_nil [ir _ _]IHi.
by rewrite !irT IHi oaA.
Qed.

Definition bsimp := Quotation.simp_form bsimpP.

Lemma try_bsimp : forall b1 b2 b3,
  true && b1 && (b2 && b3) && (b2 && b1 && b2) = b1 && b2 && true && b3.
Proof.
move=> b1 b2 b3.
Time rewrite bsimp.
Time rewrite !bsimp.
by [].
Qed.


(**************************************************************************)
(*                                                                        *)
(*     Sniper                                                             *)
(*     Copyright (C) 2021                                                 *)
(*                                                                        *)
(*     See file "AUTHORS" for the list of authors                         *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

Require Import utilities.
Require Import elimination_polymorphism.
Require Export clearbodies.
Require Import MetaCoq.Template.All.
Require Import String.
Require Import List.
Require Import ZArith.
Require Import interpretation_algebraic_types.
Require Import SMTCoq.SMTCoq.

(*********************)
(** General specification **)

(* The goal of this file is two-fold:
(1) automatically declare the projections of an inductive datatype I.
For instance, for the type list, whose constructors are [] (0 argument) and :: (2 arguments ),
we declare in the local context two functions proj_{1,0} : forall (A : Type), A -> list A -> list A and
proj_{1,1} : forall (A : Type) list A -> list A -> list A such that:
* proj_{1,0} def [] = def and proj_{1,0} d {a :: l} = a
* proj_{1,1} def [] = def and proj_{1,1} d {a :: l} = l
The metavariable d stands for a dummy default value,
of respective types A (for proj_{1,0}) and list A (for proj_{1,1})

(2) automatically prove in the local context the generation statement, specifying that every inhabitant t of I
is equal to a constructor applying to the projections of t.
For instance, in the case of list, the main tactic produces and proves the statement:
forall (A : Type) (d_{1,0} : A)  (d_{1,1} l: list A), (l =  []) \/ (l = ((proj_{1,0} d_{1,0} l)) :: ((proj_{1,1} d_{1,1} l))

Some implicit arguments have been omitted: technically,  proj_{1,0} : forall (A : Type), A -> list A -> list A and proj_{1,1} : forall (A : Type) list A -> list A -> list A and the generation statement is:
forall (A : Type) (d_{1,0} : A)  (d_{1,1} l: list A), (l = @nil A) \/ (l = (proj_{1,0} A d_{1,0} l) :: (proj_{1,1} A d_{1,1} l) *)

(*
Let us get now into the technical details.
Given an inductive datatype I, we use the following conventions:
* p : number of parameters of I
* P_0, ..., P_{p-1}: the types of the parameters of I
  lP := [ P_0 ; ... ; P_{p-1} ]
* C_1,...., C_k: the constructors of I
  lctors = [ C_0 ; ... ; C_k ]
* n_i is the number of arguments of C_i (withstanding parameters): thus, C_i has p + n_i arguments in total
  ln := [ n_0 ; ... ; n_{k-1} ]
* A_{i,j} is the type of the rank j argument of C_i (withstanding parameters): thus, C_i has the type (forall X_0 : .A_0) (X_{p-1} : A_{p-1}) (x_{i,0} : A_{i,0}) ... (x_{i,n_i-1} : A_{i, n_i-1}), B_i (* \TODO spécifier B_i: on en a besoin ?*)
  llA := [ [A_{0,0} ; ... ; A_{0,n_0-1} ] ;
            ... ;
           [ A_{k-1,0} ; ... ; A_{k-1,n_{k-1}-1}] ]

(** lift and unlift **)

A^{+i} (resp. A^{-i}) denotes A where all the free de Bruijn indices have been lifted with + i (resp. unlifted with -i)

* We set Aunlift_{i,j}/Au_{i,j} := (A_{i,j}^{-j})
  llAunlift/llAu := [ [Au_{0,0} ; Au_{0,1} ; ... ] ;
                       ... ;
                      [Au_{k-1,0} ; Au_{k-1,1} ; ... ] ]

Example: for I = nelist, the type of non-empty list, whose reification is denoted nelist_reif
* p = 1 and lP_0 = [ Type_Reif ]
* k = 2, C_0 = sing and C_1 = necons
* n_0 = 1 and n_1 = 2, ln = [1 ; 2]
* llA =  [ [ tRel 0 ] ; [ tRel 0 ; tApp nelist_reif [tRel 1] ] ]
* llAu = [ [ tRel 0 ] ; [ tRel 0 ; tApp nelist_reif [tRel 0] ] ]

From the reified point of view, an inductive type contains:
* a term of type 'inductive' (metavariable indu)
* a mutual_inductive_body (metavariable mind)
* mind contains a list of one_inductive_body's (metavariable oind)
* each one_inductive_body contains relevant information about, e.g., its constructors and their types
(* \TODO pointer vers le fonctions de aux_fun_list comme pose_mind etc *)

We must define projections proj_{i,j} for i = 0, ... , k-1 and j = 0, ..., n_i-1
proj_{i,j} = fun (X_0 : A_0) ...  (X_{p-1} : A_{p-1)} (def_{i,j} : Aunlift_{i,j}) (x : (I X_0 ... X_{p-1})),
match x with
| C_i x_{i,0} ... x_{i,n_i-1} => x_{i,j}
| C_q x_{q,0} ... x_{q,n_q-1} => def_{i,j} (* q <> i, the default value is returned *)
end.

To obtain the reification of reification of proj_{i,j}, we e set I' = tApp I [tRel p ; ... ; tRel 1]
Then proj_{i,j}_reif is:
tLam P_0 ... P_{p-1} tLam Aunlift_{i,j} tLam I'
tCase (I_indu , p , relevant ) ( tProd ((I')^{+1}) -> (Aunlift_{i,j}^{+3}) ) (tRel 0)
        [ (n_0 ; tLam A_{0,0}^{+2} ... A_{0,n_0-1}^{+2}) (tRel (S n_0)) ) ; ... ;
        (n_q ; tLam A_{0,q}^{+2} ... A_{q,n_q-1}^{+2}) (tRel (S n_q)) ) ; ... ;  (* for q <> i *)
        (n_i ; tLam A_{0,0}^{+2} ... A_{i,n_i-1}^{+2} tRel (n_i-1-j ) ) ; ...]

To obtain the reificaiton of the generation statement, we set
N_i = n_0 + ... + n_{i-1}
N'_i := n_{i+1} + ... + n_{k-1}
and N = n_0 + ... + n_{k-1} = N_k = N'_{-1}
Then, the reification of the statement is:
tProd A_0 ... A_ {p-1}
tProd Au_{0,0}^{+0} Au_{0,1}^{+1} ... Au_{0,j}^{+j} ... Au_{0,n_0-1}^{+n_0-1}
      Au_{1,0}^{+n_0} Au_{1,1}^{n_0+1} ...
      .... Au_{i,j}^{N_i+j}... Au_{k-1,n_k-1}^{N-1}
tProd (x : (I')^{+N})
  or_reif
     eq_reif _ (tRel 0)  pstat_0 ;
     eq_reif _ (tRel 0) pstat_1 ; ... ;
     eq_reif _ (tRel 0) pstat_{k-1}
where pstat_i := C_i [ _p ;
        proj_{i,0} [ _p ; tRel (N'_{i-1}) ; tRel 0 ]
        .... ;
        proj_{i,j} [ _ p ; tRel (N'_{i-1}-j) ; tRel 0] ; ... ]
where _p is a macro for p evars
 *)

(* \TODO : rename impossible term, which is an empty inductive type and is mainly used as a marker *)

(* get_indu_app_to_params t p = tApp t [tRel p ; .... ; tRel 1] *)
(* tail-recursive *)
Definition get_indu_app_to_params (t : term) (p n: nat) :=
  tApp t (Rel_list p n).

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

Ltac find_inhabitant_context t :=
first[ constructor ; assumption | apply Inh | epose (inhab := ?[t_evar] : t)].

Ltac find_inh t :=
match goal with
| H : t |- _ => H
| _ => let H := fresh in let _ := match goal with _ => assert (H : t) by find_inhabitant_context t end in H
end.

(* removes k to each de Brujin index: useful when variables are removed *)
(* Remark: does not work with dependencies. Should perhaps use subst instead *)
Fixpoint unlift (k : nat) (t : term)  {struct t} : term :=
  match t with
  | tRel i => tRel (i-k)
  | tEvar ev args => tEvar ev (map (unlift k) args)
  | tCast c kind t0 => tCast (unlift k c) kind (unlift k t0)
  | tProd na A B => tProd na (unlift k A) (unlift k B)
  | tLambda na T M => tLambda na (unlift k T) (unlift k M)
  | tLetIn na b t0 b' => tLetIn na (unlift k b) (unlift k t0) (unlift k b')
  | tApp u v => tApp (unlift k u) (map (unlift k) v)
  | tCase ind p c brs =>
      let brs' := map (on_snd (unlift k)) brs in
      tCase ind (unlift k p) (unlift k c) brs'
  | tProj p c => tProj p (unlift k c)
  | tFix mfix idx =>
      let k' := #|mfix| + k in
      let mfix' := map (map_def (unlift k) (unlift k')) mfix in tFix mfix' idx
  | tCoFix mfix idx =>
      let k' := #|mfix| + k in
      let mfix' := map (map_def (unlift k) (unlift k')) mfix in
      tCoFix mfix' idx
  | _ => t
  end.

(* branch_default_var n_i i j q = Prod x1 hole. ... Prod x_{n_i} hole (tRel kp)
    where dq is defined with:
    kp = n_q - 1 - j if q = j
    kp = n_q + 1 if q <> j
    * If j <> q then, tRel kp denotes def, the default variable
    Indeed, tRel dq is tRel 1 lifted nq times
    * If j = k, then tRel dq denotes the variable that is bound by the hole of rank i
  Thus, branch_default_var n_q i j q  denotes the branch of rank q of the
  pattern-matching specifying proj_{i,j}, where n_q is the number of arguments of
  the constructor C_q
*)
Definition branch_default_var (nq : nat)  (i : nat) (j : nat) (q : nat) :=
      let dq := if Nat.eqb i q then nq - (S j)
      else S nq in
      let fix aux i acc :=
      match i with
      | 0 => acc
      | S i => aux i (mkLam hole acc)
      end
      in aux nq (tRel dq).

(* \TODO long term: recover the "relevant" parameter and not hard-code it *)
(* Constructs the pattern matching in the proj
for instance, given the right arguments to construct the predecessor function we get the reified
< match x with
| 0 => default
| S y => y > *)

(* mkCase_list_param [n_0 ; ... ; n_{k-1} ] i j
     is the list expected by the 'tCase' constructor to define the pattern-matching
     specifying the proj_{i,j}
     Namely, it is the list:
     [ (n_0 , branch_default_var n_0 i j 0) ; ... ; (n_{k-1} , branch_default_var n_{k-1} i j (k-1) ) ]
*)
Definition mkCase_list_param (ln : list nat)  (i : nat) (j : nat) :=
  let fix aux ln q acc :=
  match ln with
  | [] => acc
  | nq :: ln => aux ln (S q)  ((nq , branch_default_var nq i j q) :: acc )
  end
  in tr_rev (aux ln 0 []).

(* proj_ij p lP_rev I indu i j llAu ln Au_{i,j}
    defines the reification of proj_ij, where the parameters follow the
    metavariables conventions specified in the head of this file
    (lP is lP reverted)
*)
Definition proj_ij (p : nat) (lP_rev : list term) (I : term) (indu : inductive)  (i : nat) (j : nat)
(ln : list nat) (Auij : term):=
mkLam_rec lP_rev
 (mkLam Auij (mkLam (get_indu_app_to_params I p 1)
(tCase (indu, p, Relevant)  (mkLam (get_indu_app_to_params I p 2) (lift0 3 Auij)) (tRel 0)  (mkCase_list_param ln i j)))).

(* This function computes the projections of an inductive type the projections in the local environment
  \TODO some tr_rev's could perhaps be avoided if collect_projs is merged with the Ltac function declare_projs below
*)
Definition collect_projs (p : nat) (lP_rev : list term) (I : term) (indu: inductive)
(llAunlift : list (list term)) (ln : list nat) (k : nat)
:= let fix aux1 (i : nat) (nk :nat) lAk' acc :=
  match (nk,lAk') with
  | (0,[]) => acc
  | (S j, Auij :: lAk') => aux1 i nk lAk' ((proj_ij p lP_rev I indu i j  ln (Auij)):: acc)
  | _ => [] (* this case should not happen *)
  end
in
let fix aux2 llAu' ln' i'  acc :=
match (i',llAu',ln') with
| (0,[],[]) => acc
| (S i,lAi :: llAu' , ni :: ln' ) => aux2 llAu' ln' i ((aux1 i ni (tr_rev lAi) []) :: acc)
| _ => []
end in
aux2 (tr_rev llAunlift) (tr_rev ln) k [].

(* \TODO improve the naming of the functions *)
Ltac declare_projs_ctor_i na p lP_rev I indu llAu ln i lAi ni :=
  let _ := match goal with _ =>  idtac end in let lAi' := constr:(tr_rev lAi) in
  let rec aux1 i j lAi' acc :=
  lazymatch j with
  | 0 => constr:(acc)
  | S ?j0 => lazymatch eval hnf in lAi' with
   | ?Auij :: ?tlAi' =>  let pij := constr:(proj_ij p lP_rev I indu i j0 ln Auij) in let name :=  fresh "proj_" na  in let _ := match goal with _ => pose_unquote_term_hnf pij name
    end in let pij_tVar := metacoq_get_value (tmQuote name)  in let acc0 := constr:(pij_tVar :: acc) in let z := aux1 i j0 tlAi' acc0 in constr:(z)
   end
   | _ => idtac "erroc declare_projs_ctor_i"
  end
  in   let res_dpi := aux1 i ni lAi' (@nil term) in constr:(res_dpi)
.

(* \TODO améliorer le nommage *)
(* declare_projs_for_one_ctor .... k lAk k
   (1) declare the projections of Ck, the ctor of rank k of I with the base name na (hopefully, the name of the inductive)
   (2) outputs the list of reified projections as tVar's [ tVar "na_k_0" ; .... ; tVar "na_k_nk" ] (i.e. projections are in order)
   where
   * lA is the list of types of the arguments of C_k
   * nk is the number of parameters of C_k
   * the other metavariables follow the usual conventions
*)
(* declare_projs na ... nc
  (1) declare the projs of an inductive using base name na (the name of inductive)
  (2) outputs the list of lists of the reified projectors as tVar's
      [[ tVar "na_0_0" ; .... ; tVar "na_k_n0" ] ; ....
      ;  [ tVar "na_nc_0" ; .... ; tVar "na_nc_{k_nc}" ] ]
      (i.e. projections are in order)
  where nc is the number of constructors of the inductive
  *)
  (* \TODO  currently, the projections are in order in the output, but it would be better that they are in the reverse order to produce the generation statement
  (indeed, we need to perform one reverse)
  *)

Ltac declare_projs na p lP_rev I indu llAu ln nc :=
  let llAu_rev := constr:(tr_rev llAu) in let ln_rev :=
constr:(tr_rev ln)
in
 let rec aux llAu' ln' k  acc :=
let y := constr:(((k,llAu'),ln'))
in lazymatch eval hnf in y with
| (?y0 , ?ln0') =>
  match eval cbv in ln0' with
  | (@nil nat) =>   constr:(acc)
  | ?nk :: ?tln0 =>
    match eval hnf in y0 with
    | (?k, ?lAu') => lazymatch eval hnf in k with
      | S ?k => match eval hnf in lAu' with
        | ?lAk :: ?tlAu'=>
        let dpk  := declare_projs_ctor_i na p lP_rev I indu llAu ln k  lAk nk in let acc0 := constr:(dpk :: acc ) in let res2 := aux tlAu' tln0 k acc0 in  constr:(res2)
  end
  end
  end
  end
 |_ => idtac "error declare_projs "
end
in
let res_dp := aux llAu_rev ln_rev nc (@nil (list term))  in constr:(res_dp)
.

(*** \TODO one unique function which declares the projectors of I in the local context
 and outputs the list of lists of their tVar's
*)
Ltac declare_projs0 p lP_rev  I indu llAunlift  ln nc
:=
match goal with _ => let rec aux1 k  i  lAk' acc :=
 let x := constr:((i,lAk'))   in (* idtac "blut 0" ; *)
  lazymatch eval hnf in x with
   | (?i,?lAk') => lazymatch eval hnf in i with
     | 0 => constr:(acc)
     | S ?i => lazymatch eval hnf in lAk' with
       | ?Akiu :: ?lAk' => let res1 := aux1 k i lAk' constr:(((proj_ij p lP_rev I indu k i ln (Akiu)):: acc))in constr:(res1)
       end end
   | _ => idtac "error declare_projs 1"
  end
in
let rec aux2 llAu' ln' k  acc :=
let y := constr:(((k,llAu'),ln'))
in  lazymatch eval hnf in y with
| (?y0 , ?ln0') =>
  lazymatch eval cbv in ln0' with
  | (@nil nat) => constr:(acc)
  | ?i :: ?ln1' =>
    lazymatch eval hnf in y0 with
    | (?k, ?lAu') => lazymatch eval hnf in k with
      | S ?k => (* idtac "blut 5" ; *) lazymatch eval hnf in lAu' with
        | ?lAk :: ?lAu'=> let res2 := aux2 llAu' ln' k constr:((aux1 k i (tr_rev lAk) (@nil term)) :: acc) in constr:(res2)
  end
  end
  end
  end
  |_ => idtac "error declare_projs 1"
end
in let res := aux2 constr:(tr_rev llAunlift) constr:(tr_rev ln) nc (@nil term)  in constr:(res)
end
.

(************************************************************************************)
(* The tactic defining projections in the local context have been specified above   *)
(* Below, we define the tactic stating and proving the generation statement         *)
(************************************************************************************)

(*
proj_return_types [[A_{0,0} ; ... ; A_{0,n_0-1}] ; ... ; [A_{k,0} ; .... ; A_{k-1,n_{k-1}}] ]
    = [ [A_{0,0}] ; A_ {0,1} ^{-1} ; ... ; A_{0,n_0-1}^{-n_0+1} ] ; ... ;
         [A_{k-1,0}] ; A_ {k-1,1} ^{-1} ; ... ; A_{k-1,n_{k-1}}^{-n_k+1}] ]
      helps compute llAu, this list of list of the return types of the projections
*)
Definition proj_return_types (llA: list (list term)) :=
  let fix aux acc i lA :=
    match lA with
    | [] => acc
    | A :: tlA => aux ((unlift i A) :: acc ) (S i) tlA
  end  in  (tr_map (fun lA => tr_rev(aux [] 0  lA)) llA).

(* warning: handles parameters but not dependent arguments *)

(* \TODO : bind_def_val_in_gen [[A_{0,0} ; ... ; A_{0,n_0-1}] ; ... ; [A_{k-1,0} ; .... ; A_{k-1,n_k-1}] ]
                                  [ n_0 ; ... ; n_{k-1} ]
    = [ A_{k,n_k}^N ; ... ; A_{0,1}^{+1} ; A_{0,0}^0 ]
      where N = n_0 + ... + n_{k-1}
      Thus, bind_def_val_in_gen performs a flattening, a revert and a incremental lift of all the elements of the initial list of lists
    *)
(* \TODO the accumulators n0, n0+n1, n0+n1+n2..., or should perhaps be computed in a separate place
 *)
Definition bind_def_val_in_gen (llAunlift : list (list term)) (ln : list nat) :=
  let fix aux1  acc i (lA : list term) : list term  :=
  match lA with
  | [] => acc
  | A0 :: lA => aux1 ((lift0 i A0) :: acc) (S i) lA
  end
  in let fix aux2 acc  a1 a2 llA ln :=
  match (llA,ln) with
  | ([],[]) => acc
  | (lA :: llA, na :: ln)  => let a1'  :=  na + a1 in  aux2 (aux1 acc  a1 lA )  a1' na  llA ln
  | _ => [] (* this cases does not happen: ln and llAunflit have the same length *)
  end
  in  aux2 [] 0 0  llAunlift ln.

(* holes_p p = [hole ; ... ; hole] (p occurrences)
   linear *)
   Definition holes_p (p : nat) :=
    let fix aux p acc :=
    match p with
    | 0 => acc
    | S p => aux p (hole :: acc)
  end in aux p [].

  (* holes_p p = [hole ; ... ; hole ; tRel db ; tRel 0] with p holes
      \TODO useful to pass the parameters to the projections,
      cf. get_elim_applied and get_eq_x_ctor_projs *)
  Definition holes_p' (p : nat) (db : nat) :=
    let fix aux p acc :=
    match p with
    | 0 => acc
    | S p => aux p (hole :: acc)
  end in aux p [tRel db; tRel 0].

(** get_eq_x_ctor_projs p ctor [proj_0, ..., proj_{n-1}] db
   is the reification of the equality "tRel 0" = ctor (proj0 [ _p ; tRel db  ; tRel 0] ;
 proj_{n-1} [ _p : tRel (db -1) ; tRel 0] ; ... ; [ _p ; tRel (db-n+1) ; tRel 0] ]
   where p is the number of parameters of the inductive
   proj_0,...., proj_{n-1} are supposed to be the reified projections of the reified constructor ctor, n is the number of argument of this constructor (withstanding parameters) and _p is a sequence of p holes
   That is, intuitively, the ouput represents an equality of the form x = ctor (proj_0 x) ... (proj_{n-1} x), where x is tRel 0
   **)
(** tail-recursive **)
  Definition get_eq_x_ctor_projs (p: nat) (ctor : term) (projs : list term)  (db: nat) :=
(* \tTODO see it one needs to give the parameters: probably not *)
let fix aux lprojs i  acc :=
   match (lprojs,i) with
   | ([],_) => acc
   | (pki :: lprojs, S i) => aux lprojs i ((tApp pki (holes_p' p i))::acc)
   | _ => [] (* this case does not happen *)
  end in
  mkEq hole (tRel 0) (tApp ctor (rev_append (holes_p p) (tr_rev (aux projs (S db) [])))).

(* \todo check that the db are computed somewhere *)
(* \todo, here, one rather needs a revert mkOr_n *)
(* \todo see if this needs to be reverted later*)
(* get_generation_disjunction p ctors list_proj ldb
   outputs the reification of forall x : I,
   x = C0 (projs0 x) \/ .... \/ x = Ck (projsk x)
   where lctors is the list of the (reified) constructors of an inductive, list_proj is the list of lists of their projections  (which are computed by the tactic declare_projs)
  x = Ck (projsk x) is a shortening of x = Ck (proj_{k,0} d_{k,0} x) .... (proj_{k,nk-1} d_{k,nk-1} x) and d_{k,i} the default value for d_{k,i} (x = Ck (projsk x) is computed with get_eq_x_ctor_projs)
   ldb is the list of De Bruijn indices of ????
   N is the total number of the arguments of all constructors (withstanding type parameters )
   Note that mkProd tApp I (Rel_list N p) _
   is forall x : I A1 ... Ap, _
   *)
(* \TODO remove ldb argument *)

 Definition get_generation_disjunction  (p : nat) (I: term) (N : nat) (lc : list term) (list_proj : list (list term)) (ln : list nat) :=
  let fix aux lc list_proj lN acc :=
  match (lc,list_proj,lN) with
  | ([],[],[]) => acc
  | (ctor :: tlc , projs :: tl_proj, db :: tlN ) => aux tlc tl_proj tlN  ((get_eq_x_ctor_projs p ctor projs db) :: acc)
  | _ => [] (* this cases does not happen *)
 end in let lN := rev_acc_add (tr_rev ln)   (* perhaps some optimization there *)
 in tProd (mkNamed "x") (tApp I (Rel_list p N)) (mkOr_n (tr_rev (aux lc list_proj lN []))) .

(** args_of_projs_in_disj [ n1 ; .... ; nk ] = [[tRel N ; tRel N-1 ; ....; tRel (N-n1+1) ] ; ... ; [tRel nk ; ... ; tRel 1]  ]
    where N = n1 + ... + n1
    i.e. the sublists have respective lengths ni and the de Bruijn index decreases at each step
    args_of_projs_in_disj [1 ; 3 ; 2 ] = [ [tRel 6 ] ; [tRel 5 ; tRel 4 ; tRel 3] ; [tRel 2 ; Rel 1]]
    This function helps specify the Db index of the default variable of each projection in the big disjunction
    **)
(* \Q : do we need this function? *)
Definition args_of_projs_in_disj (ln : list nat) : list (list term) :=
  let ln_rev := tr_rev ln in
  let fix aux l0 acc res :=
  match l0 with
  | [] => res
  | ni :: l0 =>  aux l0 (ni + acc) ((Rel_list ni acc) :: res)
  end in aux ln_rev 1 [].

Ltac prove_by_destruct_varn n  :=
match n with
| 0 =>
let x := fresh in
intro x ; destruct x; repeat first [first [reflexivity | right ; reflexivity] | left]
| S ?m => let y := fresh in intro y ; prove_by_destruct_varn m
end.

Ltac clearbody_list_of_list l :=
match l with
| @nil (list term) => idtac
| cons ?x ?xs => clearbody_list_tVar x ; clearbody_list_of_list xs
end.

Ltac gen_statement t :=
  let Helim := fresh "gen_" t in let _ := match goal with _ =>
  let indmind := fresh "indmind" in info_indu t indmind ;
  lazymatch eval compute in indmind with
  | (?induu,?mind) =>
    lazymatch eval hnf in induu with
    | (?indu, ?u) =>
    let pparams := eval compute in (get_params_from_mind mind) in
    lazymatch eval hnf in pparams with
    | (?p,?lP) =>
    lazymatch eval hnf in pparams with
    | (?p, ?lP) => let oind := eval compute in (hd nat_oind mind.(ind_bodies)) in
     let gct := eval compute in  (get_ctors_and_types_i indu p 1 0 u  oind)
   in  lazymatch eval hnf in gct with
    | (?lBfA,?ln) => lazymatch eval hnf in lBfA with
      | (?lBf,?llA) =>  lazymatch eval cbv in lBf with
        | (?lB,?lc) => let llAtrunc := eval compute in (tr_map (skipn p) llA) in  let nc := eval compute in (leng ln) in
        let lP_rev := eval compute in (tr_rev lP) in let llAu := eval compute in (proj_return_types llAtrunc) in let t_reif := constr:(tInd indu u) in  let N := constr:(fold_left Nat.add ln 0) in
        let res3 :=
         declare_projs t p lP_rev t_reif indu llAu ln nc in let llprojs := fresh "llprojs" in
         pose (llprojs  := res3) ;
        let ltypes_forall := constr:(bind_def_val_in_gen llAu ln) in
        let ggd := constr:(mkProd_rec_n "A" lP_rev (mkProd_rec_n "d" ltypes_forall (get_generation_disjunction  p t_reif N  lc  llprojs  ln))) in
          let gent := fresh "gen_stat" t in pose_unquote_term_hnf ggd gent  ; let N' := eval compute in (p + N) in assert (Helim : gent) by prove_by_destruct_varn N' ;
        unfold gent in Helim ; let llprojs2 := eval unfold llprojs in llprojs in
       clearbody_list_of_list llprojs2; (* unfold gent in Helim ; *) clear gent indmind llprojs
        end
      end
    end
    end
  end end end end in Helim.

Ltac pose_gen_statement t :=
let x := gen_statement t in idtac. (* pose x as gent *)

(* \TMP *)
Ltac get_projs_st_return t := gen_statement t.

(* \TMP *)
Ltac get_projs_st t := pose_gen_statement t.

Ltac get_projs_st_return_quote t := pose_gen_statement t.

Section tests_proj.

(* non-empty lists *)
Inductive nelist {A : Type} : Type :=
	sing :  A -> nelist    | necons : A -> nelist -> nelist .

(* bicolor lists *)
Inductive biclist {A B : Type} : Type :=
  | bicnil : biclist
  | cons1 : A -> biclist -> biclist
  | cons2 : B -> biclist -> biclist.

Inductive Ind_test (A B : Type) :=
| ind0 : Ind_test A B
| ind1 : A -> B -> Ind_test A B -> nat -> Ind_test A B.

Inductive Ind_test2 (A B C : Type) :=
| bar1 : C -> Ind_test2 A B C
| bar2 : nat -> nat -> A -> Ind_test2 A B C.

Goal False.
get_projs_st list. generalize proj_list. clear.
get_projs_st nat. clear.
get_projs_st option. clear.
get_projs_st @nelist. clear.
get_projs_st @biclist. clear.
get_projs_st Ind_test. clear.
get_projs_st Ind_test2. clear.
Abort.

Goal False.
pose_gen_statement nat. clear.
pose_gen_statement list. clear.
pose_gen_statement @nelist. clear.
pose_gen_statement @biclist. clear.
pose_gen_statement Ind_test. clear.
pose_gen_statement Ind_test2. clear.
Abort.

End tests_proj.

Ltac instantiate_ident H x :=
  let T := type of H in
 lazymatch T  with
  | forall (y : ?A), _ => let H':= fresh H in
let _ := match goal with _ => assert (H':= H) ;
let U := type of (H' x) in notHyp U ; specialize (H' x) end in H'
  | _ => fail
      end.

(* Instantiate a statement by trying to find an inhabitant in the local context (or by using
the canonical inhabitant of the CompDec typeclass *)
Ltac instantiate_inhab H :=
let T := type of H in
match T with
| forall (y : ?A), forall (z : ?B), _ => try (let inh := find_inh A in
let H' := instantiate_ident H inh in instantiate_inhab H' ; clear H)
| _ => idtac
end.

(* Instantiate polymorphic statements with a given tuple of subterms of type Type
and calls instantiate_inhab *)
Ltac instantiate_tuple_terms_inhab H t1 t2 := match t1 with
| (?x, ?t1') => try (let H' := instantiate_ident H x in
instantiate_tuple_terms_inhab H' t2 t2) ; try (instantiate_tuple_terms_inhab H t1' t2)
| impossible_term =>  let T := type of H in
           match T with
            | forall (y : ?A), _ => first [constr_eq A Type ; clear H | instantiate_inhab H]
            | _ => idtac
            end
end.

Ltac instantiate_tuple_terms_goal_inhab H t0 := let t0 := return_tuple_subterms_of_type_type in
let t := eval compute in t0 in instantiate_tuple_terms_inhab H t t.

Ltac get_projs_st_default_quote I t0 :=
let t := eval compute in t0 in
let H' := gen_statement I in
instantiate_tuple_terms_inhab H' t t.

Section tests_default.

Variable A : Type.
Variable a : A.

Goal nat -> A -> False.
let t0 := return_tuple_subterms_of_type_type in
get_projs_st_default_quote list t0. clear -a.
let t0 := return_tuple_subterms_of_type_type in
get_projs_st_default_quote Ind_test t0. clear -a.
let t0 := return_tuple_subterms_of_type_type in
get_projs_st_default_quote Ind_test2 t0. clear -a.
Abort.

End tests_default.

Fixpoint is_ind_not_in_list (t : term) (l : list term) :=
match t with
| tInd ind _ => let name := (inductive_mind ind).2 in match l with
         | nil => true
         | cons x xs => match x with
                           | tInd ind' _ => let name' := (inductive_mind ind').2 in if String.eqb name name' then false
else is_ind_not_in_list t xs
                           | _ => is_ind_not_in_list t xs
                        end
         end
| _ => false
end.

Fixpoint get_ind_of_prod_no_dup (t : term) (acc : list term) (acc' : list term) :=
match t with
| tProd _ A u => let I := (no_app A).1 in if is_ind_not_in_list I acc
then get_ind_of_prod_no_dup u (I:: acc) (I :: acc') else get_ind_of_prod_no_dup u acc acc'
| _ => acc'
end.

Definition get_ind_of_prod_no_dup_default t :=
get_ind_of_prod_no_dup t [bool_reif ; Z_reif; nat_reif ; eq_reif] [].

Ltac elims_on_list l t :=
match l with
| nil => idtac
| cons ?x ?xs => let u := metacoq_get_value (tmUnquote x) in
                 let I := eval hnf in (u.(my_projT2)) in
                 try (get_projs_st_default_quote I t) ; elims_on_list xs t
end.

Ltac get_projs_in_goal :=
let t0 := return_tuple_subterms_of_type_type in
let t := eval compute in t0 in
match goal with
| |- ?T => let T_reif := metacoq_get_value (tmQuote T) in
          let l := eval compute in (get_ind_of_prod_no_dup_default T_reif) in
          elims_on_list l t
end.

(* Checks if a given term is a variable *)
Ltac is_var v :=
let v_reif := metacoq_get_value (tmQuote v) in
match v_reif with
| tVar _ => idtac
| _ => fail
end.

(* Returns the tuple of variables in a local context *)
Ltac vars :=
match goal with
| v : _ |- _ => let _ := match goal with _ => is_var v ; revert v end in let acc := vars in
let _ := match goal with _ => intro v end in constr:((v, acc))
| _ => constr:(unit)
end.

Ltac get_projs_in_variables p :=
let t := vars in
let rec tac_rec v tuple :=
match v with
| (?v1, ?t') => let T := type of v1 in first [ let U := type of T in constr_eq U Prop ; tac_rec t' tuple |
                let I := get_head T in
                let params := get_tail T in
                try (is_not_in_tuple tuple T  ;
                get_projs_st_default_quote I params) ; try (tac_rec t' (tuple, T)) ]
| _ => idtac
end
in let prod_types0 := eval compute in p in tac_rec t prod_types0.

Section tests.

Inductive test: Set :=
    one : test
  | two : test
  | three : test
  | four : test
  | five : test
  | six : test.

Goal test -> False.

Proof. intros. get_projs_in_variables bool.
Abort.

End tests.