(** Copyright (c) 2015 Bill White **)
(** Distributed under the MIT/X11 software license **)
(** See http://www.opensource.org/licenses/mit-license.php **)

(** MathDoc: Representation of the doc part of higher-order logic
    (simple types, typed terms, proof terms) without the checking.
    This is following Egal by representing 'global definitions' by hash values.
    There are functions computing when a term or proof uses a global definition,
    and functions computing when a proof uses a "known" (a hash of a proposition
    which is either an axiom or previously proven proposition).
 **)

Require Export CryptoSignatures.

Inductive stp : Type :=
| prop : stp
| base : nat -> stp
| tvar : nat -> stp
| sar : stp -> stp -> stp.

Inductive trm : Type :=
| Gn : hashval -> trm
| Prm : nat -> list stp -> trm
| Db : nat -> trm
| Ap : trm -> trm -> trm
| La : stp -> trm -> trm
| Imp : trm -> trm -> trm
| All : stp -> trm -> trm.

Inductive pf : Type :=
| PDb : nat -> pf
| Gpn : hashval -> list stp -> pf
| PAp : pf -> pf -> pf
| TAp : pf -> trm -> pf
| PLa : trm -> pf -> pf
| TLa : stp -> pf -> pf.

Fixpoint ser_stp (a:stp) :=
match a with
| prop => (0::nil)
| base n => (1::n::nil)
| tvar n => (2::n::nil)
| sar a1 a2 => (3::ser_stp a1) ++ ser_stp a2
end.

Fixpoint hashstp (a:stp) : hashval :=
  match a with
    | prop => hashpair (hashnat 0) (hashnat 0)
    | base n => hashpair (hashnat 1) (hashnat n)
    | tvar n => hashpair (hashnat 2) (hashnat n)
    | sar a1 a2 => hashpair (hashnat 3) (hashpair (hashstp a1) (hashstp a2))
  end.

Fixpoint ser_stp_l al : list nat :=
match al with
| nil => (0::nil)
| (a::ar) => (1::ser_stp a) ++ ser_stp_l ar
end.

Fixpoint hashstpl (al:list stp) : option hashval :=
  match al with
    | nil => None
    | a::ar => Some (hashopair1 (hashstp a) (hashstpl ar))
  end.

Fixpoint ser_trm (m:trm) : list nat :=
match m with
| Gn h => 0::ser_hashval h
| Prm n al => 1::n::ser_stp_l al
| Db n => 2::n::nil
| Ap m n => 3::(ser_trm m) ++ (ser_trm n)
| La a m => 4::(ser_stp a) ++ (ser_trm m)
| Imp m n => 5::(ser_trm m) ++ (ser_trm n)
| All a m => 6::(ser_stp a) ++ (ser_trm m)
end.

(*** hashtrm - injective function from trm into hashval.
 This should not be confused with trm_hashroot below.
 ***)
Fixpoint hashtrm (m:trm) : hashval :=
match m with
| Gn h => hashpair (hashnat 4) h
| Prm i al => hashpair (hashnat 5) (hashopair1 (hashnat i) (hashstpl al))
| Db n => hashpair (hashnat 6) (hashnat n)
| Ap m n => hashpair (hashnat 7) (hashpair (hashtrm m) (hashtrm n))
| La a m => hashpair (hashnat 8) (hashpair (hashstp a) (hashtrm m))
| Imp m n => hashpair (hashnat 9) (hashpair (hashtrm m) (hashtrm n))
| All a m => hashpair (hashnat 10) (hashpair (hashstp a) (hashtrm m))
end.

(***
 This computes a hashroot for a trm relative to a theory.
 We need to have separate identifiers for the same term in different theories, especially for conjectures with bounties.
 Note that this is by design not injective since Gn's may abbreviate terms by giving their hashroot explicitly.
 hashtrm should be used when injectivity is needed.
 trm_hashroot will determine addresses where information about the trm is stored, and for POR purposes.
 ***)
Fixpoint trm_hashroot (th:option hashval) (m:trm) : hashval :=
  match m with
    | Gn h => h
    | Prm i al => hashopair2 th (hashpair (hashnat 11) (hashopair1 (hashnat i) (hashstpl al)))
    | Db i => hashopair2 th (hashpair (hashnat 12) (hashnat i))
    | Ap m n => hashopair2 th (hashpair (hashnat 13) (hashpair (trm_hashroot th m) (trm_hashroot th n)))
    | La a m => hashopair2 th (hashpair (hashnat 14) (hashpair (hashstp a) (trm_hashroot th m)))
    | Imp m n => hashopair2 th (hashpair (hashnat 15) (hashpair (trm_hashroot th m) (trm_hashroot th n)))
    | All a m => hashopair2 th (hashpair (hashnat 16) (hashpair (hashstp a) (trm_hashroot th m)))
  end.

Fixpoint ser_pf (d:pf) : list nat :=
match d with
| PDb n => 0::n::nil
| Gpn h al => 1::(ser_hashval h) ++ ser_stp_l al
| PAp d e => 2::(ser_pf d) ++ (ser_pf e)
| TAp d n => 3::(ser_pf d) ++ (ser_trm n)
| PLa p d => 4::(ser_trm p) ++ (ser_pf d)
| TLa a d => 5::(ser_stp a) ++ (ser_pf d)
end.

(*** This hashes a proof term. ***)
Fixpoint hashpf (d:pf) : hashval :=
match d with
| PDb n => hashpair (hashnat 17) (hashnat n)
| Gpn h al => hashpair (hashnat 18) (hashopair1 h (hashstpl al))
| PAp d e => hashpair (hashnat 19) (hashpair (hashpf d) (hashpf e))
| TAp d n => hashpair (hashnat 20) (hashpair (hashpf d) (hashtrm n))
| PLa p d => hashpair (hashnat 21) (hashpair (hashtrm p) (hashpf d))
| TLa a d => hashpair (hashnat 22) (hashpair (hashstp a) (hashpf d))
end.

(*** This computes a hashroot for a proof term relative to a theory. ***)
Fixpoint pf_hashroot (th:option hashval) (d:pf) : hashval :=
  match d with
    | PDb i => hashopair2 th (hashpair (hashnat 23) (hashnat i))
    | Gpn h al => hashopair2 th (hashpair (hashnat 24) (hashopair1 h (hashstpl al)))
    | PAp d e => hashopair2 th (hashpair (hashnat 25) (hashpair (pf_hashroot th d) (pf_hashroot th e)))
    | TAp d n => hashopair2 th (hashpair (hashnat 26) (hashpair (pf_hashroot th d) (trm_hashroot th n)))
    | PLa p d => hashopair2 th (hashpair (hashnat 27) (hashpair (trm_hashroot th p) (pf_hashroot th d)))
    | TLa a d => hashopair2 th (hashpair (hashnat 28) (hashpair (hashstp a) (pf_hashroot th d)))
  end.

(*** Theory (primitives and axioms, possibly with some helper definitions. No Gn should be here.) ***)
Inductive theoryitem : Type :=
| thyprim : stp -> theoryitem
| thyaxiom : trm -> theoryitem
.

(*** A theory is given as a stack of declarations. The first to be checked is at the end of the list. ***)
Definition theoryspec : Type := list theoryitem.

(*** The essential information we need to retrain about a theory consists of two parts:
 1. A list giving the stp of each primitive (Prm).
 2. A list giving hashvals of axioms.
 ***)
Definition theory : Type := prod (list stp) (list hashval).

Fixpoint theoryspec_primtps (thy:theoryspec) : list stp :=
  match thy with
    | nil => nil
    | thyprim a::thy => theoryspec_primtps thy ++ (a::nil)
    | _::thy => theoryspec_primtps thy
  end.

Definition hashtheoryitem (d:theoryitem) : hashval :=
match d with
| thyprim a => hashpair (hashnat 29) (hashstp a)
| thyaxiom p => hashpair (hashnat 30) (hashtrm p)
end.

Definition hashtheoryspec (dl : theoryspec) : hashval := hashlist (map hashtheoryitem dl).

Fixpoint theoryspec_hashroot (thy:theoryspec) : option hashval :=
match thy with
| nil => None
| thyprim a::thy => Some(hashopair1 (hashpair (hashnat 31) (hashstp a)) (theoryspec_hashroot thy))
| thyaxiom p::thy => Some(hashopair1 (hashpair (hashnat 32) (trm_hashroot None p)) (theoryspec_hashroot thy))
end.

Definition hashtheory (thy:theory) : option hashval :=
  match thy with
    | (nil,nil) => None
    | (al,hl) => Some(hashpair (hashlist (map hashstp al)) (hashlist hl))
  end.

Fixpoint theoryspec_hashedaxioms (h:option hashval) (thy:theoryspec) : list hashval :=
  match thy with
    | nil => nil
    | thyaxiom p::thy => trm_hashroot h p::theoryspec_hashedaxioms h thy
    | _::thy => theoryspec_hashedaxioms h thy
  end.

Definition theoryspec_theory (thy:theoryspec) : theory :=
  (theoryspec_primtps thy,theoryspec_hashedaxioms (theoryspec_hashroot thy) thy).

Definition ser_theoryitem (d : theoryitem) : list nat :=
match d with
| thyprim a => 1::ser_stp a
| thyaxiom p => 2::ser_trm p
end.

Fixpoint ser_theoryspec (dl : theoryspec) : list nat :=
match dl with
| nil => 0::nil
| (d::dr) => 1::ser_theoryitem d ++ ser_theoryspec dr
end.

(*** Signatures (parameters, definitions and knowns that can be imported into a document) ***)
Inductive signaitem : Type :=
| signasigna : hashval -> signaitem
| signaparam : hashval -> stp -> signaitem
| signadef : stp -> trm -> signaitem
| signaknown : trm -> signaitem
.

(*** A signature is given as a stack of declarations. The first to be checked is at the end of the list. ***)
Definition signaspec : Type := list signaitem.

Definition gsigna : Type := prod (list (prod hashval (prod stp (option trm)))) (list hashval).

Definition signa : Type := prod (list hashval) gsigna.

Definition ser_signaitem (d : signaitem) : list nat :=
match d with
| signasigna h => 0::ser_hashval h
| signaparam h a => 1::ser_hashval h ++ ser_stp a
| signadef a m => 2::ser_stp a ++ ser_trm m
| signaknown p => 3::ser_trm p
end.

Fixpoint ser_signaspec (dl : signaspec) : list nat :=
match dl with
| nil => 0::nil
| (d::dr) => 1::ser_signaitem d ++ ser_signaspec dr
end.

Definition hashsignaitem (d:signaitem) : hashval :=
match d with
  | signasigna h => hashpair (hashnat 33) h
  | signaparam h a => hashpair (hashnat 34) (hashpair h (hashstp a))
  | signadef a m => hashpair (hashnat 35) (hashpair (hashstp a) (hashtrm m))
  | signaknown p => hashpair (hashnat 36) (hashtrm p)
end.

Definition hashsignaspec (dl : signaspec) : hashval := hashlist (map hashsignaitem dl).

Fixpoint signaspec_hashroot (th:option hashval) (dl : signaspec) : hashval :=
  match dl with
    | nil => hashpair (hashnat 37) (hashnat 0)
    | signasigna h::dr => hashpair (hashnat 38) (hashpair h (signaspec_hashroot th dr))
    | signaparam h a::dr => hashpair (hashnat 39) (hashpair h (hashpair (hashstp a) (signaspec_hashroot th dr)))
    | signadef a m::dr => hashpair (hashnat 40) (hashpair (hashstp a) (hashpair (trm_hashroot th m) (signaspec_hashroot th dr)))
    | signaknown p::dr => hashpair (hashnat 41) (hashpair (trm_hashroot th p) (signaspec_hashroot th dr))
  end.

Definition hashgsigna (th:option hashval) (s : gsigna) : hashval :=
  match s with
    | (tl',kl) => hashpair (hashlist (map (fun z =>
                                            match z with
                                              | (h,(a,None)) => hashpair (hashnat 42) (hashpair h (hashstp a))
                                              | (h,(a,Some(m))) => hashpair (hashnat 43) (hashpair h (hashpair (hashstp a) (trm_hashroot th m)))
                                            end)
                                         tl'))
                          (hashlist kl)
  end.

Definition hashsigna (th:option hashval) (s : signa) : hashval :=
  match s with
    | (sl,(tl',kl)) => hashpair (hashlist sl) (hashgsigna th (tl',kl))
  end.

Fixpoint signaspec_trms (th:option hashval) (s:signaspec) : list (prod hashval (prod stp (option trm))) :=
  match s with
    | nil => nil
    | signaparam h a::s => (h,(a,None))::signaspec_trms th s
    | signadef a m::s => (trm_hashroot th m,(a,Some(m)))::signaspec_trms th s
    | _::s => signaspec_trms th s
  end.

Fixpoint signaspec_knowns (th:option hashval) (s:signaspec) : list hashval :=
  match s with
    | nil => nil
    | signaknown p::s => trm_hashroot th p::signaspec_knowns th s
    | _::s => signaspec_knowns th s
  end.

Fixpoint signaspec_signas (s:signaspec) : list hashval :=
  match s with
    | nil => nil
    | signasigna h::s => h::signaspec_signas s
    | _::s => signaspec_signas s
  end.

Definition signaspec_signa (th:option hashval) (s:signaspec) : signa :=
(signaspec_signas s,(signaspec_trms th s,signaspec_knowns th s)).

(*** Documents ***)
Inductive docitem : Type :=
| docsigna : hashval -> docitem
| docparam : hashval -> stp -> docitem
| docdef : stp -> trm -> docitem
| docknown : trm -> docitem
| docpfof : trm -> pf -> docitem
.

(*** A doc is given as a stack of declarations. The first to be checked is at the end of the list. ***)
Definition doc : Type := list docitem.

Definition ser_docitem (d : docitem) : list nat :=
match d with
| docsigna h => 0::ser_hashval h
| docparam h a => 1::ser_hashval h ++ ser_stp a
| docdef a m => 2::ser_stp a ++ ser_trm m
| docknown p => 3::ser_trm p
| docpfof p d => 4::ser_trm p ++ ser_pf d
end.

Fixpoint ser_doc (dl : doc) : list nat :=
match dl with
| nil => 0::nil
| (d::dr) => 1::ser_docitem d ++ ser_doc dr
end.

Definition hashdocitem (d : docitem) : hashval :=
match d with
| docsigna h => hashpair (hashnat 44) h
| docparam h a => hashpair (hashnat 45) (hashpair h (hashstp a))
| docdef a m => hashpair (hashnat 46) (hashpair (hashstp a) (hashtrm m))
| docknown p => hashpair (hashnat 47) (hashtrm p)
| docpfof p d => hashpair (hashnat 48) (hashpair (hashtrm p) (hashpf d))
end.

Definition hashdoc (dl : doc) : hashval := hashlist (map hashdocitem dl).

Definition docitem_hashroot (th:option hashval) (d : docitem) : hashval :=
match d with
| docsigna h => hashpair (hashnat 49) h
| docparam h a => hashpair (hashnat 50) (hashpair h (hashstp a))
| docdef a m => hashpair (hashnat 51) (hashpair (hashstp a) (trm_hashroot th m))
| docknown p => hashpair (hashnat 52) (trm_hashroot th p)
| docpfof p d => hashpair (hashnat 53) (hashpair (trm_hashroot th p) (pf_hashroot th d))
end.

Definition doc_hashroot (th:option hashval) (dl : doc) : hashval := hashlist (map (docitem_hashroot th) dl).

Lemma doc_hashroot_nil_eq th :
  doc_hashroot th nil = hashnat 0.
reflexivity.
Qed.

Lemma doc_hashroot_cons_eq th d dl :
  doc_hashroot th (d::dl) = hashpair (docitem_hashroot th d) (doc_hashroot th dl).
reflexivity.
Qed.

Lemma ser_stp_inj_lem a a' l l' : ser_stp a ++ l = ser_stp a' ++ l' -> l = l' /\ a = a'.
revert a' l l'. induction a as [| |n|a IHa b IHb]; intros [| |n'|a' b'] l l' H1; simpl in H1;
           try now (exfalso; inversion H1).
- inversion H1. tauto.
- inversion H1. tauto.
- inversion H1. tauto.
- rewrite <- app_assoc in H1. rewrite <- app_assoc in H1.
  inversion H1.
  destruct (IHa a' _ _ H0) as [H2 H3].
  destruct (IHb b' _ _ H2) as [H4 H5].
  subst l'. subst a'. subst b'. tauto.
Qed.

Lemma ser_stp_inj a a' : ser_stp a = ser_stp a' -> a = a'.
intros H1.
assert (L1: ser_stp a ++ nil = ser_stp a' ++ nil) by congruence.
generalize (ser_stp_inj_lem a a' nil nil L1). tauto.
Qed.

Lemma hashstpinj a a' : hashstp a = hashstp a' -> a = a'.
revert a'. induction a as [|i|n|a IHa b IHb]; intros [|i'|n'|a' b'] H1; simpl in H1;
           try (exfalso; apply hashnatinj in H1; omega);
           try (exfalso; revert H1; apply hashnatpairdiscr);
           try (exfalso; symmetry in H1; revert H1; apply hashnatpairdiscr);
           try (exfalso; apply hashpairinj in H1; destruct H1 as [H1 _]; apply hashnatinj in H1; omega).
- reflexivity.
- apply hashpairinj in H1. destruct H1 as [_ H1]. apply hashnatinj in H1.
  congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1]. apply hashnatinj in H1.
  congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply IHa in H2. apply IHb in H3.
  congruence.
Qed.

Lemma ser_stp_l_inj_lem al al' l l' : ser_stp_l al ++ l = ser_stp_l al' ++ l' -> l = l' /\ al = al'.
revert al' l l'. induction al as [|a al IH]; intros [|a' al'] l l' H1; simpl in H1;
                 try now (exfalso; inversion H1).
- inversion H1. split; congruence.
- inversion H1. rewrite <- app_assoc in H0. rewrite <- app_assoc in H0.
  destruct (ser_stp_inj_lem a a' _ _ H0) as [H2 H3].
  apply IH in H2. destruct H2 as [H4 H5].
  split; congruence.
Qed.

Inductive partialdoc : Type :=
| pdoc_nil : partialdoc
| pdoc_hash : hashval -> partialdoc
| pdoc_signa : hashval -> partialdoc -> partialdoc
| pdoc_param : hashval -> stp -> partialdoc -> partialdoc
| pdoc_param_hash : hashval -> partialdoc -> partialdoc
| pdoc_def : stp -> trm -> partialdoc -> partialdoc
| pdoc_def_hash : hashval -> partialdoc -> partialdoc
| pdoc_known : trm -> partialdoc -> partialdoc
| pdoc_pfof : trm -> pf -> partialdoc -> partialdoc
| pdoc_pfof_hash : hashval -> partialdoc -> partialdoc
.

Fixpoint partialdoc_hashroot (th:option hashval) (d : partialdoc) : hashval :=
match d with
| pdoc_nil => hashnat 0
| pdoc_hash h => h
| pdoc_signa h dr => hashpair (hashpair (hashnat 49) h) (partialdoc_hashroot th dr)
| pdoc_param h a dr => hashpair (hashpair (hashnat 50) (hashpair h (hashstp a))) (partialdoc_hashroot th dr)
| pdoc_param_hash h dr => hashpair (hashpair (hashnat 50) h) (partialdoc_hashroot th dr)
| pdoc_def a m dr => hashpair (hashpair (hashnat 51) (hashpair (hashstp a) (trm_hashroot th m))) (partialdoc_hashroot th dr)
| pdoc_def_hash h dr => hashpair (hashpair (hashnat 51) h) (partialdoc_hashroot th dr)
| pdoc_known p dr => hashpair (hashpair (hashnat 52) (trm_hashroot th p)) (partialdoc_hashroot th dr)
| pdoc_pfof p d dr => hashpair (hashpair (hashnat 53) (hashpair (trm_hashroot th p) (pf_hashroot th d))) (partialdoc_hashroot th dr)
| pdoc_pfof_hash h dr => hashpair (hashpair (hashnat 53) h) (partialdoc_hashroot th dr)
end.

Inductive doc_approx (th:option hashval) : partialdoc -> doc -> Prop :=
| doc_approx_nil : doc_approx th pdoc_nil nil
| doc_approx_hash h d : doc_hashroot th d = h -> doc_approx th (pdoc_hash h) d
| doc_approx_signa h dr dr': doc_approx th dr dr' -> doc_approx th (pdoc_signa h dr) (docsigna h::dr')
| doc_approx_param h a dr dr' : doc_approx th dr dr' -> doc_approx th (pdoc_param h a dr) (docparam h a::dr')
| doc_approx_param_hash h a dr dr' : doc_approx th dr dr' -> doc_approx th (pdoc_param_hash (hashpair h (hashstp a)) dr) (docparam h a::dr')
| doc_approx_def a m m' dr dr' : trm_hashroot th m = trm_hashroot th m' -> doc_approx th dr dr' -> doc_approx th (pdoc_def a m dr) (docdef a m'::dr')
| doc_approx_def_hash a m dr dr' : doc_approx th dr dr' -> doc_approx th (pdoc_def_hash (hashpair (hashstp a) (trm_hashroot th m)) dr) (docdef a m::dr')
| doc_approx_known p p' dr dr' : trm_hashroot th p = trm_hashroot th p' -> doc_approx th dr dr' -> doc_approx th (pdoc_known p dr) (docknown p'::dr')
| doc_approx_pfof p d p' d' dr dr' : trm_hashroot th p = trm_hashroot th p' -> pf_hashroot th d = pf_hashroot th d' -> doc_approx th dr dr' -> doc_approx th (pdoc_pfof p d dr) (docpfof p' d'::dr')
| doc_approx_pfof_hash p d dr dr' : doc_approx th dr dr' -> doc_approx th (pdoc_pfof_hash (hashpair (trm_hashroot th p) (pf_hashroot th d)) dr) (docpfof p d::dr')
.

Lemma doc_approx_hashroot_eq th dl dl' :
  doc_approx th dl dl' <-> partialdoc_hashroot th dl = doc_hashroot th dl'.
split.
- intros H1. induction H1.
  + simpl. reflexivity.
  + simpl. congruence.
  + simpl. rewrite IHdoc_approx. reflexivity.
  + simpl. rewrite IHdoc_approx. reflexivity.
  + simpl. rewrite IHdoc_approx. reflexivity.
  + simpl. rewrite IHdoc_approx. rewrite doc_hashroot_cons_eq. simpl. congruence.
  + simpl. rewrite IHdoc_approx. rewrite doc_hashroot_cons_eq. simpl. congruence.
  + simpl. rewrite IHdoc_approx. rewrite doc_hashroot_cons_eq. simpl. congruence.
  + simpl. rewrite IHdoc_approx. rewrite doc_hashroot_cons_eq. simpl. congruence.
  + simpl. rewrite IHdoc_approx. rewrite doc_hashroot_cons_eq. simpl. congruence.
- revert dl'. induction dl; intros [|[h'|h' a'|a' m'|p'|p' d'] dr'];
              try now (simpl; intros H1; exfalso; revert H1; apply hashnatpairdiscr).
  + intros _. apply doc_approx_nil.
  + simpl. intros H1. apply doc_approx_hash. congruence.
  + simpl. intros H1. apply doc_approx_hash. congruence.
  + simpl. intros H1. apply doc_approx_hash. congruence.
  + simpl. intros H1. apply doc_approx_hash. congruence.
  + simpl. intros H1. apply doc_approx_hash. congruence.
  + simpl. intros H1. apply doc_approx_hash. congruence.
  + simpl. intros H1. exfalso. symmetry in H1. revert H1. apply hashnatpairdiscr.
  + simpl. intros H1. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [_ H2]. subst h'.
    apply doc_approx_signa. apply IHdl. exact H3.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_nil_eq in H1.
    symmetry in H1. revert H1. apply hashnatpairdiscr.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [_ H2].
    apply hashpairinj in H2. destruct H2 as [H4 H5].
    apply hashstpinj in H5. subst s. subst h.
    apply doc_approx_param. apply IHdl. exact H3.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_nil_eq in H1.
    symmetry in H1. revert H1. apply hashnatpairdiscr.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [_ H2]. subst h.
    apply doc_approx_param_hash. apply IHdl. exact H3.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_nil_eq in H1.
    symmetry in H1. revert H1. apply hashnatpairdiscr.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [_ H2].
    apply hashpairinj in H2. destruct H2 as [H4 H5].
    apply hashstpinj in H4. subst s.
    apply doc_approx_def.
    * exact H5.
    * apply IHdl. exact H3.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_nil_eq in H1.
    symmetry in H1. revert H1. apply hashnatpairdiscr.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [_ H2].
    subst h.
    apply doc_approx_def_hash.
    apply IHdl. exact H3.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_nil_eq in H1.
    symmetry in H1. revert H1. apply hashnatpairdiscr.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [_ H2].
    apply doc_approx_known.
    * assumption.
    * apply IHdl. exact H3.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_nil_eq in H1.
    symmetry in H1. revert H1. apply hashnatpairdiscr.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [_ H2].
    apply hashpairinj in H2. destruct H2 as [H4 H5].
    apply doc_approx_pfof.
    * exact H4.
    * exact H5.
    * apply IHdl. exact H3.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_nil_eq in H1.
    symmetry in H1. revert H1. apply hashnatpairdiscr.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. exfalso. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [H2 _].
    apply hashnatinj in H2. omega.
  + simpl. intros H1. rewrite doc_hashroot_cons_eq in H1.
    apply hashpairinj in H1.
    destruct H1 as [H2 H3].
    simpl in H2. apply hashpairinj in H2. destruct H2 as [_ H2].
    subst h.
    apply doc_approx_pfof_hash.
    apply IHdl. exact H3.
Qed.

Lemma ser_trm_inj_lem m m' l l' : ser_trm m ++ l = ser_trm m' ++ l' -> l = l' /\ m = m'.
revert m' l l'. induction m as [h|n al|n|m IHm n IHn|a m IHm|m IHm n IHn|a m IHm]; intros [h'|n' al'|n'|m' n'|a' m'|m' n'|a' m'] l l' H1; simpl in H1;
           try now (exfalso; inversion H1).
- inversion H1.
  destruct (ser_hashval_inj h h' _ _ H0) as [H2 H3].
  split; congruence.
- inversion H1.
  apply ser_stp_l_inj_lem in H2. destruct H2 as [H4 H5].
  split; congruence.
- inversion H1. tauto.
- inversion H1. rewrite <- app_assoc in H0. rewrite <- app_assoc in H0.
  destruct (IHm _ _ _ H0) as [H2 H3].
  destruct (IHn _ _ _ H2) as [H4 H5].
  split; congruence.
- inversion H1. rewrite <- app_assoc in H0. rewrite <- app_assoc in H0.
  destruct (ser_stp_inj_lem _ _ _ _ H0) as [H2 H3].
  destruct (IHm _ _ _ H2) as [H4 H5].
  split; congruence.
- inversion H1. rewrite <- app_assoc in H0. rewrite <- app_assoc in H0.
  destruct (IHm _ _ _ H0) as [H2 H3].
  destruct (IHn _ _ _ H2) as [H4 H5].
  split; congruence.
- inversion H1. rewrite <- app_assoc in H0. rewrite <- app_assoc in H0.
  destruct (ser_stp_inj_lem _ _ _ _ H0) as [H2 H3].
  destruct (IHm _ _ _ H2) as [H4 H5].
  split; congruence.
Qed.

Lemma ser_trm_inj m m' : ser_trm m = ser_trm m' -> m = m'.
intros H1.
assert (L1: ser_trm m ++ nil = ser_trm m' ++ nil) by congruence.
generalize (ser_trm_inj_lem m m' nil nil L1). tauto.
Qed.

Lemma ser_pf_inj_lem d d' l l' : ser_pf d ++ l = ser_pf d' ++ l' -> l = l' /\ d = d'.
revert d' l l'. induction d as [n|h al|d IHd e IHe|d IHd n|n d IHd|a d IHd]; intros [n'|h' al'|d' e'|d' n'|n' d'|a' d'] l l' H1; simpl in H1;
                try now (exfalso; inversion H1).
- inversion H1. tauto.
- rewrite <- app_assoc in H1. rewrite <- app_assoc in H1.
  inversion H1.
  destruct (ser_hashval_inj h h' _ _ H0) as [H2 H3].
  apply ser_stp_l_inj_lem in H2. destruct H2 as [H4 H5].
  split; congruence.
- inversion H1. rewrite <- app_assoc in H0. rewrite <- app_assoc in H0.
  destruct (IHd _ _ _ H0) as [H2 H3].
  destruct (IHe _ _ _ H2) as [H4 H5].
  split; congruence.
- inversion H1. rewrite <- app_assoc in H0. rewrite <- app_assoc in H0.
  destruct (IHd _ _ _ H0) as [H2 H3].
  destruct (ser_trm_inj_lem _ _ _ _ H2) as [H4 H5].
  split; congruence.
- inversion H1. rewrite <- app_assoc in H0. rewrite <- app_assoc in H0.
  destruct (ser_trm_inj_lem _ _ _ _ H0) as [H2 H3].
  destruct (IHd _ _ _ H2) as [H4 H5].
  split; congruence.
- inversion H1. rewrite <- app_assoc in H0. rewrite <- app_assoc in H0.
  destruct (ser_stp_inj_lem _ _ _ _ H0) as [H2 H3].
  destruct (IHd _ _ _ H2) as [H4 H5].
  split; congruence.
Qed.

Lemma ser_pf_inj d d' : ser_pf d = ser_pf d' -> d = d'.
intros H1.
assert (L1: ser_pf d ++ nil = ser_pf d' ++ nil) by congruence.
generalize (ser_pf_inj_lem d d' nil nil L1). tauto.
Qed.

Lemma ser_theoryitem_inj_lem d d' l l' : ser_theoryitem d ++ l = ser_theoryitem d' ++ l' -> l = l' /\ d = d'.
destruct d as [a|p]; destruct d' as [a'|p']; simpl; intros H1; try now (exfalso; inversion H1).
- inversion H1.
  destruct (ser_stp_inj_lem _ _ _ _ H0) as [H4 H5].
  split; congruence.
- inversion H1.
  destruct (ser_trm_inj_lem _ _ _ _ H0) as [H2 H3].
  split; congruence.
Qed.

Lemma ser_theoryitem_inj d d' : ser_theoryitem d = ser_theoryitem d' -> d = d'.
intros H1.
assert (L1: ser_theoryitem d ++ nil = ser_theoryitem d' ++ nil) by congruence.
generalize (ser_theoryitem_inj_lem d d' nil nil L1). tauto.
Qed.

Lemma ser_theoryspec_inj_lem dl dl' l l' : ser_theoryspec dl ++ l = ser_theoryspec dl' ++ l' -> l = l' /\ dl = dl'.
revert dl' l l'. induction dl as [|d dl IH]; intros [|d' dl'] l l' H1; simpl in H1;
                 try now (exfalso; inversion H1).
- inversion H1. split; congruence.
- inversion H1. rewrite <- app_assoc in H0. rewrite <- app_assoc in H0.
  destruct (ser_theoryitem_inj_lem d d' _ _ H0) as [H2 H3].
  apply IH in H2. destruct H2 as [H4 H5].
  split; congruence.
Qed.

Lemma ser_theoryspec_inj dl dl' : ser_theoryspec dl = ser_theoryspec dl' -> dl = dl'.
intros H1.
assert (L1: ser_theoryspec dl ++ nil = ser_theoryspec dl' ++ nil) by congruence.
generalize (ser_theoryspec_inj_lem dl dl' nil nil L1). tauto.
Qed.

Lemma ser_signaitem_inj_lem d d' l l' : ser_signaitem d ++ l = ser_signaitem d' ++ l' -> l = l' /\ d = d'.
destruct d as [h|h a|a m|p]; destruct d' as [h'|h' a'|a' m'|p']; simpl; intros H1; try now (exfalso; inversion H1).
- inversion H1.
  destruct (ser_hashval_inj _ _ _ _ H0) as [H2 H3].
  split; congruence.
- inversion H1. rewrite <- app_assoc in H0. rewrite <- app_assoc in H0.
  destruct (ser_hashval_inj _ _ _ _ H0) as [H2 H3].
  destruct (ser_stp_inj_lem _ _ _ _ H2) as [H4 H5].
  split; congruence.
- inversion H1. rewrite <- app_assoc in H0. rewrite <- app_assoc in H0.
  destruct (ser_stp_inj_lem _ _ _ _ H0) as [H2 H3].
  destruct (ser_trm_inj_lem _ _ _ _ H2) as [H4 H5].
  split; congruence.
- inversion H1.
  destruct (ser_trm_inj_lem _ _ _ _ H0) as [H2 H3].
  split; congruence.
Qed.

Lemma ser_signaitem_inj d d' : ser_signaitem d = ser_signaitem d' -> d = d'.
intros H1.
assert (L1: ser_signaitem d ++ nil = ser_signaitem d' ++ nil) by congruence.
generalize (ser_signaitem_inj_lem d d' nil nil L1). tauto.
Qed.

Lemma ser_signaspec_inj_lem dl dl' l l' : ser_signaspec dl ++ l = ser_signaspec dl' ++ l' -> l = l' /\ dl = dl'.
revert dl' l l'. induction dl as [|d dl IH]; intros [|d' dl'] l l' H1; simpl in H1;
                 try now (exfalso; inversion H1).
- inversion H1. split; congruence.
- inversion H1. rewrite <- app_assoc in H0. rewrite <- app_assoc in H0.
  destruct (ser_signaitem_inj_lem d d' _ _ H0) as [H2 H3].
  apply IH in H2. destruct H2 as [H4 H5].
  split; congruence.
Qed.

Lemma ser_signaspec_inj dl dl' : ser_signaspec dl = ser_signaspec dl' -> dl = dl'.
intros H1.
assert (L1: ser_signaspec dl ++ nil = ser_signaspec dl' ++ nil) by congruence.
generalize (ser_signaspec_inj_lem dl dl' nil nil L1). tauto.
Qed.

Lemma ser_docitem_inj_lem d d' l l' : ser_docitem d ++ l = ser_docitem d' ++ l' -> l = l' /\ d = d'.
destruct d as [h|h a|a m|p|p d]; destruct d' as [h'|h' a'|a' m'|p'|p' d']; simpl; intros H1; try now (exfalso; inversion H1).
- inversion H1.
  destruct (ser_hashval_inj _ _ _ _ H0) as [H2 H3].
  split; congruence.
- inversion H1. rewrite <- app_assoc in H0. rewrite <- app_assoc in H0.
  destruct (ser_hashval_inj _ _ _ _ H0) as [H2 H3].
  destruct (ser_stp_inj_lem _ _ _ _ H2) as [H4 H5].
  split; congruence.
- inversion H1. rewrite <- app_assoc in H0. rewrite <- app_assoc in H0.
  destruct (ser_stp_inj_lem _ _ _ _ H0) as [H2 H3].
  destruct (ser_trm_inj_lem _ _ _ _ H2) as [H4 H5].
  split; congruence.
- inversion H1.
  destruct (ser_trm_inj_lem _ _ _ _ H0) as [H2 H3].
  split; congruence.
- inversion H1. rewrite <- app_assoc in H0. rewrite <- app_assoc in H0.
  destruct (ser_trm_inj_lem _ _ _ _ H0) as [H2 H3].
  destruct (ser_pf_inj_lem _ _ _ _ H2) as [H4 H5].
  split; congruence.
Qed.

Lemma ser_docitem_inj d d' : ser_docitem d = ser_docitem d' -> d = d'.
intros H1.
assert (L1: ser_docitem d ++ nil = ser_docitem d' ++ nil) by congruence.
generalize (ser_docitem_inj_lem d d' nil nil L1). tauto.
Qed.

Lemma ser_doc_inj_lem dl dl' l l' : ser_doc dl ++ l = ser_doc dl' ++ l' -> l = l' /\ dl = dl'.
revert dl' l l'. induction dl as [|d dl IH]; intros [|d' dl'] l l' H1; simpl in H1;
                 try now (exfalso; inversion H1).
- inversion H1. split; congruence.
- inversion H1. rewrite <- app_assoc in H0. rewrite <- app_assoc in H0.
  destruct (ser_docitem_inj_lem d d' _ _ H0) as [H2 H3].
  apply IH in H2. destruct H2 as [H4 H5].
  split; congruence.
Qed.

Lemma ser_doc_inj dl dl' : ser_doc dl = ser_doc dl' -> dl = dl'.
intros H1.
assert (L1: ser_doc dl ++ nil = ser_doc dl' ++ nil) by congruence.
generalize (ser_doc_inj_lem dl dl' nil nil L1). tauto.
Qed.

Lemma hashstplinj al al' : hashstpl al = hashstpl al' -> al = al'.
revert al'. induction al as [|a ar IH]; intros [|a' ar'].
- intros _. reflexivity.
- simpl. intros H1. discriminate H1.
- simpl. intros H1. discriminate H1.
- simpl. intros H1. inversion H1.
  apply hashopair1inj in H0.
  destruct H0 as [H2 H3].
  apply hashstpinj in H2. apply IH in H3.
  congruence.
Qed.

Lemma hashtrminj m m' : hashtrm m = hashtrm m' -> m = m'.
revert m'. induction m as [h|i al|n|m IHm n IHn|a m IHm|m IHm n IHn|a m IHm]; intros [h'|i' al'|n'|m' n'|a' m'|m' n'|a' m'] H1; simpl in H1;
           try (exfalso; apply hashpairinj in H1; destruct H1 as [H1 _]; apply hashnatinj in H1; omega).
- apply hashpairinj in H1. destruct H1 as [_ H1]. congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashopair1inj in H1. destruct H1 as [H2 H3].
  apply hashnatinj in H2. apply hashstplinj in H3.
  congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1]. apply hashnatinj in H1.
  congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply IHm in H2. apply IHn in H3.
  congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply hashstpinj in H2. apply IHm in H3.
  congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply IHm in H2. apply IHn in H3.
  congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply hashstpinj in H2. apply IHm in H3.
  congruence.
Qed.

Lemma hashpfinj d d' : hashpf d = hashpf d' -> d = d'.
revert d'. induction d as [n|h al|d IHd e IHe|d IHd n|n d IHd|a d IHd]; intros [n'|h' al'|d' e'|d' n'|n' d'|a' d'] H1; simpl in H1;
           try (exfalso; apply hashpairinj in H1; destruct H1 as [H1 _]; apply hashnatinj in H1; omega).
- apply hashpairinj in H1. destruct H1 as [_ H1]. apply hashnatinj in H1.
  congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashopair1inj in H1. destruct H1 as [H2 H3].
  apply hashstplinj in H3.
  congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply IHd in H2. apply IHe in H3.
  congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply IHd in H2. apply hashtrminj in H3.
  congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply hashtrminj in H2. apply IHd in H3.
  congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply hashstpinj in H2. apply IHd in H3.
  congruence.
Qed.

Lemma hashtheoryiteminj d d' : hashtheoryitem d = hashtheoryitem d' -> d = d'.
destruct d as [a|p]; destruct d' as [a'|p']; simpl; intros H1; try (exfalso; apply hashpairinj in H1; destruct H1 as [H1 _]; apply hashnatinj in H1; omega).
- apply hashpairinj in H1. destruct H1 as [_ H1]. apply hashstpinj in H1. congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashtrminj in H1.
  congruence.
Qed.

Lemma hashtheoryspecinj dl dl' : hashtheoryspec dl = hashtheoryspec dl' -> dl = dl'.
intros H1. apply hashlistinj in H1. apply hashmapinj in H1.
- exact H1.
- exact hashtheoryiteminj.
Qed.

Lemma hashsignaiteminj d d' : hashsignaitem d = hashsignaitem d' -> d = d'.
destruct d as [h|a|a m|p]; destruct d' as [h'|a'|a' m'|p']; simpl; intros H1; try (exfalso; apply hashpairinj in H1; destruct H1 as [H1 _]; apply hashnatinj in H1; omega).
- apply hashpairinj in H1. destruct H1 as [_ H1]. congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply hashstpinj in H3. congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply hashstpinj in H2. apply hashtrminj in H3.
  congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashtrminj in H1.
  congruence.
Qed.

Lemma hashsignaspecinj dl dl' : hashsignaspec dl = hashsignaspec dl' -> dl = dl'.
intros H1. apply hashlistinj in H1. apply hashmapinj in H1.
- exact H1.
- exact hashsignaiteminj.
Qed.

Lemma hashdociteminj d d' : hashdocitem d = hashdocitem d' -> d = d'.
destruct d as [h|h a|a m|p|p d]; destruct d' as [h'|h' a'|a' m'|p'|p' d']; simpl; intros H1; try (exfalso; apply hashpairinj in H1; destruct H1 as [H1 _]; apply hashnatinj in H1; omega).
- apply hashpairinj in H1. destruct H1 as [_ H1]. congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply hashstpinj in H3.
  congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply hashstpinj in H2.
  apply hashtrminj in H3.
  congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashtrminj in H1.
  congruence.
- apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply hashtrminj in H2.
  apply hashpfinj in H3.
  congruence.
Qed.

Lemma hashdocinj dl dl' : hashdoc dl = hashdoc dl' -> dl = dl'.
intros H1. apply hashlistinj in H1. apply hashmapinj in H1.
- exact H1.
- exact hashdociteminj.
Qed.

Definition stp_eq_dec (a a' : stp) : {a = a'} + {a <> a'}.
repeat decide equality.
Defined.

Definition trm_eq_dec (m m' : trm) : {m = m'} + {m <> m'}.
repeat decide equality. apply hashval_eq_dec.
Defined.

Definition pf_eq_dec (d d' : pf) : {d = d'} + {d <> d'}.
repeat decide equality; apply hashval_eq_dec.
Defined.

Definition theoryitem_eq_dec (d d':theoryitem) : {d = d'} + {d <> d'}.
destruct d as [a|p]; destruct d' as [a'|p']; try (right; discriminate).
- repeat decide equality; try apply hashval_eq_dec.
- repeat decide equality; try apply hashval_eq_dec.
Defined.

Definition theoryspec_eq_dec (dl dl':theoryspec) : {dl = dl'} + {dl <> dl'}.
revert dl'. induction dl as [|d dl IH]; intros [|d' dl']; try (right; discriminate).
- left. reflexivity.
- destruct (theoryitem_eq_dec d d') as [D1|D1].
  + destruct (IH dl') as [D2|D2].
    * left. congruence.
    * right. intros H1. inversion H1. tauto.
  + right. intros H1. inversion H1. tauto.
Defined.

Definition signaitem_eq_dec (d d':signaitem) : {d = d'} + {d <> d'}.
destruct d as [h|h a|a m|p]; destruct d' as [h'|h' a'|a' m'|p']; try (right; discriminate).
- repeat decide equality; try apply hashval_eq_dec.
- repeat decide equality; try apply hashval_eq_dec.
- repeat decide equality; try apply hashval_eq_dec.
- repeat decide equality; try apply hashval_eq_dec.
Defined.

Definition signaspec_eq_dec (dl dl':signaspec) : {dl = dl'} + {dl <> dl'}.
revert dl'. induction dl as [|d dl IH]; intros [|d' dl']; try (right; discriminate).
- left. reflexivity.
- destruct (signaitem_eq_dec d d') as [D1|D1].
  + destruct (IH dl') as [D2|D2].
    * left. congruence.
    * right. intros H1. inversion H1. tauto.
  + right. intros H1. inversion H1. tauto.
Defined.

Definition docitem_eq_dec (d d':docitem) : {d = d'} + {d <> d'}.
destruct d as [h|h a|a m|p|p d]; destruct d' as [h'|h' a'|a' m'|p'|p' d']; try (right; discriminate).
- repeat decide equality; try apply hashval_eq_dec.
- repeat decide equality; try apply hashval_eq_dec.
- repeat decide equality; try apply hashval_eq_dec.
- repeat decide equality; try apply hashval_eq_dec.
- repeat decide equality; try apply hashval_eq_dec.
Defined.

Definition doc_eq_dec (dl dl':doc) : {dl = dl'} + {dl <> dl'}.
revert dl'. induction dl as [|d dl IH]; intros [|d' dl']; try (right; discriminate).
- left. reflexivity.
- destruct (docitem_eq_dec d d') as [D1|D1].
  + destruct (IH dl') as [D2|D2].
    * left. congruence.
    * right. intros H1. inversion H1. tauto.
  + right. intros H1. inversion H1. tauto.
Defined.

Fixpoint signaspec_uses_objs (dl:signaspec) : list hashval :=
match dl with
| signaparam h _::dr => h::signaspec_uses_objs dr
| _::dr => signaspec_uses_objs dr
| nil => nil
end.

Fixpoint signaspec_uses_props (th:option hashval) (dl:signaspec) : list hashval :=
match dl with
| signaknown p::dr => trm_hashroot th p::signaspec_uses_props th dr
| _::dr => signaspec_uses_props th dr
| nil => nil
end.

Fixpoint signaspec_stp_markers (dl:signaspec) : list hashval :=
match dl with
| signaparam h a::dr => hashpair h (hashstp a)::signaspec_stp_markers dr
| signaknown p::dr => signaspec_stp_markers dr
| _::dr => signaspec_stp_markers dr
| nil => nil
end.

Fixpoint signaspec_known_markers (th:option hashval) (dl:signaspec) : list hashval :=
match dl with
| signaparam h a::dr => signaspec_known_markers th dr
| signaknown p::dr => trm_hashroot th p::signaspec_known_markers th dr
| _::dr => signaspec_known_markers th dr
| nil => nil
end.

Fixpoint doc_stp_markers (dl:doc) : list hashval :=
match dl with
| docparam h a::dr => hashpair h (hashstp a)::doc_stp_markers dr
| docknown p::dr => doc_stp_markers dr
| _::dr => doc_stp_markers dr
| nil => nil
end.

Fixpoint doc_known_markers (th:option hashval) (dl:doc) : list hashval :=
match dl with
| docparam h a::dr => doc_known_markers th dr
| docknown p::dr => trm_hashroot th p::doc_known_markers th dr
| _::dr => doc_known_markers th dr
| nil => nil
end.

Fixpoint doc_uses_objs (dl:doc) : list hashval :=
match dl with
| docparam h _::dr => h::doc_uses_objs dr
| _::dr => doc_uses_objs dr
| nil => nil
end.

Fixpoint doc_uses_props (th:option hashval) (dl:doc) : list hashval :=
match dl with
| docknown p::dr => trm_hashroot th p::doc_uses_props th dr
| _::dr => doc_uses_props th dr
| nil => nil
end.

Fixpoint doc_creates_objs (th:option hashval) (dl:doc) : list (prod hashval hashval) :=
match dl with
| docdef a m::dr => (trm_hashroot th m,hashstp a)::doc_creates_objs th dr
| _::dr => doc_creates_objs th dr
| nil => nil
end.

Fixpoint doc_creates_props (th:option hashval) (dl:doc) : list (prod hashval hashval) :=
match dl with
| docpfof p d::dr => (trm_hashroot th p,pf_hashroot th d)::doc_creates_props th dr
| _::dr => doc_creates_props th dr
| nil => nil
end.

Fixpoint htree (A:Type) (n:nat) : Type :=
  match n with
    | 0 => A
    | S n => prod (option (htree A n)) (option (htree A n))
  end.

Fixpoint htree_lookup {A:Type} {n:nat} : bitseq n -> htree A n -> option A :=
match n as n' return bitseq n' -> htree A n' -> option A with
| 0 => fun bs a => Some(a)
| S n => fun bs t =>
           match bs,t with
             | (false,br),(Some(t),_) => htree_lookup br t
             | (true,br),(_,Some(t)) => htree_lookup br t
             | _,_ => None
           end
end.

Fixpoint htree_create {A:Type} {n:nat} : bitseq n -> A -> htree A n :=
match n with
  | 0 => fun bs a => a
  | S n => fun bs a =>
             match bs with
               | (false,br) => (Some(htree_create br a),None)
               | (true,br) => (None,Some(htree_create br a))
             end
end.

Fixpoint htree_insert {A:Type} {n:nat} :  htree A n -> bitseq n -> A -> htree A n :=
match n with
  | 0 => fun t bs a => a
  | S n => fun t bs a =>
             match bs,t with
               | (false,br),(Some(t0),t1) => (Some(htree_insert t0 br a),t1)
               | (true,br),(t0,Some(t1)) => (t0,Some(htree_insert t1 br a))
               | (false,br),(None,t1) => (Some(htree_create br a),t1)
               | (true,br),(t0,None) => (t0,Some(htree_create br a))
             end
end.

Fixpoint ohtree_hashroot {A:Type} {n:nat} (f:A -> option hashval) : option (htree A n) -> option hashval :=
  match n with
    | 0 => fun a =>
             match a with
               | Some(a) => f a
               | None => None
             end
    | S n => fun t =>
               match t with
                 | Some(t0,t1) => hashopair (ohtree_hashroot f t0) (ohtree_hashroot f t1)
                 | None => None
               end
  end.

Definition ttree (n:nat) := htree theory n.

Definition stree (n:nat) := htree (option hashval * signa) n.

Definition theory_lookup {n} (h:bitseq n) (t:ttree n) : theory :=
  match htree_lookup h t with
    | Some(thy) => thy
    | None => (nil,nil)
  end.

Definition signa_lookup {n} (bs:bitseq n) (t:stree n) : option hashval * signa :=
  match htree_lookup bs t with
    | Some(th,s) => (th,s)
    | None => (None,(nil,(nil,nil)))
  end.

Definition ottree_insert {n} (t:option (ttree n)) (bs:bitseq n) (thy:theory) : ttree n :=
  match t with
    | Some(t) => htree_insert t bs thy
    | None => htree_create bs thy
  end.

Definition ostree_insert {n} (t:option (stree n)) (bs:bitseq n) (th:option hashval) (s:signa) : stree n :=
  match t with
    | Some(t) => htree_insert t bs (th,s)
    | None => htree_create bs (th,s)
  end.

Definition ottree_hashroot {n} (t:option (ttree n)) : option hashval :=
  ohtree_hashroot hashtheory t.

Definition ostree_hashroot {n} (t:option (stree n)) : option hashval :=
  ohtree_hashroot (fun ths: option hashval * signa =>
                     let (th,s) := ths in
                     Some(hashopair2 th (hashsigna th s)))
                  t.

(*** type checking and proof checking, left abstract here ***)

(*** Check if a trm (with no Gn's) has an stp under a certain (partial) theory. ***)
Parameter check_thy_trm_tp_p : theory -> trm -> stp -> Prop.

Fixpoint check_theoryspec_p (thy:theoryspec) : Prop :=
   match thy with
     | nil => True
     | thyprim a::thy => check_theoryspec_p thy
     | thyaxiom p::thy => check_theoryspec_p thy /\ check_thy_trm_tp_p (theoryspec_theory thy) p prop
   end.

(*** Check if a [trm has an stp|pf is of a prop] under a certain theory and signature.
 The theory hash is also given since it would be needed to hash.
 It could be recomputed from the theory, but there is no need for this.
 The trm should not contain any closed terms except Gn's.
 ***)
Parameter check_trm_tp_p : option hashval -> theory -> signa -> trm -> stp -> Prop.

Parameter check_pf_prop_p : option hashval -> theory -> signa -> pf -> trm -> Prop.

(***
 gvtp is a generic way of verifying the term with a certain hashval has a certain stp
 and gvkn is a generic way of verifying the prop with a certain hashval is known.
 In practice this will be computed using a compact tree (CTree) approximating the state.
 st is the stree for looking up signatures (signa). Each node will keep up with this.
 Using signatures reduces the need to repeat objects/knowns that are often used.
 th is the hashval of the theory (None is the empty theory).
 thy is the theory whose theoryspec has hash th.
 ***)
Fixpoint check_signaspec_r (gvtp : hashval -> stp -> Prop) (gvkn : hashval -> Prop)
         (st:option (stree 160)) (th:option hashval) (thy:theory) (s:signaspec) : Prop :=
   match s with
     | nil => True
     | signasigna h::s =>
       match st with
         | None => False
         | Some(st1) =>
           match signa_lookup (hashval_bit160 h) st1 with
             | (sth,(al,kl)) => check_signaspec_r gvtp gvkn st th thy s /\ sth = th
           end
       end
     | signaparam h a::s => check_signaspec_r gvtp gvkn st th thy s /\ gvtp h a
     | signadef a m::s => check_signaspec_r gvtp gvkn st th thy s /\ check_trm_tp_p th thy (signaspec_signa th s) m a
     | signaknown p::s => check_signaspec_r gvtp gvkn st th thy s /\ gvkn (trm_hashroot th p)
   end.

Definition check_signaspec_p (gvtp : hashval -> stp -> Prop) (gvkn : hashval -> Prop)
           (t:option (ttree 160)) (st:option (stree 160)) (th:option hashval) (s:signaspec) : Prop :=
  match th with
    | None => check_signaspec_r gvtp gvkn st th (nil,nil) s
    | Some(h) =>
      match t with
        | None => False
        | Some(t) => check_signaspec_r gvtp gvkn st th (theory_lookup (hashval_bit160 h) t) s
      end
  end.

Fixpoint doc_signas (dl:doc) : list hashval :=
  match dl with
    | nil => nil
    | docsigna h::dr => h::doc_signas dr
    | _::dr => doc_signas dr
  end.

Fixpoint doc_trms (th:option hashval) (dl:doc) : list (prod hashval (prod stp (option trm))) :=
  match dl with
    | nil => nil
    | docparam h a::dr => (h,(a,None))::doc_trms th dr
    | docdef a m::dr => (trm_hashroot th m,(a,Some(m)))::doc_trms th dr
    | _::dr => doc_trms th dr
  end.

Fixpoint doc_knowns (th:option hashval) (dl:doc) : list hashval :=
  match dl with
    | nil => nil
    | docknown p::dr => trm_hashroot th p::doc_knowns th dr
    | docpfof p _::dr => trm_hashroot th p::doc_knowns th dr
    | _::dr => doc_knowns th dr
  end.

Definition doc_signa (th:option hashval) (dl:doc) : signa :=
(doc_signas dl,(doc_trms th dl,doc_knowns th dl)).

Fixpoint check_doc_r (gvtp : hashval -> stp -> Prop) (gvkn : hashval -> Prop)
         (st:option (stree 160)) (th:option hashval) (thy:theory) (dl:doc) : Prop :=
   match dl with
     | nil => True
     | docsigna h::dr =>
       match st with
         | None => False
         | Some(st1) =>
           match signa_lookup (hashval_bit160 h) st1 with
             | (sth,(al,kl)) => check_doc_r gvtp gvkn st th thy dr /\ sth = th
           end
       end
     | docparam h a::dr => check_doc_r gvtp gvkn st th thy dr /\ gvtp h a
     | docdef a m::dr => check_doc_r gvtp gvkn st th thy dr /\ check_trm_tp_p th thy (doc_signa th dr) m a
     | docknown p::dr => check_doc_r gvtp gvkn st th thy dr /\ gvkn (trm_hashroot th p)
     | docpfof p d::dr => check_doc_r gvtp gvkn st th thy dr /\ check_pf_prop_p th thy (doc_signa th dr) d p
   end.

Definition check_doc_p (gvtp : hashval -> stp -> Prop) (gvkn : hashval -> Prop)
           (t:option (ttree 160)) (st:option (stree 160)) (th:option hashval) (dl:doc) : Prop :=
  match th with
    | None => check_doc_r gvtp gvkn st th (nil,nil) dl
    | Some(h) =>
      match t with
        | None => False
        | Some(t) => check_doc_r gvtp gvkn st th (theory_lookup (hashval_bit160 h) t) dl
      end
  end.

Lemma check_signaspec_r_markers (gvtp gvtp':hashval -> stp -> Prop) (gvkn gvkn':hashval -> Prop) st th thy s :
  (forall h a, In (hashpair h (hashstp a)) (signaspec_stp_markers s) -> gvtp h a -> gvtp' h a)
  -> (forall h, In h (signaspec_known_markers th s) -> gvkn h -> gvkn' h)
  -> check_signaspec_r gvtp gvkn st th thy s
  -> check_signaspec_r gvtp' gvkn' st th thy s.
intros H1 H2. induction s as [|[h|h a|a m|p] s IH]; simpl.
- tauto.
- destruct st as [st1|]; try tauto.
  destruct (signa_lookup (hashval_bit160 h) st1) as [sth [y z]] eqn:E1.
  intros [H3 H4].
  split.
  + revert H3. apply IH.
    * intros k b H5. apply H1. exact H5.
    * intros k H5. apply H2. exact H5.
  + exact H4.
- intros [H3 H4].
  split.
  + revert H3. apply IH.
    * intros k b H5. apply H1. right. exact H5.
    * intros k H5. apply H2. exact H5.
  + apply H1.
    * left. reflexivity.
    * exact H4.
- intros [H3 H4].
  split.
  + revert H3. apply IH.
    * intros k b H5. apply H1. exact H5.
    * intros k H5. apply H2. exact H5.
  + exact H4.
- intros [H3 H4].
  split.
  + revert H3. apply IH.
    * intros k b H5. apply H1. exact H5.
    * intros k H5. apply H2. right. exact H5.
  + apply H2.
    * left. reflexivity.
    * exact H4.
Qed.

Lemma check_signaspec_p_markers (gvtp gvtp':hashval -> stp -> Prop) (gvkn gvkn':hashval -> Prop) t st th s :
  (forall h a, In (hashpair h (hashstp a)) (signaspec_stp_markers s) -> gvtp h a -> gvtp' h a)
  -> (forall h, In h (signaspec_known_markers th s) -> gvkn h -> gvkn' h)
  -> check_signaspec_p gvtp gvkn t st th s
  -> check_signaspec_p gvtp' gvkn' t st th s.
intros H1 H2. destruct th as [h|]; simpl.
- destruct t as [t|]; simpl.
  + now apply check_signaspec_r_markers.
  + tauto.
- now apply check_signaspec_r_markers.
Qed.

Lemma check_doc_r_markers (gvtp gvtp':hashval -> stp -> Prop) (gvkn gvkn':hashval -> Prop) st th thy dl :
  (forall h a, In (hashpair h (hashstp a)) (doc_stp_markers dl) -> gvtp h a -> gvtp' h a)
  -> (forall h, In h (doc_known_markers th dl) -> gvkn h -> gvkn' h)
  -> check_doc_r gvtp gvkn st th thy dl
  -> check_doc_r gvtp' gvkn' st th thy dl.
intros H1 H2. induction dl as [|[h|h a|a m|p|p d] dr IH]; simpl.
- tauto.
- destruct st as [st1|]; try tauto.
  destruct (signa_lookup (hashval_bit160 h) st1) as [sth [y z]] eqn:E1.
  intros [H3 H4].
  split.
  + revert H3. apply IH.
    * intros k b H5. apply H1. exact H5.
    * intros k H5. apply H2. exact H5.
  + exact H4.
- intros [H3 H4].
  split.
  + revert H3. apply IH.
    * intros k b H5. apply H1. right. exact H5.
    * intros k H5. apply H2. exact H5.
  + apply H1.
    * left. reflexivity.
    * exact H4.
- intros [H3 H4].
  split.
  + revert H3. apply IH.
    * intros k b H5. apply H1. exact H5.
    * intros k H5. apply H2. exact H5.
  + exact H4.
- intros [H3 H4].
  split.
  + revert H3. apply IH.
    * intros k b H5. apply H1. exact H5.
    * intros k H5. apply H2. right. exact H5.
  + apply H2.
    * left. reflexivity.
    * exact H4.
- intros [H3 H4].
  split.
  + revert H3. apply IH.
    * intros k b H5. apply H1. exact H5.
    * intros k H5. apply H2. exact H5.
  + exact H4.
Qed.

Lemma check_doc_p_markers (gvtp gvtp':hashval -> stp -> Prop) (gvkn gvkn':hashval -> Prop) t st th dl :
  (forall h a, In (hashpair h (hashstp a)) (doc_stp_markers dl) -> gvtp h a -> gvtp' h a)
  -> (forall h, In h (doc_known_markers th dl) -> gvkn h -> gvkn' h)
  -> check_doc_p gvtp gvkn t st th dl
  -> check_doc_p gvtp' gvkn' t st th dl.
intros H1 H2. destruct th as [h|]; simpl.
- destruct t as [t|]; simpl.
  + now apply check_doc_r_markers.
  + tauto.
- now apply check_doc_r_markers.
Qed.

Lemma check_signaspec_r_uses (gvtp gvtp':hashval -> stp -> Prop) (gvkn gvkn':hashval -> Prop) st th thy s :
  (forall h a, In h (signaspec_uses_objs s) -> gvtp h a -> gvtp' h a)
  -> (forall h, In h (signaspec_uses_props th s) -> gvkn h -> gvkn' h)
  -> check_signaspec_r gvtp gvkn st th thy s
  -> check_signaspec_r gvtp' gvkn' st th thy s.
intros H1 H2. induction s as [|[h|h a|a m|p] s IH]; simpl.
- tauto.
- destruct st as [st1|]; try tauto.
  destruct (signa_lookup (hashval_bit160 h) st1) as [sth [y z]] eqn:E1.
  intros [H3 H4].
  split.
  + revert H3. apply IH.
    * intros k b H5. apply H1. exact H5.
    * intros k H5. apply H2. exact H5.
  + exact H4.
- intros [H3 H4].
  split.
  + revert H3. apply IH.
    * intros k b H5. apply H1. right. exact H5.
    * intros k H5. apply H2. exact H5.
  + apply H1.
    * left. reflexivity.
    * exact H4.
- intros [H3 H4].
  split.
  + revert H3. apply IH.
    * intros k b H5. apply H1. exact H5.
    * intros k H5. apply H2. exact H5.
  + exact H4.
- intros [H3 H4].
  split.
  + revert H3. apply IH.
    * intros k b H5. apply H1. exact H5.
    * intros k H5. apply H2. right. exact H5.
  + apply H2.
    * left. reflexivity.
    * exact H4.
Qed.

Lemma check_signaspec_p_uses (gvtp gvtp':hashval -> stp -> Prop) (gvkn gvkn':hashval -> Prop) t st th s :
  (forall h a, In h (signaspec_uses_objs s) -> gvtp h a -> gvtp' h a)
  -> (forall h, In h (signaspec_uses_props th s) -> gvkn h -> gvkn' h)
  -> check_signaspec_p gvtp gvkn t st th s
  -> check_signaspec_p gvtp' gvkn' t st th s.
intros H1 H2. destruct th as [h|]; simpl.
- destruct t as [t|]; simpl.
  + now apply check_signaspec_r_uses.
  + tauto.
- now apply check_signaspec_r_uses.
Qed.

Lemma check_doc_r_uses (gvtp gvtp':hashval -> stp -> Prop) (gvkn gvkn':hashval -> Prop) st th thy dl :
  (forall h a, In h (doc_uses_objs dl) -> gvtp h a -> gvtp' h a)
  -> (forall h, In h (doc_uses_props th dl) -> gvkn h -> gvkn' h)
  -> check_doc_r gvtp gvkn st th thy dl
  -> check_doc_r gvtp' gvkn' st th thy dl.
intros H1 H2. induction dl as [|[h|h a|a m|p|p d] dr IH]; simpl.
- tauto.
- destruct st as [st1|]; try tauto.
  destruct (signa_lookup (hashval_bit160 h) st1) as [sth [y z]] eqn:E1.
  intros [H3 H4].
  split.
  + revert H3. apply IH.
    * intros k b H5. apply H1. exact H5.
    * intros k H5. apply H2. exact H5.
  + exact H4.
- intros [H3 H4].
  split.
  + revert H3. apply IH.
    * intros k b H5. apply H1. right. exact H5.
    * intros k H5. apply H2. exact H5.
  + apply H1.
    * left. reflexivity.
    * exact H4.
- intros [H3 H4].
  split.
  + revert H3. apply IH.
    * intros k b H5. apply H1. exact H5.
    * intros k H5. apply H2. exact H5.
  + exact H4.
- intros [H3 H4].
  split.
  + revert H3. apply IH.
    * intros k b H5. apply H1. exact H5.
    * intros k H5. apply H2. right. exact H5.
  + apply H2.
    * left. reflexivity.
    * exact H4.
- intros [H3 H4].
  split.
  + revert H3. apply IH.
    * intros k b H5. apply H1. exact H5.
    * intros k H5. apply H2. exact H5.
  + exact H4.
Qed.

Lemma check_doc_p_uses (gvtp gvtp':hashval -> stp -> Prop) (gvkn gvkn':hashval -> Prop) t st th dl :
  (forall h a, In h (doc_uses_objs dl) -> gvtp h a -> gvtp' h a)
  -> (forall h, In h (doc_uses_props th dl) -> gvkn h -> gvkn' h)
  -> check_doc_p gvtp gvkn t st th dl
  -> check_doc_p gvtp' gvkn' t st th dl.
intros H1 H2. destruct th as [h|]; simpl.
- destruct t as [t|]; simpl.
  + now apply check_doc_r_uses.
  + tauto.
- now apply check_doc_r_uses.
Qed.

Lemma check_signaspec_p_subq (gvtp gvtp':hashval -> stp -> Prop) (gvkn gvkn':hashval -> Prop) t st th s :
  (forall h a, gvtp h a -> gvtp' h a)
  -> (forall h, gvkn h -> gvkn' h)
  -> check_signaspec_p gvtp gvkn t st th s
  -> check_signaspec_p gvtp' gvkn' t st th s.
intros H1 H2. apply check_signaspec_p_uses.
- intros h a _. apply H1.
- intros h _. apply H2.
Qed.

Lemma check_doc_p_subq (gvtp gvtp':hashval -> stp -> Prop) (gvkn gvkn':hashval -> Prop) t st th dl :
  (forall h a, gvtp h a -> gvtp' h a)
  -> (forall h, gvkn h -> gvkn' h)
  -> check_doc_p gvtp gvkn t st th dl
  -> check_doc_p gvtp' gvkn' t st th dl.
intros H1 H2. apply check_doc_p_uses.
- intros h a _. apply H1.
- intros h _. apply H2.
Qed.

(***
 The next functions give the burncost for theories and signatures.
 Creating theories and signatures should be done sparingly since they must be kept on every node to check future documents.
 The real functions will give the number of cants based on the number of bytes required to serialize.
 The current idea is that it will be such that 21 million fraenks must be burned to create 1GB of theories and signatures, and so there will be a hard upper bound of 1GB of theories and 1GB of signatures (just counting what is stored at the leaves).
***)
(*** 21 zerms per byte = 21 billion cants per byte ***)
Parameter cants_per_byte : nat. (*** := 21000000000. Leave abstract here to avoid Coq trying to compute with it. The value doesn't matter here. ***)

(***
 These are simply estimates of the number of bytes required to represent the data serialized.
 The way it's implemented in the real code will require more care.
 ***)
Definition stp_numbytes (a:stp) : nat := length (ser_stp a).

Fixpoint stpl_numbytes (al:list stp) : nat :=
  match al with
    | nil => 0
    | a::ar => stp_numbytes a + stpl_numbytes ar
  end.

Fixpoint trm_numbytes (m:trm) : nat :=
  match m with
    | Gn _ => 21
    | Prm _ al => 1 + stpl_numbytes al
    | Db _ => 1
    | Ap m n => 1 + trm_numbytes m + trm_numbytes n
    | La a m => 1 + stp_numbytes a + trm_numbytes m
    | Imp m n => 1 + trm_numbytes m + trm_numbytes n
    | All a m => 1 + stp_numbytes a + trm_numbytes m
  end.

Fixpoint odefl_numbytes (dl: list (prod hashval (prod stp (option trm)))) : nat :=
  match dl with
    | nil => 0
    | (h,(a,None))::dr => stp_numbytes a + 21 + odefl_numbytes dr
    | (h,(a,Some(m)))::dr => stp_numbytes a + trm_numbytes m + 21 + odefl_numbytes dr
  end.

Definition theory_burncost (thy:theory) : nat :=
  let (al,kl) := thy in
  cants_per_byte * stpl_numbytes al
  +
  cants_per_byte * 21 * length kl.

Definition theoryspec_burncost (s:theoryspec) : nat := theory_burncost (theoryspec_theory s).

Fixpoint signaspec_burncost (s:signaspec) : nat :=
  match s with
    | signasigna h::s => cants_per_byte * 21 + signaspec_burncost s
    | signaparam h a::s => cants_per_byte * (stp_numbytes a + 21) + signaspec_burncost s
    | signadef a m::s => cants_per_byte * (trm_numbytes m + stp_numbytes a + 21) + signaspec_burncost s
    | signaknown p::s => cants_per_byte * 21 + signaspec_burncost s
    | nil => 0
  end.

Definition signa_burncost (s:signa) : nat :=
  match s with
    | (sl,(dl,kl)) =>
      length sl * cants_per_byte * 21
      +
      odefl_numbytes dl * cants_per_byte
      +
      length kl * cants_per_byte * 21
  end.

Lemma signaspec_signa_burncost_eq (th:option hashval) (s:signaspec) :
  signaspec_burncost s = signa_burncost (signaspec_signa th s).
induction s as [|[h|h a|a m|p] sr IH].
- simpl. omega.
- simpl. rewrite IH. simpl. omega.
- simpl. rewrite IH. simpl.
  assert (L1: (stp_numbytes a + 21 + odefl_numbytes (signaspec_trms th sr)) * cants_per_byte = (stp_numbytes a + 21) * cants_per_byte + odefl_numbytes (signaspec_trms th sr) * cants_per_byte).
  { apply mult_plus_distr_r. }
  rewrite L1.
  rewrite mult_comm.
  omega.
- simpl. rewrite IH. simpl. repeat rewrite mult_plus_distr_l. repeat rewrite mult_plus_distr_r.
  rewrite (mult_comm 21).
  repeat rewrite (mult_comm cants_per_byte).
  rewrite (mult_comm 21).
  omega.
- simpl. rewrite IH. simpl. omega.
Qed.

Fixpoint htree_sum (A:Type) (f:A -> nat) (n:nat) : htree A n -> nat :=
  match n with
    | 0 => fun x:htree A 0 => f x
    | S n => fun t:htree A (S n) => match t with
                                      | (None,None) => 0
                                      | (Some l,None) => htree_sum A f n l
                                      | (None,Some r) => htree_sum A f n r
                                      | (Some l,Some r) => htree_sum A f n l + htree_sum A f n r
                                    end
  end.

Definition ottree_burncost {n} (tht:option (ttree n)) : nat :=
  match tht with
    | None => 0
    | Some(tht) => htree_sum theory theory_burncost n tht
  end.

Definition ostree_burncost {n} (sigt:option (stree n)) : nat :=
  match sigt with
    | None => 0
    | Some(sigt) => htree_sum (option hashval * signa) (fun z => let (x,y) := z in signa_burncost y) n sigt
  end.


(** * Constructive Completeness *)

Require Import models nd forms decidability toolbox.
Require Import PslBase.Base.

Section Canonical.
  (**
We define the *canonical models*, whose worlds are the maximally consistent theories.
We first define the relations.
   **)
  Context {d : DerivationType}.
  Variable A0 : context.
  Variable s0 : form.
  Definition U' := scl (s0::(K ⊥)::A0).
  Record mcTheory := mkmcTheory {
                         T: list form;
                         Tsubs: (T el (power U')) ;
                         Tcons: ~(nd T ⊥);
                         TUPrime: forall A B,  (A ∨ B) el T -> A el T \/ B el T;
                         Tdedclos: forall A, A el U' ->  nd T A -> A el T;
                       }.

  (** Define extension operator on theories  **)

  Definition single_extend (Ω: context) (A: form) (a: form) :=
    if (@ielg_dec (a::Ω) A d) then Ω else (a::Ω).

  Lemma single_extend_subcontext  A Ω B: Ω <<= (single_extend Ω A B).
  Proof.
    intros a Ha.  unfold single_extend. destruct (ielg_dec (B :: Ω) A d); eauto.
  Qed.

  Lemma extend_two_possibilites Γ A B:
    ((single_extend Γ A B) === Γ /\ (B::Γ) ⊢ A) \/   (single_extend Γ A B) === (B::Γ) /\ ~((B::Γ) ⊢ A).
  Proof.
    destruct (ielg_dec (B::Γ) A d) eqn:id.
    - left. split; try tauto.
      split.
      + intros a Ha. unfold single_extend in Ha. rewrite id in Ha. auto.
      + unfold single_extend. rewrite id; auto.
    - right.      split; auto. split.
      +  intros a Ha. unfold single_extend in Ha. rewrite id in Ha. auto.
      +  unfold single_extend. rewrite id; auto.
  Qed.
  Fixpoint extend (Ω: context) (A: form) (Γ: context) : context :=
    match Γ with
      nil => Ω
    | (a::Γ') =>
      single_extend (extend Ω A Γ') A a  end.

  Lemma extend_does_not_derive Ω A Γ: ~(nd Ω A) -> ~(nd (extend Ω A Γ) A).
  Proof.
    revert Ω.
    induction Γ; eauto.
    - intros.  destruct (ielg_dec (a :: extend Ω A Γ) A d) eqn:di.
      +  simpl extend. unfold single_extend. rewrite di. apply IHΓ.  auto.
      +  simpl extend. unfold single_extend. rewrite di. apply n.
  Qed.

  Lemma extend_subset Ω Γ A: Ω <<= (extend Ω A Γ).
  Proof.
    revert Ω.
    induction Γ; eauto.
    - intro.  simpl extend. unfold single_extend.  destruct (ielg_dec (a :: extend Ω A Γ) A d); eauto.
  Qed.

  Lemma extend_does_not_derive_imp Ω Γ A B:
    ~(nd Ω A) -> B el Γ -> ~(nd (extend Ω A Γ) B) -> (nd (extend Ω A Γ) (B ⊃ A)).
  Proof.
    intros H H1. revert H. revert Ω.
    induction Γ.
    - intros.  eauto.
    - intros.  destruct H1.
      + subst a. simpl.
        destruct (extend_two_possibilites (extend Ω A Γ) A B) as [(E1 & E2) | (E1 & E2)].
        * apply ndW with (extend Ω A Γ). eauto.  destruct E1; auto.
        * exfalso.   apply H0. simpl extend; fold extend. apply ndW with ( B :: extend Ω A Γ).  apply ndA. auto. destruct E1; auto.
      + assert (~extend Ω A Γ ⊢ B).  intro. apply H0. apply ndW with (extend Ω A Γ). auto. apply single_extend_subcontext.
        specialize (IHΓ H1 (Ω) H H2).
        simpl extend.  apply ndW with (extend Ω A Γ). auto.  apply single_extend_subcontext.
  Qed.

  Lemma ImpAgree (Γ: context) (a b: form) :
    Γ ⊢ (a ⊃ b) <-> ((a::Γ) ⊢ b).
  Proof.
    split.
    - intro H.  apply ndIE with a; auto. apply ndW with Γ; firstorder eauto.
    -  intros.  apply ndII. firstorder eauto.
  Qed.

  Lemma extend_locally_dclosed Γ Ω A B: ~(nd Ω A) -> (nd (extend Ω A Γ) (B)) -> B el Γ ->  B el (extend Ω A Γ).
  Proof.
    revert Ω B.  induction Γ.
    - intros.   inversion H1.
    - intros. destruct H1.
      + simpl extend; fold extend. destruct (extend_two_possibilites  (extend Ω A Γ) A a).
        *  destruct H2. apply extend_does_not_derive with Ω A (a::Γ) in H.
           exfalso. apply H. subst a. apply ndIE with B.  apply ndII. apply ndW with ((B :: extend Ω A Γ)). auto.
           unfold extend at 2.  fold extend. enough ((extend Ω A Γ ) <<= (single_extend (extend Ω A Γ) A B)).
           eauto.  apply single_extend_subcontext. auto.
        *    subst a.  destruct H2. rewrite H1.  auto.
      +
        simpl extend. unfold single_extend. simpl extend in H0. unfold single_extend in H0.  destruct (ielg_dec (a :: extend Ω A Γ) A d) eqn:di.
        *  apply IHΓ; auto.
        *  enough (B el (extend Ω A (a::Γ))). simpl extend in H2. unfold single_extend in H2. rewrite di in H2.   auto. simpl extend. unfold single_extend.   rewrite di.  right.   apply IHΓ. auto.  2: auto.  destruct (ielg_dec (extend Ω A Γ) B d); auto. exfalso.
           apply ImpAgree in H0.
           assert (HA := n0).
           apply (extend_does_not_derive_imp H H1) in HA. apply n. apply ndIE with B.
           apply ndW with (extend Ω A Γ). auto.  auto. apply ndIE with a.  apply ndW with (extend Ω A Γ). auto.  auto.  apply ndA. auto.
  Qed.

  Lemma extend_locally_prime Γ Ω A B C:  ~(nd Ω A) -> (nd (extend Ω A Γ) (B ∨ C)) -> B el Γ -> C el Γ -> B el (extend Ω A Γ) \/ C el (extend Ω A Γ).
  Proof.
    intros. decide (B el (extend Ω A Γ)).  auto. decide (C el (extend Ω A Γ)).  auto. assert (~(extend Ω A Γ ⊢ (B ∨ C))).
    assert (~(extend Ω A Γ ⊢ B)). intro. apply (extend_locally_dclosed H) in H3. congruence. auto.
    assert (~(extend Ω A Γ ⊢ C)). intro. apply (extend_locally_dclosed H) in H4. congruence. auto. intro. specialize (@extend_does_not_derive Ω A Γ  H ). intro.  apply H6. apply ndDE with B C. auto.
    apply extend_does_not_derive_imp. auto.  auto.  auto.   apply extend_does_not_derive_imp; auto.   congruence.
  Qed.

  Lemma extend_locally_easy_subset Ω A Γ: (extend Ω A Γ) <<= (Ω ++ Γ).
  Proof.
    revert Ω. induction Γ. eauto. intros.  simpl extend. unfold single_extend. destruct (ielg_dec (a :: extend Ω A Γ) A d); auto.
    specialize (IHΓ Ω). intros b Hb.  apply  IHΓ in Hb. apply in_app_iff. apply in_app_iff in Hb. destruct Hb. tauto. right. right. assumption.
    intros b Hb.  destruct Hb; eauto. subst b; eauto. apply IHΓ in H.  apply in_app_iff in H; destruct H; apply in_app_iff; try tauto. right. right. auto.
  Qed.

  Lemma extend_locally_subset Γ A Ω: Ω <<= Γ -> (extend Ω A Γ) <<= Γ.
  Proof.
    intros. enough (extend Ω A Γ <<= Γ ++ Γ).  intros a Ha. specialize (H0 a Ha). apply in_app_iff in H0; destruct H0; assumption.
    enough (extend Ω A Γ <<= Ω ++ Γ). intros a Ha. specialize (H0 a Ha).  apply in_app_iff in H0. destruct H0; eauto.  apply extend_locally_easy_subset.
  Qed.
  (* Not deriven implies adding it causes us to derive A *)
  Definition U'_sfc : sf_closed U' := @scl_closed _.

  Definition subsetMKT (A B: mcTheory) :=  (T A) <<= (T B).
  Definition valuationMKT (A: mcTheory) (a: nat) := (Var a) el (T A).
  Definition subsetVerif (A B:mcTheory) := (unK (T A)) <<= (T B).

  Instance canonical: (KripkeModel).
  Proof.
    apply mkKripkeModel with (world := mcTheory) (cogn := subsetMKT) (val := valuationMKT) (verif := subsetVerif).
    firstorder.  firstorder.
    + intros A B c d' E. unfold subsetVerif in c.  apply c.  apply unK_in_iff.  eauto.
    +   intros x y z H H0. intros a Ha.  apply unK_in_iff in Ha. destruct Ha; auto.  apply H0. apply unK_in_iff. left. apply H. auto. apply H0. apply unK_in_iff. right. apply H.  auto.
  Defined.

  Definition Lindenbaum (Γ : list form) (A: form) (H: Γ <<= U') (H': ~(nd Γ A)) : mcTheory.
  Proof.
    eapply mkmcTheory with (rep (extend Γ A U') U').
    - apply rep_power.
    - enough (~ nd (extend Γ A U') ⊥).
      intro. apply H0. apply (ndW H1).   apply rep_incl.
      intro. apply extend_does_not_derive with Γ A U' in H'. apply H'.  apply ndE. auto.

    - intros. rewrite rep_equi in *.
      apply extend_locally_prime.  auto.  apply ndA.  auto. apply extend_locally_subset in H0.  apply U'_sfc in H0; tauto. auto. apply extend_locally_subset in H0.   apply U'_sfc in H0; tauto. auto.
      all: try apply extend_locally_subset; auto.
    - intros.
       rewrite rep_equi in *.
       apply extend_locally_dclosed; auto.
       apply ndW with ((rep (extend Γ A U') U')). eauto. apply rep_equi.
       all: try apply extend_locally_subset; auto.
  Defined.

  (* Canonical models are IEL models *)
  Lemma are_iel_models: d = normal -> forall w, exists u, verif w u.
  Proof.
    intros.
    assert (exists Δ: mcTheory, (unK (T w)) <<= (T Δ)).
    {
      assert (unK (T w) <<= U').
      {
        intros a Ha. apply unK_in_iff in Ha.   destruct Ha; eauto.  destruct w.
        simpl in H0. apply power_incl in Tsubs0. eauto.
        destruct w.
        assert ((K a) el U'). simpl in H0. apply power_incl in Tsubs0. auto. apply U'_sfc in H1; auto.
      }
      enough (~ nd (unK (T w)) ⊥).
      eexists (Lindenbaum  H0 H1).
      simpl T. enough (unK (T w) <<= (extend (unK (T w)) ⊥ U')).
      enough ((extend (unK (T w)) ⊥ U') <<= (rep (extend (unK (T w)) ⊥ U') U')).
      intros a Ha. apply H3. apply H2. assumption.
      apply rep_equi. apply extend_locally_subset; auto.
      apply extend_subset.
      intro. cut (gen (T w) (K ⊥)). intro. apply (@Tcons w). rewrite H.  apply ndgen_iff.   apply genKB.  rewrite H in H2.  apply H2.
      apply genKI.  apply ndgen_iff. apply H1.
    }
    destruct H0.  exists x.  firstorder eauto.
  Qed.

  Lemma truth_lemma : forall (x: form), In x U' -> forall (t: (@world  canonical)), (evalK x t) <-> x el (T t).
  Proof.
    intro x. intro Hx. induction x.
    - intros w. split.
      + intro. decide (K x el (T w)); eauto.  exfalso.
        assert (exists Δ: mcTheory, (unK (T w)) <<= (T Δ)
                                   /\ ~(x el (T Δ))).
        {
          destruct w. simpl. assert ((x::T0) <<= U'). intros a Ha. destruct Ha; eauto. subst a. apply  U'_sfc in Hx; auto. cbn in H.  specialize (power_incl Tsubs0). eauto.
          assert (~(nd (unK T0) x)). {
            intro. apply n. simpl. apply Tdedclos0; auto.   apply ndgen_iff. apply ndgen_iff in H1.  apply genKI. auto.  (* TODO: Remove ndgen_iff *)
          }
          assert (unK T0 <<= U'). {
            intros a Ha. apply unK_in_iff in Ha. destruct Ha; auto.
            assert ((K a el U')).             specialize (power_incl Tsubs0). eauto. apply U'_sfc in H3. eauto.

          }
          eexists (@Lindenbaum  (unK T0) x H2   H1 ). split.
          - simpl. rewrite rep_equi.  apply extend_subset.     apply extend_locally_subset.
            auto.
          - simpl.  enough (~(nd (extend (unK T0) x U') x)). {
              intro.  apply H3. apply ndA. apply rep_incl in H4.  auto.
            }   apply  extend_does_not_derive. rewrite-> ndgen_iff.  auto. intro.  apply H1.  apply ndgen_iff. auto.  (* TODO: Remove ndgen_iff *)
        }
        destruct H0 as (w' & Hw' & Hw'd).
        specialize (H w'). apply Hw'd. apply IHx.   apply U'_sfc in Hx; tauto.  apply H. firstorder eauto.
      + intros H Ω vo.  apply IHx.  apply U'_sfc in Hx; tauto. apply vo.  apply unK_in_iff.  tauto.
    - intro w.     split.
      + intro. decide ((x1 ⊃ x2) el (T w)); eauto.  exfalso.
         assert (exists Δ: mcTheory, (x1::(T w)) <<= (T Δ)
                                   /\ ~(x2 el (T Δ))).
         {
           destruct w. simpl.
           assert ((x1::T0 <<= U')).
           { intros a Ha; destruct Ha. subst a. apply U'_sfc in Hx; tauto. eauto using power_incl.
             specialize (power_incl Tsubs0).  firstorder eauto.
           }
           assert (~ nd (x1 :: T0) x2).  {
             intro. apply ImpAgree in H1. apply n.  apply Tdedclos0 in H1.  assumption.  assumption.
           }
           eexists (Lindenbaum  H0 H1). split.
           - simpl T. rewrite rep_equi.  apply extend_subset.
             apply extend_locally_subset. auto.
           - simpl. enough (~(nd (extend (x1 :: T0) x2 U') x2)). {
               intro.  apply H2. apply ndA.  auto. apply rep_equi in H3. auto.
                apply extend_locally_subset. auto.
            } apply extend_does_not_derive.  auto.
         }
         destruct H0 as (Ω & Ho1 & Ho2).
         specialize (H Ω).  apply Ho2.  apply IHx2.   apply U'_sfc in Hx; tauto. apply H.  firstorder eauto. apply IHx1. apply U'_sfc in Hx; tauto.    eauto.
      + intro. intros Ω Hc He. apply IHx2.  apply U'_sfc in Hx; tauto. apply Tdedclos. apply U'_sfc in Hx; tauto.  apply ndIE with x1.
        apply ndA. auto. apply ndA. apply IHx1; auto. apply U'_sfc in Hx; tauto.
    - intro w.  split.
      + intro. destruct H.  apply Tdedclos.  auto.  apply ndCI;  apply ndA. apply IHx1.  apply U'_sfc in Hx; tauto. auto.
        apply IHx2.  apply U'_sfc in Hx; tauto. auto.
      +   intro.  split.
          * apply IHx1. apply U'_sfc in Hx; tauto. apply Tdedclos. apply U'_sfc in Hx; tauto.
            apply ndCEL with x2. auto.
          *  apply IHx2. apply U'_sfc in Hx; tauto. apply Tdedclos.  apply U'_sfc in Hx; tauto.
             apply ndCER with x1. auto.
    -   intro w. split.
        + intro H.  destruct H.
          * apply Tdedclos. auto.  apply ndDIL.  apply ndA. apply IHx1.   apply U'_sfc in Hx; tauto. auto.
          *  apply Tdedclos. auto.  apply ndDIR.  apply ndA.  apply IHx2.   apply U'_sfc in Hx; tauto. auto.
        + intro. apply TUPrime in H.  destruct H.
          * left. apply IHx1; eauto.   apply U'_sfc in Hx; tauto.
          * right. apply IHx2; eauto.   apply U'_sfc in Hx; tauto.
    -         firstorder eauto. exfalso. destruct t.  apply Tcons0.  apply ndA.  apply H.
    -           firstorder eauto.

  Qed.

  Lemma gen_stable Γ A: ~~(gen Γ A) -> gen Γ A.
  Proof.
    intros. destruct (@gen_dec Γ A d).  auto. exfalso.  tauto.
  Qed.

  Lemma nd_stable Γ A: ~~(nd Γ A) -> nd Γ A.
  Proof.
    intros. destruct (@ielg_dec Γ A d).  auto. exfalso.  tauto.
  Qed.

  (** Show completeness for subformulas *)
  Lemma completeness' Ω A: A el U' -> Ω <<= U' -> entails Ω A -> nd Ω A.
  Proof.
    intros Au U H. apply nd_stable. intro.
    unfold entails in H.
    specialize (H (@canonical)).
     assert (exists Δ: mcTheory, ~(nd (T Δ) A) /\ (Ω <<= (T Δ))).
     {
       eexists (Lindenbaum  U H0). split.
       - simpl. enough (~ (extend Ω A U') ⊢ A). intro. apply H1. eapply ndW.  apply H2.
         apply rep_equi. apply extend_locally_subset. auto.
         apply extend_does_not_derive. auto.
       - simpl. intros a Ha.  apply rep_in.  apply extend_locally_subset. auto.   apply extend_subset. auto.
     }
     assert (model_constraint canonical). {
       destruct d eqn:dn; simpl; auto. unfold isIEL. apply are_iel_models.
       auto.
     }
     specialize (H H2). clear H2.
     destruct H1 as [Δ H2].
     specialize (H Δ). destruct H2.
     decide (A el (T Δ)).
    + apply H1. apply ndA.  auto.
    + rewrite<- truth_lemma in n; auto. apply n.  apply H.  unfold evalK'. intros.  apply truth_lemma.   eauto.  eauto.
  Qed.

  (** * Constructive Finite Model Property *)
  Definition finiteModel (M: KripkeModel) := exists (L: list (@world M)), forall (w : (@world M)), exists w', w' el L /\ (cogn w w') /\ (cogn w' w).
  Definition fentails Γ A := forall M, model_constraint M -> finiteModel M -> (forall w, @evalK' M Γ w  -> evalK A w).

  Definition fmp := forall Γ A, fentails Γ A -> nd Γ A.

  Instance lce_dec: eq_dec (list (list form)).
  eauto.
  Defined.

  (** *** Compute the candidate list *)
  Definition checkPrimeDisj (C: list form) (A B: form) : bool.
    decide (A el C).
    - exact true.
    - decide (B el C).   exact true. exact false.
  Defined.

  Definition checkPrimeSingle (L: list form) (A: form) :=
    match A with
      (B1 ∨ B2) => checkPrimeDisj L B1 B2
    | _ => true
    end.

  Definition checkPrime (A: list form)  : bool :=
    forallb (checkPrimeSingle A) A.

  Definition checkDCLSingle (C: list form) (A: form) : bool.
    destruct (ielg_dec C A d).
    - decide (A el C). exact true. exact false.
    - exact true.
  Defined.

  Definition checkDCL (A: list form) (U: list form) : bool :=
    forallb (checkDCLSingle A) U.

  Definition checkConsistent (A: list form) : bool.
    destruct (ielg_dec A ⊥ d).
    - exact false.
    - exact true.
  Defined.
  Definition candidateList := filter (fun x => match (checkDCL x U',  checkPrime x, checkConsistent x ) with
                                              (true, true, true) => true
                                            | _ => false end) (power U').

    Definition realCandidates (H: list context) : list world.
    induction H as [ |Γ IH].
    - apply nil.
    -  decide (Γ el (power U')). 2: apply IHIH. rename i into i'.
       decide (checkConsistent Γ). 2: apply IHIH.
       +   decide (checkDCL Γ U'). 2: apply IHIH.
           * decide (checkPrime Γ)  . 2: apply IHIH.
             assert (new: world).
             { eapply mkmcTheory with (T := Γ).
               - eauto.
               - unfold checkConsistent in i. destruct (ielg_dec Γ ⊥); congruence; auto.
               - intros A B H1. unfold checkPrime in i1.
                 specialize (@forallb_forall form ( checkPrimeSingle Γ) Γ).
                 intros H2. destruct H2.
                 specialize (H i1 (A ∨ B) H1).  simpl checkPrimeSingle in H. unfold checkPrimeDisj in H.  decide (A el Γ); auto.  decide (B el Γ); auto.

               - unfold checkDCL in i0.  specialize (@forallb_forall form (checkDCLSingle Γ) U').   intro. destruct H.  specialize (H i0).  clear H0.
                 intros A Ha. specialize (H A Ha).  intro Hg.  unfold checkDCLSingle in H. destruct  (ielg_dec Γ A d).  decide (A el Γ). auto.  congruence.  congruence.

             }
             eapply (new::IHIH).
    Defined.
         Ltac dec := repeat (destruct Dec).

      Lemma candidatesConnection: forall (x: nd.context),  (x el candidateList) -> exists w', w' el (realCandidates candidateList) /\ (T w') = x.
  Proof.
    intros x H.

    pose proof (H1 := H).
    apply in_filter_iff in H. destruct H.   destruct (checkDCL x U') eqn:dcl;  destruct (checkPrime x) eqn:cp; destruct (checkConsistent x) eqn:cc;  try congruence.

    induction candidateList.
    -  inversion H1.
    -  destruct H1.
       + subst a. simpl realCandidates.
              destruct ( @Dec (@In (list form) x (@power form U'))
        (@list_in_dec (list form) x (@power form U') (@gentree.list_eq_dec form form_eq_dec'))) eqn:ni.     destruct (Dec (checkConsistent x)) eqn:nx. destruct (Dec (checkDCL x U')) eqn:nii. destruct (Dec (checkPrime x)) eqn:niiii.

              eexists. split.
              simpl.   left. reflexivity. simpl.  reflexivity.
              exfalso. apply n. apply cp.
              exfalso. apply n. apply dcl.
              exfalso. apply n. apply cc.
              exfalso. apply n. apply H.

       + specialize (IHl H1).
         destruct IHl as (w & Hw1 & Hw2). exists w.
         simpl realCandidates.
         dec. all: try right; auto.
 Qed.

  Lemma canonicalFinite: finiteModel canonical.
  Proof.
    exists (realCandidates candidateList).
    intros.
    destruct w.
    enough (T0 el candidateList).
    specialize (candidatesConnection H).  intro.  destruct H0 as [wCan [HwCan1 HwCan2]].
    exists wCan. split; try tauto.
    split.
    - intros a. simpl.  rewrite HwCan2. auto.
    - intros a. simpl.  rewrite HwCan2. auto.
    - unfold candidateList. apply in_filter_iff.  split; auto.
      destruct (checkDCL T0 U') eqn:dclt.
      destruct (checkPrime T0) eqn:cpt.
      destruct (checkConsistent T0) eqn:cct.
      auto.
      + unfold checkConsistent in cct.  destruct (ielg_dec T0 ⊥ d); congruence.
      + unfold checkPrime in cpt.
      assert (forall x, In x T0 -> (checkPrimeSingle T0 x) = true).
      { intros x Hx.
        unfold checkPrimeSingle. destruct x; auto. specialize (TUPrime0 x1 x2 Hx).  unfold checkPrimeDisj.
        decide (x1 el T0); decide (x2 el T0); try congruence. tauto.
      }
      apply forallb_forall in H. congruence.
      + unfold checkDCL in dclt. assert (forall x, In x U' -> ( checkDCLSingle T0 x)). {
          intros x Hx. unfold checkDCLSingle. destruct (ielg_dec T0 x d); auto.
          decide (x el T0); auto.
        }
         apply forallb_forall in H.  congruence.
  Qed.

  Definition finiteModelProperty := forall Γ A, ~(nd Γ A) -> exists M,  (exists w,  evalK' Γ w /\ ~(evalK A w)) /\ finiteModel M /\ model_constraint M.

  (* Show that finiteModelproperty implies fmp *)
  Lemma fmp_two_versions:
    finiteModelProperty -> fmp.
  Proof.
    intro.
    unfold fmp. intros Γ A H0.
    apply nd_stable. intro H1.  specialize (H Γ A H1).
    destruct H as (M & Hm1 & Hm2 & Hm3).
    specialize (H0 M Hm3 Hm2). destruct Hm1. destruct H.    apply H2. auto.
  Qed.

End Canonical.

Lemma completeness Ω A (D: DerivationType): entails Ω A -> nd Ω A.
Proof.
  intro. apply completeness' with Ω A. unfold U'. apply scl_incl'. auto. intros a Ha. apply scl_incl'. auto. auto.
Qed.

Lemma ielHasFmp (D: DerivationType): finiteModelProperty.
Proof.
  intros Γ A H.
  exists (canonical Γ A).
  repeat split.
  + assert (Γ <<= U' Γ A). { unfold U'. intros a Ha.  apply scl_incl'.  auto.
                           }
                           eexists (Lindenbaum H0 H). split. unfold evalK'. intros. apply truth_lemma.  unfold U'.  apply scl_incl'.  auto.
    simpl. rewrite rep_equi.  apply extend_subset.  auto.  apply extend_locally_subset.   auto.
    rewrite truth_lemma. simpl T.  rewrite rep_equi. intro. eapply extend_does_not_derive with Γ A (U' Γ A) in H.  apply H.  apply ndA. auto.
    apply extend_locally_subset.  auto.
    unfold U'. apply scl_incl'.   auto.
  + apply canonicalFinite.
  + destruct D; simpl; auto. unfold isIEL.   apply are_iel_models. reflexivity.

Qed.

(** ** Admissibility *)
Section Admissibility.

    Variable d: DerivationType.
  Definition liftRelOne {X: Type} (R: X -> X -> Prop) (r1 r2: (option X)) :=
    match (r1, r2) with
      (Some x, Some y) => (R x y) |
    (None, _)     => True |
    _ => False
    end.

  Definition liftProp {X: Type} (R: X -> nat -> Prop) (r: (option X)) (n: nat) :=
    (match r with
       Some r' => R r' n
     | None => False end).
  Lemma onSomeEqualsRlift {X: Type} x R  (n: nat): (@liftProp X R (Some x) n) <-> (R x n).
    split; firstorder eauto.
  Qed.

  Section liftRelProps.
    Context {X: Type} {R: X -> X -> Prop} {R': X -> X -> Prop}.

    Definition lr := (liftRelOne R).
    Definition lr' := (liftRelOne R').

    Lemma lr_in a b :
      lr a b -> (exists b', a = None /\ b = Some b') \/ (exists a' b', a = Some a' /\ b = Some b') \/ (a = None /\ b = None).
    Proof.
      Unset Printing All.
      intro.
      unfold lr in H.
      destruct a, b; firstorder eauto; try congruence.
    Defined.

    Lemma preserves_reflexivity: Reflexive R -> Reflexive lr.
    Proof.
      intros.
      intro x.
      destruct x; firstorder eauto.
    Defined.

    Lemma preserves_transitivity: Transitive R -> Transitive lr.
      intros H x y z H1 H2.
      destruct x; destruct y; destruct z; firstorder eauto.
    Defined.
    Lemma preservesPreOrder: PreOrder R -> PreOrder lr.
      intros H.  destruct H.  split.
      apply preserves_reflexivity; auto.
      apply preserves_transitivity; auto.
    Defined.

    Lemma preservesSubrealtion: subrelation R R' -> subrelation lr lr'.
    Proof.
      intros H x  y H1.
      destruct (lr_in H1); firstorder eauto; rewrite H0; rewrite H2.
      cbv. auto. cbv. apply H. rewrite H0 in H1. rewrite H2 in H1.  cbv in H1. auto.
      cbv. auto.
    Defined.

    Lemma onSomeEqualsR x y: lr (Some x) (Some y) <-> (R x y).
      split; firstorder eauto.
    Qed.
  End liftRelProps.

  Definition reflectionModel (m: KripkeModel): (KripkeModel).

    apply mkKripkeModel with (world := (option world)) (cogn := (liftRelOne  cogn)) (verif := (liftRelOne verif)) (val := (liftProp  val)).
    + apply preservesPreOrder; auto. apply m.
    + intros s x y H H0.
      destruct x; destruct y; firstorder eauto; try congruence.
      destruct m. rewrite onSomeEqualsRlift. apply monotone with (x := w);
                                               firstorder eauto using onSomeEqualsR.
    + destruct m.  apply preservesSubrealtion.  auto.
    + intros x y z. destruct m; destruct x; destruct y; destruct  z; firstorder eauto using onSomeEqualsR.
      apply onSomeEqualsR.  apply transvalid with (y := w0).
      rewrite<- onSomeEqualsR.  exact H.  rewrite<- onSomeEqualsR.  exact H0.
  Defined.

  (* Derivability in the reflection model (Even nicer would be if submodels would be arbitrary) *)
  Lemma derivReflSomeIdent (m: KripkeModel) ϕ: forall w, ((@evalK m ϕ w) <-> (@evalK (reflectionModel m) ϕ (Some w))).
  Proof.
    - induction ϕ;try firstorder eauto.
      + split.
        intros H r1 v. destruct r1.
        apply IHϕ. apply H. auto using onSomeEqualsR.
        destruct v.

        intros H r' v.
        apply IHϕ. apply H. auto using onSomeEqualsR.
      + split.
        * intros H. simpl evalK. intros r' H1 H2.
          destruct r'.
          apply IHϕ2. apply H.  auto using onSomeEqualsR.
          apply IHϕ1. auto.
          destruct H1.
        * intros H r' c H1.
          apply IHϕ2.
          apply H.
          eauto using onSomeEqualsR.
          apply IHϕ1. auto.
  Qed.

  Lemma derivRefl (m: KripkeModel) ϕ: (exists w, ~(@evalK m ϕ w)) -> ~(@evalK (reflectionModel m) (K ϕ) None).
  Proof.
    intro.
    intro.  destruct H. apply H.
    apply derivReflSomeIdent.
    apply H0. simpl verif. cbv. auto.
  Qed.

  Lemma reflectionPreservesIEL (m: KripkeModel):
    isIEL m -> isIEL (reflectionModel m).
  Proof.
    intros H w.
    destruct w.
    - specialize (H w). destruct H as [w' Hw']. exists (Some w'). apply Hw'.
    - exists None. firstorder eauto.
  Qed.

  Lemma reflectionAdmissible  A : nd [] (K A) -> nd [] A.
  Proof.
    intro.
    destruct (ielg_dec [] A d); auto.
    assert (exists (M: KripkeModel) w, ~(@evalK M A w) /\ model_constraint M).  {
      exists (canonical [] A).
      assert ([] <<= (U' [] A)) by  auto.
      eexists (Lindenbaum H0 n). split.
      rewrite truth_lemma. enough (~(nd (T (Lindenbaum H0 n)) A)). {
        intro. apply H1. apply ndA. auto.
      }
      simpl T. intro.   apply extend_does_not_derive with [] A (U' [] A) in n.  apply n.
      apply ndW with (rep (extend [] A (U' [] A)) (U' [] A)).  auto.
      apply rep_equi.  apply extend_locally_subset.  auto.  unfold U'.  simpl scl.
      apply in_app_iff. left.  apply scl'_in.
      destruct d eqn:rd; try firstorder. simpl model_constraint.
      intros w.
      pose proof (are_iel_models). rewrite rd in H1.  apply H1.  reflexivity.
    }
    destruct H0 as (M & w & Hmw).
    enough (exists m w, model_constraint m /\ ~ evalK (K A) w).
    apply soundness in H. repeat destruct H0.   exfalso. apply H1.
    apply H. auto.
    firstorder eauto.

    exists (reflectionModel M).
    exists None.
    split.
    - destruct d eqn:deq; try firstorder.   simpl model_constraint. apply reflectionPreservesIEL.
      tauto.
    -  destruct Hmw.  firstorder eauto using  derivRefl.
 Qed.
End Admissibility.


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

From Undecidability.Shared.Libs.DLW
  Require Import utils_tac.

Require Import Undecidability.Synthetic.Undecidability.
Require Import Undecidability.Synthetic.ReducibilityFacts.

From Undecidability.PCP              Require Import PCP PCP_undec.
From Undecidability.StackMachines    Require Import BSM.
From Undecidability.MinskyMachines   Require Import MM MM_sss.

From Undecidability.ILL
  Require Import EILL ILL iBPCP_MM MM_EILL EILL_ILL.

Require Import Undecidability.PCP.Reductions.HaltTM_1_to_PCPb.

Import ReductionChainNotations UndecidabilityNotations.

(* The reduction chain from the CPP 2019, Y. Forster & D. Larchey-Wendling *)

Theorem PCP_chain_ILL :
  PCP ⪯ PCPb /\
  PCPb ⪯ iPCPb /\
  iPCPb ⪯ Halt_BSM /\
  Halt_BSM ⪯ MM_HALTS_ON_ZERO /\
  MM_HALTS_ON_ZERO ⪯ EILL_PROVABILITY /\
  EILL_PROVABILITY ⪯ ILL_PROVABILITY.
Proof.
  msplit 5.
  + apply PCP_to_PCPb.reduction.
  + apply PCPb_iff_iPCPb.reductionLR.
  + apply iBPCP_chain_MM.
  + apply iBPCP_chain_MM.
  + apply MM_HALTS_ON_ZERO_EILL_PROVABILITY.
  + apply EILL_ILL_PROVABILITY.
Qed.

Check PCP_chain_ILL.

(* Undecidability results *)

Local Hint Resolve EILL_rILL_cf_PROVABILITY
                   EILL_rILL_PROVABILITY
                   EILL_ILL_cf_PROVABILITY
                 : core.

(* EILL provability using G_eill *)

Theorem EILL_undec : undecidable EILL_PROVABILITY.
Proof. undec from PCP_undec using chain PCP_chain_ILL. Qed.

(* whole ILL with cut *)

Theorem ILL_undec : undecidable ILL_PROVABILITY.
Proof. undec from PCP_undec using chain PCP_chain_ILL. Qed.

(* whole ILL without cut *)

Theorem ILL_cf_undec : undecidable ILL_cf_PROVABILITY.
Proof. undec from EILL_undec; auto. Qed.

(* (!,&,-o) fragment of ILL without cut *)

Theorem rILL_cf_undec : undecidable rILL_cf_PROVABILITY.
Proof. undec from EILL_undec; auto. Qed.

(* (!,&,-o) fragment of ILL with cut *)

Theorem rILL_undec : undecidable rILL_PROVABILITY.
Proof. undec from EILL_undec; auto. Qed.