(**************************************************************************)
(*                                                                        *)
(*  This file is part of octant-proof.                                    *)
(*                                                                        *)
(*  Copyright (C) 2019-2020 Orange                                        *)
(*                                                                        *)
(*  you can redistribute it and/or modify it under the terms of the GNU   *)
(*  Lesser General Public License as published by the Free Software       *)
(*  Foundation, either version 3 of the License, or (at your option)      *)
(*  any later version.                                                    *)
(*                                                                        *)
(*  It is distributed in the hope that it will be useful,                 *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU Lesser General Public License for more details.                   *)
(*                                                                        *)
(*  You should have received a copy of the GNU Lesser General Public      *)
(*  License along with the software. If not, see                          *)
(*  <https://www.gnu.org/licenses/>.                                      *)
(*                                                                        *)
(**************************************************************************)

Require Import syntax.
Require Import occurrences.
Require Import subs.
Require Import pmatch.
Require Import bSemantics.
Require Import monotonicity.
Require Import soundness.
Require Import tSemantics.

From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun choice fintype tuple finset bigop finfun.

Require Import bigop_aux.
Require Import utils.
Require Import finseqs.
Require Import fintrees.

Require Import Sumbool.

Set Implicit Arguments.
Unset Strict Implicit.

Implicit Types (s r : sub) (d def : syntax.constant) (t : term) (a : atom)
               (ga : gatom) (tl : list atom) (cl : clause) (i : interp).

(** * No recursion traces: extracting bounded sequences from deduction traces *)
Section no_rec_traces.

(** Program to analyze *)
Variable p : program.
(** default ground atom for the trace semantics *)
Variable gat_def : gatom.

(** Default term, variable and predicate, actually unsused but required by the nth
    or nth_error functions *)
Variable dt : term.
Variable dv : 'I_n.
Variable df : symtype.

(** A branch is a sequence without repetition of [t_occ] *)
Definition dbranch := (@uniq_seq_finType (t_occ_finType p)).

(** the predicate corresponding to the last occurrence of the branch *)
Definition branch_pred (br : seq (t_occ p)) :=
  match br with
    | [::] => df (* case not used in practice *)
    | a :: l => match p_at (last a l) with
        | None => df (* same *)
        | Some f => f end end.

(** branch_pred stable wrt. cons *)
Lemma branch_pred_eq h (s : seq (t_occ p)) :
  size s > 0 -> branch_pred s = branch_pred (h::s).
Proof.
by destruct s.
Qed.

(** [t_ind] (term index) of the last occurrence of the branch *)
Definition branch_t_ind (br : seq (t_occ p)) :=
  match br with
    | [::] => 0 (* unused case *)
    | a :: l => t_ind (last a l) end.

(** branch_t_ind stable wrt. cons *)
Lemma branch_t_ind_eq h (s : seq (t_occ p)) :
  size s > 0 -> branch_t_ind s = branch_t_ind (h::s).
Proof.
by destruct s.
Qed.

(** ** The actual extraction *)
(**    [prev] is the set of previously visited [t_occ]s
       [tr] is the trace to "unrec"
       [v] is the variable we focus on
       [count] is the fuel used for termination
       The function computes the sequences of [t_occ]s the values of [v] go
       through, and eliminates the repetition of [t_occ]s *)
Fixpoint unrec_trace_gen (prev : (tocs p)) (tr : (ABtree rul_gr_finType gatom_finType)) (v : 'I_n) (count : nat) : {set dbranch} :=
  match count with | 0 => set0 | count.+1 =>
  match tr with
    | ABLeaf _ => [set unil]
    | ABNode (RS cl s) descs =>
          let unrec_b (o : t_occ p) : {set dbranch} :=
            match (nth_error descs (b_ind o)) with
              | None => set0 (* None case not used in practice *)
              | Some (ABLeaf _) => [set unil]
              | Some (ABNode (RS clb sb) descsb) =>
                  unrec_trace_gen (o |: prev)
                                  (ABNode (RS clb sb) descsb)
                                  (get_cl_var dt dv clb (t_ind o))
                                  count end
        in
        let occs := (occsInProgram p v) :\: prev in
        \bigcup_(occ in occs) [set pucons occ l | l in unrec_b occ]
         end end.

(** Version used in practice, where [prev] is empty *)
Definition unrec_trace (tr : (ABtree rul_gr_finType gatom_finType)) (v : 'I_n) (count : nat) : {set dbranch} :=
  unrec_trace_gen set0 tr v count.

(** ** The sequences in the no recursion trace are disjoint from [prev] *)
Lemma unrec_trace_gen_notin (prev : (tocs p)) (tr : (ABtree rul_gr_finType gatom_finType)) (v : 'I_n) (count : nat) :
  [forall br in unrec_trace_gen prev tr v count, [disjoint [set x | x \in (useq br)] & prev]].
Proof.
move:prev tr v. induction count as [|count Hrec].
- intros. apply/forallP=>x. apply/implyP=>//=. by rewrite in_set0.
- move=>prev tr v. apply/forallP=>br. apply/implyP=>/=.
  destruct tr as [|[cl s] descs].
  + move=>/set1P ->. simpl. rewrite disjoints_subset. apply/subsetP=>x. rewrite in_set. by rewrite in_nil.
  + move=>/bigcup_seqP [i Hin] /andP [/imsetP [x Hx ->] Hinb].
    unfold pucons.
    destruct (nth_error_case descs (b_ind i)) as [Hnone|[[|] [Hd1 Hd2]]].
    - by rewrite Hnone in_set0 in Hx.
    - rewrite Hd2 in Hx. rewrite (set1P Hx).
      simpl. rewrite disjoints_subset.
      apply/subsetP=>y. rewrite in_set mem_seq1.
      move=>/eqP ->. rewrite in_setC.
      have H := setDP Hinb. by destruct H.
    - rewrite Hd2 in Hx. destruct s0.
      have H := implyP (forallP (Hrec _ _ _) _) Hx.
      rewrite disjoints_subset subsetC in H.
      rewrite disjoints_subset.
      have Hb := (subsetP H i (setU11 i _)).
      rewrite in_setC in_set in Hb.
      destruct sumbool_of_bool as [Hf|Hf].
      + apply/subsetP=>y. rewrite in_set in_cons in_setC.
        move=>/orP [/eqP ->|Hyin].
        - have Ht := setDP Hinb. by destruct Ht.
        - destruct (bool_des_rew (y \in prev)) as [Hyr|Hy].
          + have Ht := subsetP H y (setU1r i Hyr).
            rewrite in_setC in_set Hyin in Ht. inversion Ht.
          + by rewrite Hy.
      + by rewrite Hb in Hf.
Qed.

(** ** The no recursion trace is monotonuous wrt. its fuel *)
Lemma unrec_trace_gen_count_incr (prev : (tocs p)) (tr : (ABtree rul_gr_finType gatom_finType)) (v : 'I_n) (c1 c2 : nat) br :
 c1 <= c2 -> br \in unrec_trace_gen prev tr v c1 -> br \in unrec_trace_gen prev tr v c2.
Proof.
move:prev v c1 c2 br.
induction tr using abtree_ind_prop;
move=>prev v [|c1] [|c2] br //=.
- by rewrite in_set0.
- by rewrite in_set0.
- destruct h as [cl s].
  move=>Hlt /bigcup_seqP [i Hienum /andP [/imsetP [x Hxin ->] Hin]].
  destruct (nth_error_case l (b_ind i)) as [Hnone|[[|] [Hd1 Hd2]]].
  + by rewrite Hnone in_set0 in Hxin.
  + rewrite Hd2 in Hxin. rewrite (set1P Hxin).
    unfold pucons. simpl.
    apply/bigcup_seqP. exists i. auto.
    apply/andP;split. rewrite Hd2.
    apply/imsetP. exists unil. by apply/set1P.
    auto. auto.
  + unfold pucons.
    rewrite Hd2 in Hxin. destruct s0 as [clb sb].
    have Hif := disjoint_setI0 (implyP (forallP (unrec_trace_gen_notin _ _ _ _) _) Hxin).
    destruct sumbool_of_bool as [Hnotin|Hinin].
    - apply/bigcup_seqP. exists i. auto.
      apply/andP;split. apply/imsetP. exists x.
      rewrite Hd2.
      apply/(all_prop_in H Hd1). apply Hlt.
      apply Hxin. destruct sumbool_of_bool as [Hit|Hit].
      by apply/val_inj. rewrite Hnotin in Hit. inversion Hit.
      auto.
    - move:Hinin. move=>/negPf /Bool.not_false_is_true Hinin.
      assert (Hf : i \in (@set0 (t_occ_finType p))).
      rewrite -Hif. apply/setIP. split. rewrite in_set. apply Hinin.
      by apply/setU1P;auto. by rewrite in_set0 in Hf.
Qed.

(** ** [unrec_trace_gen] has a normal form wrt. its fuel *)
Lemma unrec_trace_gen_normal_form (prev : (tocs p)) (tr : (ABtree rul_gr_finType gatom_finType)) (v : 'I_n) (count : nat) :
  forall br, br \in unrec_trace_gen prev tr v count -> br \in unrec_trace_gen prev tr v (ABheight tr).+1.
Proof.
move:prev v count.
induction tr using abtree_ind_prop;
move=>prev v [|count] br //.
- by rewrite in_set0.
- by rewrite in_set0.
- destruct h as [cl s].
  move=>/bigcup_seqP [i Hinenum /andP [/imsetP [x Hxin ->] Hinb]].
  destruct (nth_error_case l (b_ind i)) as [Hnone|[[|] [Hd1 Hd2]]].
  + by rewrite Hnone in_set0 in Hxin.
  + rewrite Hd2 in Hxin.
    rewrite (set1P Hxin).
    apply/bigcup_seqP. exists i. auto.
    apply/andP;split;auto.
    apply/imsetP.
    exists x.
    by rewrite Hd2 Hxin. rewrite (set1P Hxin). by apply/val_inj.
  + rewrite Hd2 in Hxin. destruct s0 as [clb sb].
    have Hif := disjoint_setI0 (implyP (forallP (unrec_trace_gen_notin _ _ _ _) _) Hxin).
    have Hrec := (all_prop_in H Hd1 _ _ _ _ Hxin).
    assert (Hh : (ABheight (ABNode (RS clb sb) l0)).+1 <= (ABheight (ABNode (RS cl s) l))).
    apply/sstree_height. apply/hasP. exists (ABNode (RS clb sb) l0 ). apply Hd1.
    simpl. by apply/orP;left.
    unfold pucons.
    destruct sumbool_of_bool as [Hnotin|Hinin].
    - apply/bigcup_seqP. exists i. auto.
      apply/andP;split. apply/imsetP. exists x.
      rewrite Hd2.
      apply/(unrec_trace_gen_count_incr Hh Hrec).
      apply/val_inj. simpl. unfold pucons.
      destruct sumbool_of_bool as [Hf|Hf]. auto.
      by rewrite Hnotin in Hf. auto.
    - move:Hinin. move=>/negPf /Bool.not_false_is_true Hinin.
      assert (Hf : i \in (@set0 (t_occ_finType p))).
      rewrite -Hif. apply/setIP. split. rewrite in_set. apply Hinin.
      by apply/setU1P;auto. by rewrite in_set0 in Hf.
Qed.

(** A substitution [s] is adequate wrt. a branch [br], ending with an occurrence [o] referring to
    an occurrence of predicate [f], and an interpretation [i] iff. [s] [v] = [c], st. [i] contains
    a [f]-fact that has c at the position matching [o] *)
Definition br_adequate def (br : dbranch) (s : sub) (v : 'I_n) (i : interp) : bool :=
  [exists c : syntax.constant, (s v == Some c) &&
         [exists ga in i, (sym_gatom ga == branch_pred br)
                       && (nth def (arg_gatom ga) (branch_t_ind br) == c)]].

(** ** Core result: any value [v] can take in practice during an execution of [p]
       is captured by the no-recursion trace *)
Theorem no_rec_needed def prev (tr : trace_sem_trees gat_def) (i : interp) (m : nat) cl s v :
   vars_not_shared p
-> prog_safe p
-> only_variables_in_heads p
-> tr \in sem_t p gat_def def m i
-> ABroot (val tr) = inl (RS cl s)
-> v \in tail_vars (body_cl cl)
-> [forall br in unrec_trace_gen prev (val tr) v (ABheight (val tr)).+1,
      br_adequate def br s v i].
Proof.
move:cl s v tr prev.
induction m as [|m Hrec].
- move=>/= cl s v tr prev Hvns Hpsafe Hvarshead /imsetP [x Hx ->] //.
- move=> cl s v tr prev Hvns Hpsafe Hvarshead Hded. have Hded_copy := Hded. move:Hded.
  move=>/setUP [Hded|/bigcup_seqP [clb Hclbinp /andP [H _]]].
  + by apply/Hrec.
  + destruct (imset2P (mem_pset_set H))
      as [descs sb Hdescsded Hsmatch Htreq]. clear H.
    destruct tr as [[|[clt st] descst] Htr];
    move=>// [Hcleq Hseq] Hvin.
    unfold wu_pcons_seq in Htreq.
    unfold wu_pcons_wlist in Htreq. move:Htreq.
    destruct sumbool_of_bool;move=> //[Hcleqb Hseqb Hdescseq].
    assert (Hdescssize : size descs <= bn).
    destruct descs as [descs Hdescs]. rewrite (eqP Hdescs).
    destruct clb. apply wlist_to_seq_size.
    rewrite (seq_wlistK Hdescssize) in Hdescseq.
    (* cl = clb = clt, s = sb = st and descs = descst *)
    rewrite in_set in Hsmatch.
    destruct (and3P Hsmatch) as [Hsbmatch Hdedsub Hprevded]. clear Hsmatch.
    apply/forallP=>br. apply/implyP=>Hbrb. have Hbrb_copy := Hbrb. move:Hbrb. simpl.
    move=>/bigcup_seqP [occ Hoccinrule].
    move=>/andP [/imsetP [brb Hbrb Hbreq]] /setDP [Hocc1 Hocc2].
    assert (Hdomvs : v \in dom s).
    rewrite -Hseq Hseqb.
    apply (subsetP (match_vars_subset Hsbmatch)).
    rewrite -Hcleqb Hcleq. apply Hvin.
    rewrite in_set in Hdomvs.
    destruct (sub_elim s v) as [[c Hc]|Hnone];
      try by rewrite Hnone in Hdomvs.
    apply/existsP. exists c. apply/andP;split. apply/eqP/Hc.
    destruct (nth_error_case descst (b_ind occ))
      as [Hnone|[[ga| [cld sd] descsd] [Hdin Hdnth]]]. by rewrite Hnone in_set0 in Hbrb.
    - rewrite Hdnth in Hbrb.
      rewrite (set1P Hbrb) in Hbreq.
      simpl in Hbreq.
      assert (Hwub : @wu_pred _ _ bn (ABLeaf rul_gr_finType ga)). auto.
      assert (Hsubtree : subtree (val {| wht := (ABLeaf rul_gr_finType ga); Hwht := Hwub |}) (val {| wht := ABNode (RS clt st) descst; Hwht := Htr |})).
      simpl. apply/hasP. exists (ABLeaf rul_gr_finType ga). apply Hdin. by apply/eqP.
      have Hgain  := sem_t_leaf (trace_sem_prev_trees Hded_copy Hsubtree).
      apply/existsP. exists ga. apply/andP;split. apply Hgain.
      unfold ded_sub_equal in Hdedsub.
      rewrite Hdescseq in Hdnth. destruct (nth_error_preim Hdnth) as [trb [Htrb1 Htrb2]].
      have Heqb := (nth_error_map (ded def) Htrb1).
      assert (Heqt : trb = {| wht := (ABLeaf rul_gr_finType ga); Hwht := Hwub |}).
      apply/val_inj. apply Htrb2.
      rewrite Heqt in Heqb. unfold ded at 2 in Heqb. simpl in Heqb.
      rewrite Hbreq. simpl. unfold p_at.
      have Hoccsrule := occsInProgramV Hocc1.
      unfold t_at in Hoccsrule.
      simpl. unfold at_at. unfold at_at in Hoccsrule.
      destruct (nth_error_case p (r_ind occ)) as [Hnone|[d [Hd1 Hd2]]]. by rewrite Hnone in Hoccsrule.
      rewrite Hd2 in Hoccsrule. rewrite Hd2.
      destruct (nth_error_case (body_cl d) (b_ind occ)) as [Hnone|[db [Hdb1 Hdb2]]].
      by rewrite Hnone in Hoccsrule.
      rewrite Hdb2 in Hoccsrule. rewrite Hdb2.
      have Heqtb := (nth_error_map (gr_atom_def def sb) Hdb2).
      assert (Hdeq : d = clb). apply/(@vns_cl_eq _ _ _ v).
      apply/bigcup_seqP. exists db. apply Hdb1. apply/andP;split;auto.
      apply/bigcup_seqP. exists (Var v). destruct occ. apply (nth_error_in Hoccsrule).
      apply/andP;split;auto. by apply/set1P. rewrite -Hcleqb Hcleq. apply Hvin. apply Hd1.
      apply Hclbinp. apply Hvns.
      simpl in Heqb.
      rewrite Hdeq -(eqP Hdedsub) Heqb in Heqtb.
      inversion Heqtb as [Hgasbeq].
      apply/andP;split.
      + by destruct ga as [[]]; destruct db as [[]].
      + simpl. destruct occ.
        rewrite (nth_map (Var v) def _ (nth_error_in_size Hoccsrule)) (nth_error_nth (Var v) Hoccsrule).
        simpl. rewrite -Hseqb Hseq. unfold odflt. unfold oapp. by rewrite Hc.
    - assert (Hsubd : subtree (ABNode (RS cld sd) descsd) (ABNode (RS clt st) descst)).
      apply/orP;right. apply/hasP. exists (ABNode (RS cld sd) descsd). auto. by apply/orP;left.
      have Hwupred := (wu_pred_sub Hsubd Htr).
      assert (Hssubd : strict_subtree (val {| wht := (ABNode (RS cld sd) descsd); Hwht := Hwupred |}) (val {| wht := ABNode (RS clt st) descst; Hwht := Htr |})).
      apply/hasP. exists (ABNode (RS cld sd) descsd). auto. by apply/orP;left.
      have Hdedm1 := trace_sem_prev_trees_m1 Hded_copy Hssubd. simpl in Hdedm1.
      assert (Hrootd : ABroot (val {| wht := ABNode (RS cld sd) descsd; Hwht := Hwupred |}) =
       inl (RS cld sd)). auto.
      unfold ded_sub_equal in Hdedsub.
      rewrite Hdescseq in Hdnth. destruct (nth_error_preim Hdnth) as [trb [Htrb1 Htrb2]].
      have Heqb := (nth_error_map (ded def) Htrb1).
      assert (Heqt : trb = {| wht := ABNode (RS cld sd) descsd; Hwht := Hwupred |}).
      apply/val_inj. apply Htrb2.
      rewrite Heqt in Heqb. unfold ded at 2 in Heqb. simpl in Heqb.
      destruct cld as [hcld tlcld].
      (* rewrite Hbreq. simpl. unfold p_at.*)
      have Hoccsrule := occsInProgramV Hocc1. have Htat_copy := Hoccsrule.
      unfold t_at in Hoccsrule.
      (*rewrite Hocceq. simpl. unfold at_at.*) unfold at_at in Hoccsrule.
      destruct (nth_error_case p (r_ind occ)) as [Hnone|[d [Hd1 Hd2]]]. by rewrite Hnone in Hoccsrule.
      rewrite Hd2 in Hoccsrule. (*rewrite Hd2.*)
      destruct (nth_error_case (body_cl d) (b_ind occ)) as [Hnone|[db [Hdb1 Hdb2]]].
      by rewrite Hnone in Hoccsrule.
      rewrite Hdb2 in Hoccsrule. (*rewrite Hdb2.*)
      have Heqtb := (nth_error_map (gr_atom_def def sb) Hdb2).
      assert (Hdeq : d = clb). apply/(@vns_cl_eq _ _ _ v).
      apply/bigcup_seqP. exists db. apply Hdb1. apply/andP;split;auto.
      apply/bigcup_seqP. exists (Var v). destruct occ. apply (nth_error_in Hoccsrule).
      apply/andP;split;auto. by apply/set1P. rewrite -Hcleqb Hcleq. apply Hvin. apply Hd1.
      apply Hclbinp. apply Hvns.
      destruct occ as [occ Hocc]. simpl in Heqb.
      rewrite Hdeq -(eqP Hdedsub) Heqb in Heqtb.
      inversion Heqtb as [[Hgasymbeq Hgaargbeq]].
      have Hcldin := (tr_cl_in Hdedm1 Hrootd).
      assert (Hsveq : s v = sd (get_cl_var dt dv (Clause hcld tlcld) t_ind)
                   /\ nth_error (arg_atom hcld) t_ind = Some (Var (get_cl_var dt dv (Clause hcld tlcld) t_ind))).
      have H := (nth_error_map (gr_term_def def sb) Hoccsrule).
      rewrite -Hgaargbeq in H. unfold get_cl_var. simpl.
      destruct (nth_error_preim H) as [[v'|c'] [H1' H2']]. split.
      rewrite (nth_error_nth _ H1') (gr_term_def_eq_in_dom H2'). by rewrite -Hseq Hseqb.
      destruct (existsP (trace_sem_head_match Hpsafe Hdedm1)) as [x Hx].
      apply (subsetP (match_vars_subset Hx)).
      apply/(subsetP (allP Hpsafe _ Hcldin)).
      apply/bigcup_seqP. exists (Var v'). apply (nth_error_in H1'). apply/andP;split;auto.
      by apply/set1P.
      apply (subsetP (match_vars_subset Hsbmatch)). rewrite -Hcleqb Hcleq. apply Hvin.
      rewrite (nth_error_nth _ H1'). apply H1'.
      have Hf := (allP (allP Hvarshead _ Hcldin) _ (nth_error_in H1')). inversion Hf.
      destruct Hsveq as [Hv1' Hv2'].
      assert (Hnewintail : (get_cl_var dt dv (Clause hcld tlcld) t_ind) \in tail_vars tlcld).
      apply (subsetP (allP Hpsafe _ Hcldin)).
      apply/bigcup_seqP. exists (Var (get_cl_var dt dv (Clause hcld tlcld) t_ind)).
      apply (nth_error_in Hv2'). apply/andP;split;auto.
      by apply/set1P.
      rewrite Hdescseq (nth_error_map val Htrb1) Heqt in Hbrb. simpl in Hbrb.
     (* helping unification *)
      assert (Hbrbin : brb
           \in unrec_trace_gen ({| r_ind := occ; b_ind := Hocc; t_ind := t_ind |} |: prev)
                 (val  {|  wht := ABNode (RS (Clause hcld tlcld) sd) descsd; Hwht := Hwupred |})
                 (get_cl_var dt dv (Clause hcld tlcld) t_ind) (@foldr nat nat maxn O
                 (@map (ABtree rul_gr gatom) nat (@ABheight rul_gr gatom) (@map
                 (@WUtree (Finite.eqType rul_gr_finType) (Finite.eqType gatom_finType) bn)
                 (ABtree rul_gr gatom) (@wht (Finite.eqType rul_gr_finType)
                 (Finite.eqType gatom_finType) bn) (@tval (@size atom  (@wlist_to_seq_co atom bn (body_cl clb)))
                 (@WUtree (Finite.eqType rul_gr_finType) (Finite.eqType gatom_finType) bn) descs)))).+1).
      apply Hbrb.
      have Hbrbprev := (unrec_trace_gen_normal_form Hbrbin). clear Hbrb. clear Hbrbin.
      have Hdisj := implyP (forallP (unrec_trace_gen_notin _ _ _ _) _) Hbrbprev.
      move:Hbreq. unfold pucons. destruct sumbool_of_bool as [Hin|Hin].
      + move=>/= ->.
        have Hreced := implyP (forallP ((@Hrec _ sd _ _ _ Hvns) Hpsafe Hvarshead Hdedm1 Hrootd Hnewintail) brb) Hbrbprev.
        apply/existsP.
        simpl in Hreced.
        destruct (existsP Hreced) as [c' Hc']. destruct (andP Hc') as [Hc1' Hc2']. clear Hc'. clear Hreced.
        destruct (existsP Hc2') as [ga Hga]. destruct (andP Hga) as [Hga1 Hga2]. destruct (andP Hga2) as [Hga3 Hga4].
        clear Hga2. clear Hc2'. clear Hga. exists ga.
        destruct (bool_des_rew ({| r_ind := occ; b_ind := Hocc; t_ind := t_ind |} \in
                (@mem (Equality.sort (Choice.eqType (Finite.choiceType (t_occ_finType p))))
                 (seq_predType (Choice.eqType (Finite.choiceType (t_occ_finType p))))
                 (@useq (Choice.eqType (Finite.choiceType (t_occ_finType p))) brb)))) as [Hf|Hf].
        - assert (Hff : ({| r_ind := occ; b_ind := Hocc; t_ind := t_ind |} \in (@set0 (t_occ_finType p)))).
          rewrite -(disjoint_setI0 Hdisj). apply/setIP;split.
          rewrite in_set. apply Hf.
          apply setU11. by rewrite in_set0 in Hff.
          assert (Hsize : 0 < size brb).
          destruct brb as [[|]];auto.
          move:Hbrbprev. move=>/= /bigcup_seqP [i1 Hi1inenum /andP [/imsetP [x]]].
          destruct (nth_error_case descsd (b_ind i1)) as [Hnone|[[|] [Hdd1 Hdd2]]].
          + by rewrite Hnone in_set0.
          + rewrite Hdd2. move=>/set1P -> //.
          + rewrite Hdd2. destruct s0. move=>Hxunrec.
            unfold pucons.
            (* helping unification *)
            assert (Hxunrecb :
                x \in unrec_trace_gen (@setU (t_occ_finType p) (@set1 (t_occ_finType p)  i1)
               (@setU (t_occ_finType p) (@set1 (t_occ_finType p) {| r_ind := occ; b_ind := Hocc; t_ind := t_ind |})
               prev)) (ABNode (RS c0 s0) l) (get_cl_var dt dv c0 (occurrences.t_ind i1)) (@foldr nat nat maxn O
               (@map (ABtree rul_gr gatom) nat (@ABheight rul_gr gatom) descsd)).+1).
            apply Hxunrec.
            have Hdisjb := implyP (forallP (unrec_trace_gen_notin _ _ _ _) _) Hxunrecb.
            clear Hxunrecb. clear Hxunrec. destruct sumbool_of_bool as [Hfff|Hfff];move=>//.
            assert (Hff : (i1 \in (@set0 (t_occ_finType p)))).
            rewrite -(disjoint_setI0 Hdisjb). apply/setIP;split.
            rewrite in_set. destruct (bool_des_rew ((@in_mem (Equality.sort (Choice.eqType (Finite.choiceType (t_occ_finType p))))
               i1
               (@mem (Equality.sort (Choice.eqType (Finite.choiceType (t_occ_finType p))))
                  (seq_predType (Choice.eqType (Finite.choiceType (t_occ_finType p))))
                  (@useq (Choice.eqType (Finite.choiceType (t_occ_finType p))) x))))) as [Hf5|Hf5].
            by rewrite Hf5 in Hfff. by rewrite Hf5 in Hfff. apply setU11. by rewrite in_set0 in Hff.
          apply/and3P;split. apply Hga1.
          rewrite (eqP Hga3).
          apply/eqP/branch_pred_eq/Hsize.
          rewrite -(branch_t_ind_eq {| r_ind := occ; b_ind := Hocc; t_ind := t_ind |} Hsize) (eqP Hga4).
          assert (Hsome : Some c' = Some c).
          rewrite -Hc -(eqP Hc1'). auto. by inversion Hsome.
        - assert (Hff : ({| r_ind := occ; b_ind := Hocc; t_ind := t_ind |} \in (@set0 (t_occ_finType p)))).
          rewrite -(disjoint_setI0 Hdisj). apply/setIP;split.
          rewrite in_set.
          destruct (bool_des_rew (@in_mem (Equality.sort (Choice.eqType (Finite.choiceType (t_occ_finType p))))
              {| r_ind := occ; b_ind := Hocc; t_ind := t_ind |}
              (@mem (Equality.sort (Choice.eqType (Finite.choiceType (t_occ_finType p))))
                 (seq_predType (Choice.eqType (Finite.choiceType (t_occ_finType p))))
                 (@useq (Choice.eqType (Finite.choiceType (t_occ_finType p))) brb)))) as [Hf|Hf].
          apply Hf. by rewrite Hf in Hin.
          apply setU11. by rewrite in_set0 in Hff.
Qed.

End no_rec_traces.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime A B C Oprime Aprime Bprime Cprime Eprimeprime Bprimeprime C2 C3 : Universe, ((wd_ O E /\ (wd_ Oprime Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ A E /\ (wd_ Eprimeprime O /\ (wd_ O Oprime /\ (wd_ Bprimeprime O /\ (wd_ Bprime Oprime /\ (wd_ C2 Oprime /\ (wd_ Eprimeprime A /\ (wd_ E Eprimeprime /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ Oprime Eprimeprime /\ (wd_ E Oprime /\ (wd_ C Bprimeprime /\ (wd_ Cprime C3 /\ (wd_ B Bprimeprime /\ (wd_ Bprime C3 /\ (wd_ Eprime C2 /\ (wd_ Aprime C2 /\ (wd_ Oprime Aprime /\ (wd_ A Aprime /\ (wd_ C Cprime /\ (wd_ B Bprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ Oprime Eprime Aprime /\ (col_ Oprime Eprime Bprime /\ (col_ Oprime Eprime Cprime /\ (col_ O Eprimeprime Bprimeprime /\ (col_ O Eprimeprime Oprime /\ (col_ O Eprimeprime C2 /\ (col_ O Eprimeprime C3 /\ (col_ O A C /\ col_ Oprime Eprime C2)))))))))))))))))))))))))))))))))))))) -> col_ O Oprime C2)).
Proof.
  time tac.
Qed.

End FOFProblem.


Definition T := Type.
Definition U := Type.

Module Type MT.
  Parameter t : T.
End MT.

Module Type MU.
  Parameter t : U.
End MU.

Module F (E : MT).
  Definition elt :T := E.t.
End F.

Module G (E : MU).
  Include F E.
Print Universes. (* U <= T *)
End G.
Print Universes. (* Check if constraint is lost *)

Module Mt.
  Definition t := T.
End Mt.

Module P := G Mt. (* should yield Universe inconsistency *)
(* ... otherwise the following command will show that T has type T! *)
Eval cbv delta [P.elt Mt.t] in P.elt.


Require Coq.Structures.Equalities.
Require Coq.FSets.FSetAVL.
Require Coq.FSets.FSetWeakList.
Require Coq.FSets.FMapFacts.
Require Coq.Lists.List.

Require Genevan.ProtoIdentifier.
Require Genevan.ProtoName.
Require Genevan.ProtoPeer.Peer.
Require Genevan.ProtoPeer.Collection.

Record t := {
  supports : ProtoIdentifier.t
}.

Module ServerEndpointPeer : Peer.T with Definition t := t.
  Definition t        := t.
  Definition eq       := @Logic.eq t.
  Definition eq_refl  := @Logic.eq_refl t.
  Definition eq_sym   := @Logic.eq_sym t.
  Definition eq_trans := @Logic.eq_trans t.

  #[local]
  Instance eq_equiv : RelationClasses.Equivalence eq := { }.

  Theorem eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
  Proof.
    intros x y.
    destruct x as [xi].
    destruct y as [yi].
    destruct (ProtoIdentifier.Dec.eq_dec xi yi) as [HL|HR]. {
      left; rewrite HL; reflexivity.
    } {
      right.
      intro H_contra.
      assert (xi = yi) by congruence.
      contradiction.
    }
  Qed.
  Definition supports (e : t) : ProtoIdentifier.t := supports e.
End ServerEndpointPeer.

Module Sets : FSetInterface.WS
  with Definition E.t  := t
  with Definition E.eq := ServerEndpointPeer.eq
:= FSetWeakList.Make ServerEndpointPeer.

Module ServerEndpointCollection :=
  ProtoPeer.Collection.Make ServerEndpointPeer Sets.


Require Import ZArith List Nat String.
Require Import syntax semantics.
Require Import untyped_syntax error.
Import error.Notations.

Lemma andb_and a b : (a && b)%bool <-> a /\ b.
Proof.
  split.
  - apply Bool.andb_prop_elim.
  - apply Bool.andb_prop_intro.
Qed.

Module Typer(C : ContractContext).

  Module syntax := Syntax C.
  Import syntax. Import untyped_syntax.

  Definition instruction := syntax.instruction.

  Definition safe_instruction_cast {self_type tff} A A' B B' :
    instruction self_type tff A B -> A = A' -> B = B' -> instruction self_type tff A' B'.
  Proof.
    intros i [] [].
    exact i.
  Defined.

  Record cast_error :=
    Mk_cast_error
      {
        input : Datatypes.list type;
        output :  Datatypes.list type;
        expected_input : Datatypes.list type;
        expected_output : Datatypes.list type;
        tff : Datatypes.bool;
        self_type_ : Datatypes.option type;
        i : instruction self_type_ tff input output;
      }.

  Definition instruction_cast {self_type tff} A A' B B' i : M (instruction self_type tff A' B') :=
    match stype_dec A A', stype_dec B B' with
    | left HA, left HB => Return (safe_instruction_cast A A' B B' i HA HB)
    | _, _ => Failed _ (Typing cast_error (Mk_cast_error A B A' B' tff _ i))
    end.

  Definition instruction_cast_range {self_type tff} A B B' (i : instruction self_type tff A B)
    : M (instruction self_type tff A B') := instruction_cast A A B B' i.

  Definition instruction_cast_domain {self_type tff} A A' B (i : instruction self_type tff A B)
    : M (instruction self_type tff A' B) := instruction_cast A A' B B i.

  Definition contract_cast (c : contract_constant) (a b : type)
             (H : C.get_contract_type c = Some b)
             (He : a = b)
    : syntax.concrete_data (contract a) :=
    syntax.Contract_constant c (eq_trans H (f_equal Some (eq_sym He))).

  Inductive typer_result {self_type} A : Set :=
  | Inferred_type B : instruction self_type false A B -> typer_result A
  | Any_type : (forall B, instruction self_type true A B) -> typer_result A.

  Definition type_check_instruction {self_type}
             (type_instruction :
                forall (i : untyped_syntax.instruction) A,
                  M (typer_result A))
             i A B : M {b : Datatypes.bool & instruction self_type b A B} :=
    let! r1 := type_instruction i A in
    match r1 with
    | Inferred_type _ B' i =>
      let! i := instruction_cast_range A B' B i in
      Return (existT _ false i)
    | Any_type _ i => Return (existT _ true (i B))
    end.

  Definition type_check_instruction_no_tail_fail {self_type}
             (type_instruction :
                forall (i : untyped_syntax.instruction) A,
                  M (typer_result A))
             i A B : M (instruction self_type Datatypes.false A B) :=
    let! r1 := type_instruction i A in
    match r1 with
    | Inferred_type _ B' i => instruction_cast_range A B' B i
    | Any_type _ i => Failed _ (Typing _ tt)
    end.

  Definition assert_not_tail_fail {self_type} A (r : typer_result A) :
    M {B & instruction self_type Datatypes.false A B} :=
    match r with
    | Inferred_type _ B i => Return (existT _ B i)
    | Any_type _ _ => Failed _ (Typing _ tt)
    end.

  Definition type_instruction_no_tail_fail {self_type}
             (type_instruction :
                forall (i : untyped_syntax.instruction) A,
                  M (typer_result A))
             i A : M {B & instruction self_type Datatypes.false A B} :=
    let! r := type_instruction i A in
    assert_not_tail_fail A r.

  Definition type_branches {self_type}
             (type_instruction :
                forall (i : untyped_syntax.instruction) A,
                  M (typer_result A))
             i1 i2 A1 A2 A
             (IF_instr : forall B tffa tffb,
                 instruction self_type tffa A1 B ->
                 instruction self_type tffb A2 B ->
                 instruction self_type (tffa && tffb) A B)
    : M (typer_result A) :=
    let! r1 := type_instruction i1 A1 in
    let! r2 := type_instruction i2 A2 in
    match r1, r2 with
    | Inferred_type _ B1 i1, Inferred_type _ B2 i2 =>
      let! i2 := instruction_cast_range A2 B2 B1 i2 in
      Return
              (Inferred_type _ _
                            (IF_instr B1 false false i1 i2))
    | Inferred_type _ B i1, Any_type _ i2 =>
      Return (Inferred_type _ _ (IF_instr B false true i1 (i2 B)))
    | Any_type _ i1, Inferred_type _ B i2 =>
      Return (Inferred_type _ _ (IF_instr B true false (i1 B) i2))
    | Any_type _ i1, Any_type _ i2 =>
      Return (Any_type _ (fun B =>
                              IF_instr B true true (i1 B) (i2 B)))
    end.

  Definition take_one (S : stack_type) : M (type * stack_type) :=
    match S with
    | nil => Failed _ (Typing _ "take_one"%string)
    | cons a l => Return (a, l)
    end.

  Fixpoint take_n (A : stack_type) n : M ({B | List.length B = n} * stack_type) :=
    match n as n return M ({B | List.length B = n} * stack_type) with
    | 0 => Return (exist (fun B => List.length B = 0) nil eq_refl, A)
    | S n =>
      let! (a, A) := take_one A in
      let! (exist _ B H, C) := take_n A n in
      Return (exist _ (cons a B) (f_equal S H), C)
    end.

  Lemma take_n_length n S1 S2 H1 : take_n (S1 ++ S2) n = Return (exist _ S1 H1, S2).
  Proof.
    generalize dependent S1.
    induction n; destruct S1; simpl; intro H1.
    - repeat f_equal.
      apply Eqdep_dec.UIP_dec.
      repeat decide equality.
    - discriminate.
    - discriminate.
    - assert (List.length S1 = n) as H2.
      + apply (f_equal pred) in H1.
        exact H1.
      + rewrite (IHn S1 H2).
        simpl.
        repeat f_equal.
        apply Eqdep_dec.UIP_dec.
        repeat decide equality.
  Qed.

  Definition type_check_dig {self_type} n (S:stack_type) : M (typer_result (self_type := self_type) S) :=
    let! (exist _ S1 H1, tS2) := take_n S n in
    let! (t, S2) := take_one tS2 in
    let! i := instruction_cast_domain (S1 +++ t ::: S2) S _ (syntax.DIG n H1) in
    Return (Inferred_type S (t ::: S1 +++ S2) i).

  Definition type_check_dug {self_type} n (S:stack_type) : M (typer_result (self_type := self_type) S) :=
    let! (t, S12) := take_one S in
    let! (exist _ S1 H1, S2) := take_n S12 n in
    let! i := instruction_cast_domain (t ::: S1 +++ S2) S _ (syntax.DUG n H1) in
    Return (Inferred_type S (S1 +++ t ::: S2) i).

  Fixpoint as_comparable (a : type) : M comparable_type :=
    match a with
    | Comparable_type a => Return (Comparable_type_simple a)
    | pair (Comparable_type a) b =>
      let! b := as_comparable b in
      Return (Cpair a b)
    | _ => Failed _ (Typing _ ("not a comparable type"%string, a))
    end.

  Lemma as_comparable_comparable (a : comparable_type) :
    as_comparable a = Return a.
  Proof.
    induction a.
    - reflexivity.
    - simpl.
      rewrite IHa.
      reflexivity.
  Qed.

  Definition type_contract_data_aux c a tyopt :=
    match tyopt return C.get_contract_type c = tyopt -> error.M (syntax.concrete_data (contract a)) with
    | Some b =>
      match type_dec a b with
      | left He => fun H => Return (contract_cast c a b H He)
      | right _ => fun _ => Failed _ (Typing _ ("ill-typed contract"%string, c, a, b))
      end
    | None => fun _ => Failed _ (Typing _ ("contract not found"%string, c))
    end.

  Definition type_contract_data c a := type_contract_data_aux c a _ eq_refl.

  Fixpoint type_data (d : concrete_data) {struct d}
    : forall ty, M (syntax.concrete_data ty) :=
    match d with
    | Int_constant z =>
      fun ty =>
        match ty with
        | Comparable_type int => Return (syntax.Int_constant z)
        | Comparable_type nat =>
          if (z >=? 0)%Z then Return (syntax.Nat_constant (Z.to_N z))
          else Failed _ (Typing _ ("Negative value cannot be typed in nat"%string, d))
        | Comparable_type mutez =>
          let! m := tez.of_Z z in
          Return (syntax.Mutez_constant (Mk_mutez m))
        | Comparable_type timestamp => Return (syntax.Timestamp_constant z)
        | _ => Failed _ (Typing _ (d, ty))
        end
    | String_constant s =>
      fun ty =>
        match ty with
        | Comparable_type string => Return (syntax.String_constant s)
        | signature => Return (syntax.Signature_constant s)
        | key => Return (syntax.Key_constant s)
        | Comparable_type key_hash => Return (syntax.Key_hash_constant s)
        | contract a =>
          let c := Mk_contract s in
          type_contract_data c a
        | Comparable_type address => Return (syntax.Address_constant (syntax.Mk_address s))
        | chain_id => Return (syntax.Chain_id_constant (syntax.Mk_chain_id s))
        | _ => Failed _ (Typing _ (d, ty))
        end
    | Bytes_constant s =>
      fun ty =>
        match ty with
        | Comparable_type bytes => Return (syntax.Bytes_constant s)
        | _ => Failed _ (Typing _ (d, ty))
        end
    | Unit =>
      fun ty =>
        match ty with
        | unit => Return syntax.Unit
        | _ => Failed _ (Typing _ (d, ty))
        end
    | True_ =>
      fun ty =>
        match ty with
        | Comparable_type bool => Return syntax.True_
        | _ => Failed _ (Typing _ (d, ty))
        end
    | False_ =>
      fun ty =>
        match ty with
        | Comparable_type bool => Return syntax.False_
        | _ => Failed _ (Typing _ (d, ty))
        end
    | Pair x y =>
      fun ty =>
        match ty with
        | pair a b =>
          let! x := type_data x a in
          let! y := type_data y b in
          Return (syntax.Pair x y)
        | _ => Failed _ (Typing _ (d, ty))
        end
    | Left x =>
      fun ty =>
        match ty with
        | or a b =>
          let! x := type_data x a in
          Return (syntax.Left x)
        | _ => Failed _ (Typing _ (d, ty))
        end
    | Right y =>
      fun ty =>
        match ty with
        | or a b =>
          let! y := type_data y b in
          Return (syntax.Right y)
        | _ => Failed _ (Typing _ (d, ty))
        end
    | Some_ x =>
      fun ty =>
        match ty with
        | option a =>
          let! x := type_data x a in
          Return (syntax.Some_ x)
        | _ => Failed _ (Typing _ (d, ty))
        end
    | None_ =>
      fun ty =>
        match ty with
        | option a => Return syntax.None_
        | _ => Failed _ (Typing _ (d, ty))
        end
    | Concrete_seq l =>
      fun ty =>
        match ty with
        | list a =>
          let! l :=
            (fix type_data_list l :=
              match l with
              | nil => Return nil
              | cons x l =>
                let! x := type_data x a in
                let! l := type_data_list l in
                Return (cons x l)
              end
            ) l in
          Return (syntax.Concrete_list l)
        | set a =>
          let! l :=
            (fix type_data_list l :=
              match l with
              | nil => Return nil
              | cons x l =>
                let! x := type_data x a in
                let! l := type_data_list l in
                Return (cons x l)
              end
            ) l in
          Return (syntax.Concrete_set l)
        | map a b =>
          let! l :=
            (fix type_data_list l :=
              match l with
              | nil => Return nil
              | cons (Elt x y) l =>
                let! x := type_data x a in
                let! y := type_data y b in
                let! l := type_data_list l in
                Return (cons (syntax.Elt _ _ x y) l)
              | _ => Failed _ (Typing _ (d, ty))
              end
            ) l in
          Return (syntax.Concrete_map l)
        | _ => Failed _ (Typing _ (d, ty))
        end
    | Instruction i =>
      fun ty =>
        match ty with
        | lambda a b =>
          let! existT _ tff i := type_check_instruction type_instruction i (cons a nil) (cons b nil) in
          Return (syntax.Instruction _ i)
        | _ => Failed _ (Typing _ (d, ty))
        end
    | d => fun ty => Failed _ (Typing _ (d, ty))
    end

  with
  type_instruction {self_type} i A {struct i} : M (typer_result (self_type := self_type) A) :=
    match i, A with
    | NOOP, A => Return (Inferred_type _ _ syntax.NOOP)
    | FAILWITH, a :: A => Return (Any_type _ (fun B => syntax.FAILWITH))
    | SEQ i1 i2, A =>
      let! existT _ B i1 := type_instruction_no_tail_fail type_instruction i1 A in
      let! r2 := type_instruction i2 B in
      match r2 with
      | Inferred_type _ C i2 =>
        Return (Inferred_type _ _ (syntax.SEQ i1 i2))
      | Any_type _ i2 =>
        Return (Any_type _ (fun C => syntax.SEQ i1 (i2 C)))
      end
    | IF_ i1 i2, Comparable_type bool :: A =>
      type_branches type_instruction i1 i2 _ _ _ (fun B tffa tffb => syntax.IF_)
    | IF_NONE i1 i2, option a :: A =>
      type_branches type_instruction i1 i2 _ _ _ (fun B tffa tffb => syntax.IF_NONE)
    | IF_LEFT i1 i2, or a b :: A =>
      type_branches type_instruction i1 i2 _ _ _ (fun B tffa tffb => syntax.IF_LEFT)
    | IF_CONS i1 i2, list a :: A =>
      type_branches type_instruction i1 i2 _ _ _ (fun B tffa tffb => syntax.IF_CONS)
    | LOOP i, Comparable_type bool :: A =>
      let! i := type_check_instruction_no_tail_fail
        type_instruction i A (bool ::: A) in
      Return (Inferred_type _ _ (syntax.LOOP i))
    | LOOP_LEFT i, or a b :: A =>
      let! i := type_check_instruction_no_tail_fail
        type_instruction i (a :: A) (or a b :: A) in
      Return (Inferred_type _ _ (syntax.LOOP_LEFT i))
    | EXEC, a :: lambda a' b :: B =>
      let A := a :: lambda a' b :: B in
      let A' := a :: lambda a b :: B in
      let! i := instruction_cast_domain A' A _ syntax.EXEC in
      Return (Inferred_type _ _ i)
    | APPLY, a :: lambda (pair a' b) c :: B =>
      let A := a :: lambda (pair a' b) c :: B in
      let A' := a :: lambda (pair a b) c :: B in
      (if is_packable a as b return is_packable a = b -> _
       then fun i =>
        let! i := instruction_cast_domain A' A _ (@syntax.APPLY _ _ _ _ _ (IT_eq_rev _ i)) in
        Return (Inferred_type _ _ i)
       else fun _ => Failed _ (Typing _ "APPLY"%string)) eq_refl
    | DUP, a :: A =>
      Return (Inferred_type _ _ syntax.DUP)
    | SWAP, a :: b :: A =>
      Return (Inferred_type _ _ syntax.SWAP)
    | PUSH a v, A =>
      let! d := type_data v a in
      Return (Inferred_type _ _ (syntax.PUSH a d))
    | UNIT, A => Return (Inferred_type _ _ syntax.UNIT)
    | LAMBDA a b i, A =>
      let! existT _ tff i :=
        type_check_instruction type_instruction i (a :: nil) (b :: nil) in
      Return (Inferred_type _ _ (syntax.LAMBDA a b i))
    | EQ, Comparable_type int :: A =>
      Return (Inferred_type _ _ syntax.EQ)
    | NEQ, Comparable_type int :: A =>
      Return (Inferred_type _ _ syntax.NEQ)
    | LT, Comparable_type int :: A =>
      Return (Inferred_type _ _ syntax.LT)
    | GT, Comparable_type int :: A =>
      Return (Inferred_type _ _ syntax.GT)
    | LE, Comparable_type int :: A =>
      Return (Inferred_type _ _ syntax.LE)
    | GE, Comparable_type int :: A =>
      Return (Inferred_type _ _ syntax.GE)
    | OR, Comparable_type bool :: Comparable_type bool :: A =>
      Return (Inferred_type _ _ (@syntax.OR _ _ syntax.bitwise_bool _))
    | OR, Comparable_type nat :: Comparable_type nat :: A =>
      Return (Inferred_type _ _ (@syntax.OR _ _ syntax.bitwise_nat _))
    | AND, Comparable_type bool :: Comparable_type bool :: A =>
      Return (Inferred_type _ _ (@syntax.AND _ _ syntax.bitwise_bool _))
    | AND, Comparable_type nat :: Comparable_type nat :: A =>
      Return (Inferred_type _ _ (@syntax.AND _ _ syntax.bitwise_nat _))
    | XOR, Comparable_type bool :: Comparable_type bool :: A =>
      Return (Inferred_type _ _ (@syntax.XOR _ _ syntax.bitwise_bool _))
    | XOR, Comparable_type nat :: Comparable_type nat :: A =>
      Return (Inferred_type _ _ (@syntax.XOR _ _ syntax.bitwise_nat _))
    | NOT, Comparable_type bool :: A =>
      Return (Inferred_type _ _ (@syntax.NOT _ _ syntax.not_bool _))
    | NOT, Comparable_type nat :: A =>
      Return (Inferred_type _ _ (@syntax.NOT _ _ syntax.not_nat _))
    | NOT, Comparable_type int :: A =>
      Return (Inferred_type _ _ (@syntax.NOT _ _ syntax.not_int _))
    | NEG, Comparable_type nat :: A =>
      Return (Inferred_type _ _ (@syntax.NEG _ _ syntax.neg_nat _))
    | NEG, Comparable_type int :: A =>
      Return (Inferred_type _ _ (@syntax.NEG _ _ syntax.neg_int _))
    | ABS, Comparable_type int :: A =>
      Return (Inferred_type _ _ syntax.ABS)
    | INT, Comparable_type nat :: A =>
      Return (Inferred_type _ _ syntax.INT)
    | ISNAT, Comparable_type int :: A =>
      Return (Inferred_type _ _ syntax.ISNAT)
    | ADD, Comparable_type nat :: Comparable_type nat :: A =>
      Return (Inferred_type _ _ (@syntax.ADD _ _ _ syntax.add_nat_nat _))
    | ADD, Comparable_type nat :: Comparable_type int :: A =>
      Return (Inferred_type _ _ (@syntax.ADD _ _ _ syntax.add_nat_int _))
    | ADD, Comparable_type int :: Comparable_type nat :: A =>
      Return (Inferred_type _ _ (@syntax.ADD _ _ _ syntax.add_int_nat _))
    | ADD, Comparable_type int :: Comparable_type int :: A =>
      Return (Inferred_type _ _ (@syntax.ADD _ _ _ syntax.add_int_int _))
    | ADD, Comparable_type timestamp :: Comparable_type int :: A =>
      Return (Inferred_type _ _ (@syntax.ADD _ _ _ syntax.add_timestamp_int _))
    | ADD, Comparable_type int :: Comparable_type timestamp :: A =>
      Return (Inferred_type _ _ (@syntax.ADD _ _ _ syntax.add_int_timestamp _))
    | ADD, Comparable_type mutez :: Comparable_type mutez :: A =>
      Return (Inferred_type _ _ (@syntax.ADD _ _ _ syntax.add_tez_tez _))
    | SUB, Comparable_type nat :: Comparable_type nat :: A =>
      Return (Inferred_type _ _ (@syntax.SUB _ _ _ syntax.sub_nat_nat _))
    | SUB, Comparable_type nat :: Comparable_type int :: A =>
      Return (Inferred_type _ _ (@syntax.SUB _ _ _ syntax.sub_nat_int _))
    | SUB, Comparable_type int :: Comparable_type nat :: A =>
      Return (Inferred_type _ _ (@syntax.SUB _ _ _ syntax.sub_int_nat _))
    | SUB, Comparable_type int :: Comparable_type int :: A =>
      Return (Inferred_type _ _ (@syntax.SUB _ _ _ syntax.sub_int_int _))
    | SUB, Comparable_type timestamp :: Comparable_type int :: A =>
      Return (Inferred_type _ _ (@syntax.SUB _ _ _ syntax.sub_timestamp_int _))
    | SUB, Comparable_type timestamp :: Comparable_type timestamp :: A =>
      Return (Inferred_type _ _ (@syntax.SUB _ _ _ syntax.sub_timestamp_timestamp _))
    | SUB, Comparable_type mutez :: Comparable_type mutez :: A =>
      Return (Inferred_type _ _ (@syntax.SUB _ _ _ syntax.sub_tez_tez _))
    | MUL, Comparable_type nat :: Comparable_type nat :: A =>
      Return (Inferred_type _ _ (@syntax.MUL _ _ _ syntax.mul_nat_nat _))
    | MUL, Comparable_type nat :: Comparable_type int :: A =>
      Return (Inferred_type _ _ (@syntax.MUL _ _ _ syntax.mul_nat_int _))
    | MUL, Comparable_type int :: Comparable_type nat :: A =>
      Return (Inferred_type _ _ (@syntax.MUL _ _ _ syntax.mul_int_nat _))
    | MUL, Comparable_type int :: Comparable_type int :: A =>
      Return (Inferred_type _ _ (@syntax.MUL _ _ _ syntax.mul_int_int _))
    | MUL, Comparable_type mutez :: Comparable_type nat :: A =>
      Return (Inferred_type _ _ (@syntax.MUL _ _ _ syntax.mul_tez_nat _))
    | MUL, Comparable_type nat :: Comparable_type mutez :: A =>
      Return (Inferred_type _ _ (@syntax.MUL _ _ _ syntax.mul_nat_tez _))
    | EDIV, Comparable_type nat :: Comparable_type nat :: A =>
      Return (Inferred_type _ _ (@syntax.EDIV _ _ _ syntax.ediv_nat_nat _))
    | EDIV, Comparable_type nat :: Comparable_type int :: A =>
      Return (Inferred_type _ _ (@syntax.EDIV _ _ _ syntax.ediv_nat_int _))
    | EDIV, Comparable_type int :: Comparable_type nat :: A =>
      Return (Inferred_type _ _ (@syntax.EDIV _ _ _ syntax.ediv_int_nat _))
    | EDIV, Comparable_type int :: Comparable_type int :: A =>
      Return (Inferred_type _ _ (@syntax.EDIV _ _ _ syntax.ediv_int_int _))
    | EDIV, Comparable_type mutez :: Comparable_type nat :: A =>
      Return (Inferred_type _ _ (@syntax.EDIV _ _ _ syntax.ediv_tez_nat _))
    | EDIV, Comparable_type mutez :: Comparable_type mutez :: A =>
      Return (Inferred_type _ _ (@syntax.EDIV _ _ _ syntax.ediv_tez_tez _))
    | LSL, Comparable_type nat :: Comparable_type nat :: A =>
      Return (Inferred_type _ _ syntax.LSL)
    | LSR, Comparable_type nat :: Comparable_type nat :: A =>
      Return (Inferred_type _ _ syntax.LSR)
    | COMPARE, a :: a' :: B =>
      let A := a ::: a' ::: B in
      let! a : comparable_type := as_comparable a in
      let! a' : comparable_type := as_comparable a' in
      let A' := a ::: a ::: B in
      let! i := instruction_cast_domain A' A (int ::: B) (syntax.COMPARE (a := a)) in
      Return (Inferred_type _ _ i)
    | CONCAT, Comparable_type string :: Comparable_type string :: B =>
      Return (Inferred_type _ _ (@syntax.CONCAT _ _ stringlike_string _))
    | CONCAT, Comparable_type bytes :: Comparable_type bytes :: B =>
      Return (Inferred_type _ _ (@syntax.CONCAT _ _ stringlike_bytes _))
    | CONCAT, list (Comparable_type string) :: B =>
      Return (Inferred_type _ _ (@syntax.CONCAT_list _ _ stringlike_string _))
    | CONCAT, list (Comparable_type bytes) :: B =>
      Return (Inferred_type _ _ (@syntax.CONCAT_list _ _ stringlike_bytes _))
    | SIZE, set a :: A =>
      Return (Inferred_type _ _ (@syntax.SIZE _ _ (size_set a) _))
    | SIZE, cons (list a) A =>
      Return (Inferred_type _ _ (@syntax.SIZE _ _ (size_list a) _))
    | SIZE, cons (map a b) A =>
      Return (Inferred_type _ _ (@syntax.SIZE _ _ (size_map a b) _))
    | SIZE, Comparable_type string :: A =>
      Return (Inferred_type _ _ (@syntax.SIZE _ _ size_string _))
    | SIZE, Comparable_type bytes :: A =>
      Return (Inferred_type _ _ (@syntax.SIZE _ _ size_bytes _))
    | SLICE, Comparable_type nat :: Comparable_type nat :: Comparable_type string :: A =>
      Return (Inferred_type _ _ (@syntax.SLICE _ _ stringlike_string _))
    | SLICE, Comparable_type nat :: Comparable_type nat :: Comparable_type bytes :: A =>
      Return (Inferred_type _ _ (@syntax.SLICE _ _ stringlike_bytes _))
    | PAIR, a :: b :: A =>
      Return (Inferred_type _ _ syntax.PAIR)
    | CAR, pair a b :: A =>
      Return (Inferred_type _ _ syntax.CAR)
    | CDR, pair a b :: A =>
      Return (Inferred_type _ _ syntax.CDR)
    | EMPTY_SET c, A =>
      Return (Inferred_type _ _ (syntax.EMPTY_SET c))
    | MEM, elt' :: set elt :: B =>
      let A := elt' :: set elt :: B in
      let A' := elt ::: set elt :: B in
      let! i := instruction_cast_domain
        A' A _ (@syntax.MEM _ _ _ (mem_set elt) _) in
      Return (Inferred_type _ _ i)
    | MEM, kty' :: map kty vty :: B =>
      let A := kty' :: map kty vty :: B in
      let A' := kty ::: map kty vty :: B in
      let! i := instruction_cast_domain
        A' A _ (@syntax.MEM _ _ _ (mem_map kty vty) _) in
      Return (Inferred_type _ _ i)
    | MEM, kty' :: big_map kty vty :: B =>
      let A := kty' :: big_map kty vty :: B in
      let A' := kty ::: big_map kty vty :: B in
      let! i := instruction_cast_domain
        A' A _ (@syntax.MEM _ _ _ (mem_bigmap kty vty) _) in
      Return (Inferred_type _ _ i)
    | UPDATE, elt' :: Comparable_type bool :: set elt :: B =>
      let A := elt' ::: bool ::: set elt :: B in
      let A' := elt ::: bool ::: set elt :: B in
      let! i := instruction_cast_domain
        A' A _ (@syntax.UPDATE _ _ _ _ (update_set elt) _) in
      Return (Inferred_type _ _ i)
    | UPDATE, kty' :: option vty' :: map kty vty :: B =>
      let A := kty' ::: option vty' ::: map kty vty :: B in
      let A' := kty ::: option vty ::: map kty vty :: B in
      let! i := instruction_cast_domain
        A' A _ (@syntax.UPDATE _ _ _ _ (update_map kty vty) _) in
      Return (Inferred_type _ _ i)
    | UPDATE, kty' :: option vty' :: big_map kty vty :: B =>
      let A := kty' ::: option vty' ::: big_map kty vty :: B in
      let A' := kty ::: option vty ::: big_map kty vty :: B in
      let! i := instruction_cast_domain
        A' A _ (@syntax.UPDATE _ _ _ _ (update_bigmap kty vty) _) in
      Return (Inferred_type _ _ i)
    | ITER i, list a :: A =>
      let! i := type_check_instruction_no_tail_fail type_instruction i (a :: A) A in
      Return (Inferred_type _ _ (syntax.ITER i))
    | ITER i, set a :: A =>
      let! i := type_check_instruction_no_tail_fail type_instruction i (a ::: A) A in
      Return (Inferred_type _ _ (syntax.ITER i))
    | ITER i, map kty vty :: A =>
      let! i := type_check_instruction_no_tail_fail type_instruction i (pair kty vty :: A) A in
      Return (Inferred_type _ _ (syntax.ITER i))
    | EMPTY_MAP kty vty, A =>
      Return (Inferred_type _ _ (syntax.EMPTY_MAP kty vty))
    | EMPTY_BIG_MAP kty vty, A =>
      Return (Inferred_type _ _ (syntax.EMPTY_BIG_MAP kty vty))
    | GET, kty' :: map kty vty :: B =>
      let A := kty' :: map kty vty :: B in
      let A' := kty ::: map kty vty :: B in
      let! i := instruction_cast_domain
        A' A _ (@syntax.GET _ _ _ (get_map kty vty) _) in
      Return (Inferred_type _ _ i)
    | GET, kty' :: big_map kty vty :: B =>
      let A := kty' :: big_map kty vty :: B in
      let A' := kty ::: big_map kty vty :: B in
      let! i := instruction_cast_domain
        A' A _ (@syntax.GET _ _ _ (get_bigmap kty vty) _) in
      Return (Inferred_type _ _ i)
    | MAP i, list a :: A =>
      let! r := type_instruction_no_tail_fail type_instruction i (a :: A) in
      match r with
      | existT _ (b :: A') i =>
        let! i := instruction_cast_range (a :: A) (b :: A') (b :: A) i in
        Return (Inferred_type _ _ (syntax.MAP i))
      | _ => Failed _ (Typing _ tt)
      end
    | MAP i, map kty vty :: A =>
      let! r := type_instruction_no_tail_fail type_instruction i (pair kty vty ::: A) in
      match r with
      | existT _ (b :: A') i =>
        let! i := instruction_cast_range (pair kty vty :: A) (b :: A') (b :: A) i in
        Return (Inferred_type _ _ (syntax.MAP i))
      | _ => Failed _ (Typing _ tt)
      end
    | SOME, a :: A => Return (Inferred_type _ _ syntax.SOME)
    | NONE a, A => Return (Inferred_type _ _ (syntax.NONE a))
    | LEFT b, a :: A => Return (Inferred_type _ _ (syntax.LEFT b))
    | RIGHT a, b :: A => Return (Inferred_type _ _ (syntax.RIGHT a))
    | CONS, a' :: list a :: B =>
      let A := a' :: list a :: B in
      let A' := a :: list a :: B in
      let! i := instruction_cast_domain A' A _ (syntax.CONS) in
      Return (Inferred_type _ _ i)
    | NIL a, A => Return (Inferred_type _ _ (syntax.NIL a))
    | CREATE_CONTRACT g p i,
      option (Comparable_type key_hash) :: Comparable_type mutez :: g2 :: B =>
      let A :=
          option key_hash ::: mutez ::: g2 :: B in
      let A' :=
          option key_hash ::: mutez ::: g ::: B in
      let! existT _ tff i :=
        type_check_instruction (self_type := Some p) type_instruction i (pair p g :: nil) (pair (list operation) g :: nil) in
      let! i := instruction_cast_domain A' A _ (syntax.CREATE_CONTRACT g p i) in
      Return (Inferred_type _ _ i)
    | TRANSFER_TOKENS, p1 :: Comparable_type mutez :: contract p2 :: B =>
      let A := p1 ::: mutez ::: contract p2 ::: B in
      let A' := p1 ::: mutez ::: contract p1 ::: B in
      let! i := instruction_cast_domain A' A _ syntax.TRANSFER_TOKENS in
      Return (Inferred_type _ _ i)
    | SET_DELEGATE, option (Comparable_type key_hash) :: A =>
      Return (Inferred_type _ _ syntax.SET_DELEGATE)
    | BALANCE, A =>
      Return (Inferred_type _ _ syntax.BALANCE)
    | ADDRESS, contract _ :: A =>
      Return (Inferred_type _ _ syntax.ADDRESS)
    | CONTRACT ty, Comparable_type address :: A =>
      Return (Inferred_type _ _ (syntax.CONTRACT ty))
    | SOURCE, A =>
      Return (Inferred_type _ _ syntax.SOURCE)
    | SENDER, A =>
      Return (Inferred_type _ _ syntax.SENDER)
    | SELF, A =>
      match self_type with
      | Some sty => Return (Inferred_type _ _ syntax.SELF)
      | None => Failed _ (Typing _ "SELF is not allowed inside lambdas"%string)
      end
    | AMOUNT, A =>
      Return (Inferred_type _ _ syntax.AMOUNT)
    | IMPLICIT_ACCOUNT, Comparable_type key_hash :: A =>
      Return (Inferred_type _ _ syntax.IMPLICIT_ACCOUNT)
    | NOW, A =>
      Return (Inferred_type _ _ syntax.NOW)
    | PACK, a :: A =>
      Return (Inferred_type _ _ syntax.PACK)
    | UNPACK ty, Comparable_type bytes :: A =>
      Return (Inferred_type _ _ (syntax.UNPACK ty))
    | HASH_KEY, key :: A =>
      Return (Inferred_type _ _ syntax.HASH_KEY)
    | BLAKE2B, Comparable_type bytes :: A =>
      Return (Inferred_type _ _ syntax.BLAKE2B)
    | SHA256, Comparable_type bytes :: A =>
      Return (Inferred_type _ _ syntax.SHA256)
    | SHA512, Comparable_type bytes :: A =>
      Return (Inferred_type _ _ syntax.SHA512)
    | CHECK_SIGNATURE, key :: signature :: Comparable_type bytes :: A =>
      Return (Inferred_type _ _ syntax.CHECK_SIGNATURE)
    | DIG n, A => type_check_dig n _
    | DUG n, A => type_check_dug n _
    | DIP n i, S12 =>
      let! (exist _ S1 H1, S2) := take_n S12 n in
      let! existT _ B i := type_instruction_no_tail_fail type_instruction i S2 in
      let! i := instruction_cast_domain (S1 +++ S2) S12 _ (syntax.DIP n H1 i) in
      Return (Inferred_type S12 (S1 +++ B) i)
    | DROP n, S12 =>
      let! (exist _ S1 H1, S2) := take_n S12 n in
      let! i := instruction_cast_domain (S1 +++ S2) S12 _ (syntax.DROP n H1) in
      Return (Inferred_type S12 S2 i)
    | CHAIN_ID, _ =>
      Return (Inferred_type _ _ syntax.CHAIN_ID)
    | _, _ => Failed _ (Typing _ (i, A))
    end.
End Typer.


Require Import Coq.Lists.List.
Require Import MirrorShard.SepExpr.
Require Import MirrorShard.ExprTac.

Module Make (ST : SepTheory.SepTheory) (SE : SepExpr ST).

  Section abstracted.
    Variables (not : Prop -> Prop)
              (emp : ST.hprop)
              (star : ST.hprop -> ST.hprop -> ST.hprop)
              (ex : forall T : Type, (T -> ST.hprop) -> ST.hprop)
              (inj : Prop -> ST.hprop).
    Variables (types : list Expr.type) (funcs : Expr.functions types)
      (sfuncs : SE.predicates types) (meta_env : Expr.env types).

    Fixpoint nsexprD (var_env : Expr.env types) (s : SE.sexpr types)
      {struct s} : ST.hprop :=
      match s with
        | SE.Emp => emp
        | SE.Inj p =>
          match nexprD not types funcs meta_env var_env p Expr.tvProp with
            | Some p0 => inj p0
            | None => inj (SepExpr.BadInj p)
          end
        | SE.Star l r =>
          star (nsexprD var_env l) (nsexprD var_env r)
        | SE.Exists t b =>
          ex _
          (fun x : Expr.tvarD types t =>
            nsexprD (@existT _ (Expr.tvarD types) t x :: var_env) b)
        | SE.Func f b =>
          match nth_error sfuncs f with
            | Some f' =>
              match
                Expr.applyD (nexprD not types funcs meta_env var_env)
                (SE.SDomain f') b ST.hprop (SE.SDenotation f')
                with
                | Some p => p
                | None => inj (SepExpr.BadPredApply f b var_env)
              end
            | None => inj (SepExpr.BadPred f)
          end
        | SE.Const p => p
      end.
  End abstracted.

  Theorem nsexprD_sexprD : nsexprD not ST.emp ST.star ST.ex ST.inj = SE.sexprD.
  Proof. reflexivity. Qed.
End Make.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A1 A2 B1 B2 C1 C2 Q P R M C0 : Universe, ((wd_ Q P /\ (wd_ P R /\ (wd_ Q R /\ (wd_ A1 A2 /\ (wd_ C1 C2 /\ (wd_ B1 B2 /\ (wd_ M Q /\ (wd_ C1 C0 /\ (wd_ C2 C0 /\ (wd_ P C0 /\ (wd_ Q C1 /\ (wd_ Q C2 /\ (wd_ B2 P /\ (wd_ B1 P /\ (wd_ A2 R /\ (wd_ A1 R /\ (wd_ B1 C1 /\ (wd_ B1 C2 /\ (wd_ B2 C1 /\ (wd_ B2 C2 /\ (col_ A1 A2 Q /\ (col_ B1 B2 Q /\ (col_ A1 A2 P /\ (col_ C1 C2 P /\ (col_ B1 B2 R /\ (col_ C1 C2 C0 /\ col_ P Q C0)))))))))))))))))))))))))) -> col_ Q C1 C2)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Wasm Require Import datatypes_properties binary_parser_types.
From Wasm Require Import binary_format_parser binary_format_printer.
From compcert Require Import Integers.
From parseque Require Import Parseque.
Require Import Byte.
Require Import leb128.
Require Import Coq.Arith.Le.

Inductive repr_unsigned : list byte -> module -> Prop :=
.

Inductive repr_module : list byte -> module -> Prop :=
.

(* TODO: we should have ast->binary->ast = id
   but not binary->ast->binary /= id, because of non-unique representation  *)

Lemma encode_decode_is_identity : forall m,
(* TODO: probably need some well-formedness condition, for example of block types *)
  run_parse_module (binary_of_module m) = Some m.
(* TODO *)
Admitted.


From iris.program_logic Require Export weakestpre.
From iris.program_logic Require Import lifting adequacy.
From iris.program_logic Require ectx_language.
From iris.algebra Require Import auth.
From iris.proofmode Require Import tactics classes.
Set Default Proof Using "Type".

Class ownPG (Λ : language) (Σ : gFunctors) := OwnPG {
  ownP_invG : invG Σ;
  ownP_inG :> inG Σ (authR (optionUR (exclR (stateC Λ))));
  ownP_name : gname;
}.

Instance ownPG_irisG `{ownPG Λ Σ} : irisG Λ Σ := {
  iris_invG := ownP_invG;
  state_interp σ κs _ := own ownP_name (● (Excl' σ))%I;
  fork_post _ := True%I;
}.
Global Opaque iris_invG.

Definition ownPΣ (Λ : language) : gFunctors :=
  #[invΣ;
    GFunctor (authR (optionUR (exclR (stateC Λ))))].

Class ownPPreG (Λ : language) (Σ : gFunctors) : Set := IrisPreG {
  ownPPre_invG :> invPreG Σ;
  ownPPre_state_inG :> inG Σ (authR (optionUR (exclR (stateC Λ))))
}.

Instance subG_ownPΣ {Λ Σ} : subG (ownPΣ Λ) Σ → ownPPreG Λ Σ.
Proof. solve_inG. Qed.

(** Ownership *)
Definition ownP `{ownPG Λ Σ} (σ : state Λ) : iProp Σ :=
  own ownP_name (◯ (Excl' σ)).

Typeclasses Opaque ownP.
Instance: Params (@ownP) 3.

(* Adequacy *)
Theorem ownP_adequacy Σ `{ownPPreG Λ Σ} s e σ φ :
  (∀ `{ownPG Λ Σ}, ownP σ ⊢ WP e @ s; ⊤ {{ v, ⌜φ v⌝ }}) →
  adequate s e σ (λ v _, φ v).
Proof.
  intros Hwp. apply (wp_adequacy Σ _).
  iIntros (? κs).
  iMod (own_alloc (● (Excl' σ) ⋅ ◯ (Excl' σ))) as (γσ) "[Hσ Hσf]"; first done.
  iModIntro. iExists (λ σ κs, own γσ (● (Excl' σ)))%I.
  iFrame "Hσ".
  iApply (Hwp (OwnPG _ _ _ _ γσ)). rewrite /ownP. iFrame.
Qed.

Theorem ownP_invariance Σ `{ownPPreG Λ Σ} s e σ1 t2 σ2 φ :
  (∀ `{ownPG Λ Σ},
      ownP σ1 ={⊤}=∗ WP e @ s; ⊤ {{ _, True }} ∗
      |={⊤,∅}=> ∃ σ', ownP σ' ∧ ⌜φ σ'⌝) →
  rtc erased_step ([e], σ1) (t2, σ2) →
  φ σ2.
Proof.
  intros Hwp Hsteps. eapply (wp_invariance Σ Λ s e σ1 t2 σ2 _)=> //.
  iIntros (? κs κs').
  iMod (own_alloc (● (Excl' σ1) ⋅ ◯ (Excl' σ1))) as (γσ) "[Hσ Hσf]"; first done.
  iExists (λ σ κs' _, own γσ (● (Excl' σ)))%I, (λ _, True%I).
  iFrame "Hσ".
  iMod (Hwp (OwnPG _ _ _ _ γσ) with "[Hσf]") as "[$ H]";
    first by rewrite /ownP; iFrame.
  iIntros "!> Hσ". iMod "H" as (σ2') "[Hσf %]". rewrite /ownP.
  iDestruct (own_valid_2 with "Hσ Hσf")
    as %[Hp%Excl_included _]%auth_valid_discrete_2; simplify_eq; auto.
Qed.

(** Lifting *)
Section lifting.
  Context `{ownPG Λ Σ}.
  Implicit Types s : stuckness.
  Implicit Types e : expr Λ.
  Implicit Types Φ : val Λ → iProp Σ.

  Lemma ownP_eq σ1 σ2 κs n : state_interp σ1 κs n -∗ ownP σ2 -∗ ⌜σ1 = σ2⌝.
  Proof.
    iIntros "Hσ● Hσ◯". rewrite /ownP.
    iDestruct (own_valid_2 with "Hσ● Hσ◯") as %[Hps _]%auth_valid_discrete_2.
    by pose proof (leibniz_equiv _ _ (Excl_included _ _ Hps)) as ->.
  Qed.
  Lemma ownP_state_twice σ1 σ2 : ownP σ1 ∗ ownP σ2 ⊢ False.
  Proof. rewrite /ownP -own_op own_valid. by iIntros (?). Qed.
  Global Instance ownP_timeless σ : Timeless (@ownP Λ Σ _ σ).
  Proof. rewrite /ownP; apply _. Qed.

  Lemma ownP_lift_step s E Φ e1 :
    (|={E,∅}=> ∃ σ1, ⌜if s is NotStuck then reducible e1 σ1 else to_val e1 = None⌝ ∗
      ▷ ownP σ1 ∗
      ▷ ∀ κ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ -∗
      ownP σ2
            ={∅,E}=∗ WP e2 @ s; E {{ Φ }} ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
    ⊢ WP e1 @ s; E {{ Φ }}.
  Proof.
    iIntros "H". destruct (to_val e1) as [v|] eqn:EQe1.
    - apply of_to_val in EQe1 as <-. iApply fupd_wp.
      iMod "H" as (σ1) "[Hred _]"; iDestruct "Hred" as %Hred.
      destruct s; last done. apply reducible_not_val in Hred.
      move: Hred; by rewrite to_of_val.
    - iApply wp_lift_step; [done|]; iIntros (σ1 κ κs n) "Hσκs".
      iMod "H" as (σ1' ?) "[>Hσf H]".
      iDestruct (ownP_eq with "Hσκs Hσf") as %<-.
      iModIntro; iSplit; [by destruct s|]; iNext; iIntros (e2 σ2 efs Hstep).
      iDestruct "Hσκs" as "Hσ". rewrite /ownP.
      iMod (own_update_2 with "Hσ Hσf") as "[Hσ Hσf]".
      { apply auth_update. apply: option_local_update.
         by apply: (exclusive_local_update _ (Excl σ2)). }
      iFrame "Hσ". iApply ("H" with "[]"); eauto with iFrame.
  Qed.

  Lemma ownP_lift_stuck E Φ e :
    (|={E,∅}=> ∃ σ, ⌜stuck e σ⌝ ∗ ▷ (ownP σ))
    ⊢ WP e @ E ?{{ Φ }}.
  Proof.
    iIntros "H". destruct (to_val e) as [v|] eqn:EQe.
    - apply of_to_val in EQe as <-. iApply fupd_wp.
      iMod "H" as (σ1) "[H _]". iDestruct "H" as %[Hnv _]. exfalso.
      by rewrite to_of_val in Hnv.
    - iApply wp_lift_stuck; [done|]. iIntros (σ1 κs n) "Hσ".
      iMod "H" as (σ1') "(% & >Hσf)".
      by iDestruct (ownP_eq with "Hσ Hσf") as %->.
  Qed.

  Lemma ownP_lift_pure_step `{Inhabited (state Λ)} s E Φ e1 :
    (∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
    (∀ σ1 κ e2 σ2 efs, prim_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1) →
    (▷ ∀ κ e2 efs σ, ⌜prim_step e1 σ κ e2 σ efs⌝ →
      WP e2 @ s; E {{ Φ }} ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
    ⊢ WP e1 @ s; E {{ Φ }}.
  Proof.
    iIntros (Hsafe Hstep) "H"; iApply wp_lift_step.
    { specialize (Hsafe inhabitant). destruct s; last done.
      by eapply reducible_not_val. }
    iIntros (σ1 κ κs n) "Hσ". iMod (fupd_intro_mask' E ∅) as "Hclose"; first set_solver.
    iModIntro; iSplit; [by destruct s|]; iNext; iIntros (e2 σ2 efs ?).
    destruct (Hstep σ1 κ e2 σ2 efs); auto; subst.
    by iMod "Hclose"; iModIntro; iFrame; iApply "H".
  Qed.

  (** Derived lifting lemmas. *)
  Lemma ownP_lift_atomic_step {s E Φ} e1 σ1 :
    (if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
    (▷ (ownP σ1) ∗
       ▷ ∀ κ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ -∗
         ownP σ2 -∗
      from_option Φ False (to_val e2) ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
    ⊢ WP e1 @ s; E {{ Φ }}.
  Proof.
    iIntros (?) "[Hσ H]"; iApply ownP_lift_step.
    iMod (fupd_intro_mask' E ∅) as "Hclose"; first set_solver.
    iModIntro; iExists σ1; iFrame; iSplit; first by destruct s.
    iNext; iIntros (κ e2 σ2 efs ?) "Hσ".
    iDestruct ("H" $! κ e2 σ2 efs with "[] [Hσ]") as "[HΦ $]"; [by eauto..|].
    destruct (to_val e2) eqn:?; last by iExFalso.
    iMod "Hclose"; iApply wp_value; last done. by apply of_to_val.
  Qed.

  Lemma ownP_lift_atomic_det_step {s E Φ e1} σ1 v2 σ2 efs :
    (if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
    (∀ κ' e2' σ2' efs', prim_step e1 σ1 κ' e2' σ2' efs' →
                     σ2' = σ2 ∧ to_val e2' = Some v2 ∧ efs' = efs) →
    ▷ (ownP σ1) ∗ ▷ (ownP σ2 -∗
      Φ v2 ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
    ⊢ WP e1 @ s; E {{ Φ }}.
  Proof.
    iIntros (? Hdet) "[Hσ1 Hσ2]"; iApply ownP_lift_atomic_step; try done.
    iFrame; iNext; iIntros (κ' e2' σ2' efs' ?) "Hσ2'".
    edestruct (Hdet κ') as (<-&Hval&<-); first done. rewrite Hval.
    iApply ("Hσ2" with "Hσ2'").
  Qed.

  Lemma ownP_lift_atomic_det_step_no_fork {s E e1} σ1 v2 σ2 :
    (if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
    (∀ κ' e2' σ2' efs', prim_step e1 σ1 κ' e2' σ2' efs' →
      σ2' = σ2 ∧ to_val e2' = Some v2 ∧ efs' = []) →
    {{{ ▷ (ownP σ1) }}} e1 @ s; E {{{ RET v2; ownP σ2 }}}.
  Proof.
    intros. rewrite -(ownP_lift_atomic_det_step σ1 v2 σ2 []); [|done..].
    rewrite big_sepL_nil right_id. apply bi.wand_intro_r. iIntros "[Hs Hs']".
    iSplitL "Hs"; first by iFrame. iModIntro. iIntros "Hσ2". iApply "Hs'". iFrame.
  Qed.

  Lemma ownP_lift_pure_det_step_no_fork `{Inhabited (state Λ)} {s E Φ} e1 e2 :
    (∀ σ1, if s is NotStuck then reducible e1 σ1 else to_val e1 = None) →
    (∀ σ1 κ e2' σ2 efs', prim_step e1 σ1 κ e2' σ2 efs' → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
    ▷ WP e2 @ s; E {{ Φ }} ⊢ WP e1 @ s; E {{ Φ }}.
  Proof.
    intros. rewrite -(wp_lift_pure_det_step_no_fork e1 e2) //; eauto.
  Qed.
End lifting.

Section ectx_lifting.
  Import ectx_language.
  Context {Λ : ectxLanguage} `{ownPG Λ Σ} {Hinh : Inhabited (state Λ)}.
  Implicit Types s : stuckness.
  Implicit Types Φ : val Λ → iProp Σ.
  Implicit Types e : expr Λ.
  Hint Resolve head_prim_reducible head_reducible_prim_step.
  Hint Resolve (reducible_not_val _ inhabitant).
  Hint Resolve head_stuck_stuck.

  Lemma ownP_lift_head_step s E Φ e1 :
    (|={E,∅}=> ∃ σ1, ⌜head_reducible e1 σ1⌝ ∗ ▷ (ownP σ1) ∗
            ▷ ∀ κ e2 σ2 efs, ⌜head_step e1 σ1 κ e2 σ2 efs⌝ -∗
            ownP σ2
            ={∅,E}=∗ WP e2 @ s; E {{ Φ }} ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
    ⊢ WP e1 @ s; E {{ Φ }}.
  Proof.
    iIntros "H". iApply ownP_lift_step.
    iMod "H" as (σ1 ?) "[>Hσ1 Hwp]". iModIntro. iExists σ1. iSplit.
    { destruct s; try by eauto using reducible_not_val. }
    iFrame. iNext. iIntros (κ e2 σ2 efs ?) "Hσ2".
    iApply ("Hwp" with "[] Hσ2"); eauto.
  Qed.

  Lemma ownP_lift_head_stuck E Φ e :
    sub_redexes_are_values e →
    (|={E,∅}=> ∃ σ, ⌜head_stuck e σ⌝ ∗ ▷ (ownP σ))
    ⊢ WP e @ E ?{{ Φ }}.
  Proof.
    iIntros (?) "H". iApply ownP_lift_stuck. iMod "H" as (σ) "[% >Hσ]".
    iExists σ. iModIntro. by auto with iFrame.
  Qed.

  Lemma ownP_lift_pure_head_step s E Φ e1 :
    (∀ σ1, head_reducible e1 σ1) →
    (∀ σ1 κ e2 σ2 efs, head_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1) →
    (▷ ∀ κ e2 efs σ, ⌜head_step e1 σ κ e2 σ efs⌝ →
      WP e2 @ s; E {{ Φ }} ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
    ⊢ WP e1 @ s; E {{ Φ }}.
  Proof using Hinh.
    iIntros (??) "H".  iApply ownP_lift_pure_step; eauto.
    { by destruct s; auto. }
    iNext. iIntros (?????). iApply "H"; eauto.
  Qed.

  Lemma ownP_lift_atomic_head_step {s E Φ} e1 σ1 :
    head_reducible e1 σ1 →
    ▷ (ownP σ1) ∗ ▷ (∀ κ e2 σ2 efs,
    ⌜head_step e1 σ1 κ e2 σ2 efs⌝ -∗ ownP σ2 -∗
      from_option Φ False (to_val e2) ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
    ⊢ WP e1 @ s; E {{ Φ }}.
  Proof.
    iIntros (?) "[Hst H]". iApply ownP_lift_atomic_step; eauto.
    { by destruct s; eauto using reducible_not_val. }
    iSplitL "Hst"; first done.
    iNext. iIntros (???? ?) "Hσ". iApply ("H" with "[] Hσ"); eauto.
  Qed.

  Lemma ownP_lift_atomic_det_head_step {s E Φ e1} σ1 v2 σ2 efs :
    head_reducible e1 σ1 →
    (∀ κ' e2' σ2' efs', head_step e1 σ1 κ' e2' σ2' efs' →
      σ2' = σ2 ∧ to_val e2' = Some v2 ∧ efs' = efs) →
    ▷ (ownP σ1) ∗ ▷ (ownP σ2 -∗
                      Φ v2 ∗ [∗ list] ef ∈ efs, WP ef @ s; ⊤ {{ _, True }})
    ⊢ WP e1 @ s; E {{ Φ }}.
  Proof.
    intros Hr Hs.
    destruct s; apply ownP_lift_atomic_det_step; eauto using reducible_not_val;
    intros; eapply Hs; eauto 10.
  Qed.

  Lemma ownP_lift_atomic_det_head_step_no_fork {s E e1} σ1 κ v2 σ2 :
    head_reducible e1 σ1 →
    (∀ κ' e2' σ2' efs', head_step e1 σ1 κ' e2' σ2' efs' →
      κ' = κ ∧ σ2' = σ2 ∧ to_val e2' = Some v2 ∧ efs' = []) →
    {{{ ▷ (ownP σ1) }}} e1 @ s; E {{{ RET v2; ownP σ2 }}}.
  Proof.
    intros ???; apply ownP_lift_atomic_det_step_no_fork; last naive_solver.
    by destruct s; eauto using reducible_not_val.
  Qed.

  Lemma ownP_lift_pure_det_head_step_no_fork {s E Φ} e1 e2 :
    (∀ σ1, head_reducible e1 σ1) →
    (∀ σ1 κ e2' σ2 efs', head_step e1 σ1 κ e2' σ2 efs' → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
    ▷ WP e2 @ s; E {{ Φ }} ⊢ WP e1 @ s; E {{ Φ }}.
  Proof using Hinh.
    iIntros (??) "H"; iApply wp_lift_pure_det_step_no_fork; try by eauto.
    by destruct s; eauto using reducible_not_val.
  Qed.
End ectx_lifting.


From iris.proofmode Require Import
  proofmode.

From caml5 Require Import
  prelude.
From caml5.common Require Export
  natinf.
From caml5 Require Export
  base.
From caml5.algebra Require Import
  lib.auth_natinf_min.

Class AuthNatinfMinG Σ := {
  auth_natinf_min_G_inG : inG Σ auth_natinf_min_R ;
}.
#[local] Existing Instance auth_natinf_min_G_inG.

Definition auth_natinf_min_Σ := #[
  GFunctor auth_natinf_min_R
].
#[global] Instance subG_auth_natinf_min_Σ Σ :
  subG auth_natinf_min_Σ Σ →
  AuthNatinfMinG Σ.
Proof.
  solve_inG.
Qed.

Section auth_natinf_min_G.
  Context `{!AuthNatinfMinG Σ}.
  Implicit Types n m : natinf.

  Definition auth_natinf_min_auth γ dq n :=
    own γ (auth_natinf_min_auth dq n).
  Definition auth_natinf_min_frag γ n :=
    own γ (auth_natinf_min_frag n).

  #[global] Instance auth_natinf_min_auth_timeless γ dq n :
    Timeless (auth_natinf_min_auth γ dq n).
  Proof.
    apply _.
  Qed.
  #[global] Instance auth_natinf_min_auth_persistent γ n :
    Persistent (auth_natinf_min_auth γ DfracDiscarded n).
  Proof.
    apply _.
  Qed.
  #[global] Instance auth_natinf_min_frag_timeless γ n :
    Timeless (auth_natinf_min_frag γ n).
  Proof.
    apply _.
  Qed.
  #[global] Instance auth_natinf_min_frag_persistent γ n :
    Persistent (auth_natinf_min_frag γ n).
  Proof.
    apply _.
  Qed.

  #[global] Instance auth_natinf_min_auth_fractional γ n :
    Fractional (λ q, auth_natinf_min_auth γ (DfracOwn q) n).
  Proof.
    intros ?*. rewrite -own_op -auth_natinf_min_auth_dfrac_op //.
  Qed.
  #[global] Instance auth_natinf_min_auth_as_fractional γ q n :
    AsFractional (auth_natinf_min_auth γ (DfracOwn q) n) (λ q, auth_natinf_min_auth γ (DfracOwn q) n) q.
  Proof.
    split; done || apply _.
  Qed.

  Lemma auth_natinf_min_auth_persist γ dq n :
    auth_natinf_min_auth γ dq n ==∗
    auth_natinf_min_auth γ DfracDiscarded n.
  Proof.
    iApply own_update. apply auth_natinf_min_auth_persist.
  Qed.

  Lemma auth_natinf_min_alloc n :
    ⊢ |==> ∃ γ,
      auth_natinf_min_auth γ (DfracOwn 1) n.
  Proof.
    iMod (own_alloc (auth_natinf_min.auth_natinf_min_auth (DfracOwn 1) n)) as "(% & ?)".
    { apply auth_natinf_min_auth_valid. }
    naive_solver.
  Qed.

  Lemma auth_natinf_min_auth_valid γ dq a :
    auth_natinf_min_auth γ dq a -∗
    ⌜✓ dq⌝.
  Proof.
    iIntros. iDestruct (own_valid with "[$]") as %?%auth_natinf_min_auth_dfrac_valid. done.
  Qed.
  Lemma auth_natinf_min_auth_combine γ dq1 n1 dq2 n2 :
    auth_natinf_min_auth γ dq1 n1 -∗
    auth_natinf_min_auth γ dq2 n2 -∗
      auth_natinf_min_auth γ (dq1 ⋅ dq2) n1 ∗
      ⌜n1 = n2⌝.
  Proof.
    iIntros "H●1 H●2". iCombine "H●1 H●2" as "H●".
    iDestruct (own_valid with "H●") as %(? & <-)%auth_natinf_min_auth_dfrac_op_valid.
    rewrite -auth_natinf_min_auth_dfrac_op. naive_solver.
  Qed.
  Lemma auth_natinf_min_auth_valid_2 γ dq1 n1 dq2 n2 :
    auth_natinf_min_auth γ dq1 n1 -∗
    auth_natinf_min_auth γ dq2 n2 -∗
    ⌜✓ (dq1 ⋅ dq2) ∧ n1 = n2⌝.
  Proof.
    iIntros "H●1 H●2".
    iDestruct (auth_natinf_min_auth_combine with "H●1 H●2") as "(H● & %)".
    iDestruct (auth_natinf_min_auth_valid with "H●") as %?.
    done.
  Qed.
  Lemma auth_natinf_min_auth_agree γ dq1 n1 dq2 n2 :
    auth_natinf_min_auth γ dq1 n1 -∗
    auth_natinf_min_auth γ dq2 n2 -∗
    ⌜n1 = n2⌝.
  Proof.
    iIntros "H●1 H●2".
    iDestruct (auth_natinf_min_auth_valid_2 with "H●1 H●2") as %?. naive_solver.
  Qed.
  Lemma auth_natinf_min_auth_exclusive γ n1 n2 :
    auth_natinf_min_auth γ (DfracOwn 1) n1 -∗
    auth_natinf_min_auth γ (DfracOwn 1) n2 -∗
    False.
  Proof.
    iIntros "H●1 H●2".
    iDestruct (auth_natinf_min_auth_valid_2 with "H●1 H●2") as %(? & _). done.
  Qed.

  Lemma auth_natinf_min_frag_inf γ :
    ⊢ |==> auth_natinf_min_frag γ natinf_inf.
  Proof.
    iApply own_unit.
  Qed.
  Lemma auth_natinf_min_frag_get γ q n :
    auth_natinf_min_auth γ q n -∗
    auth_natinf_min_frag γ n.
  Proof.
    apply own_mono, auth_natinf_min_included.
  Qed.
  Lemma auth_natinf_min_frag_le {γ n} n' :
    natinf_le n n' →
    auth_natinf_min_frag γ n -∗
    auth_natinf_min_frag γ n'.
  Proof.
    intros. apply own_mono, auth_natinf_min_frag_mono. done.
  Qed.

  Lemma auth_natinf_min_valid γ dq n m :
    auth_natinf_min_auth γ dq n -∗
    auth_natinf_min_frag γ m -∗
    ⌜natinf_le n m⌝.
  Proof.
    iIntros "H●1 H●2".
    iDestruct (own_valid_2 with "H●1 H●2") as %?%auth_natinf_min_both_dfrac_valid.
    naive_solver.
  Qed.

  Lemma auth_natinf_min_update {γ n} n' :
    natinf_le n' n →
    auth_natinf_min_auth γ (DfracOwn 1) n ==∗
    auth_natinf_min_auth γ (DfracOwn 1) n'.
  Proof.
    iIntros "% H●".
    iMod (own_update with "H●"); first apply auth_natinf_min_auth_update; done.
  Qed.
End auth_natinf_min_G.

#[global] Opaque auth_natinf_min_auth.
#[global] Opaque auth_natinf_min_frag.


Require Import Coqlib.
Require Import List. Import ListNotations.
Require Import DRBG_state_handle.
Require Import DRBG_working_state.
Require Import entropy.

Definition DRBG_reseed_function
           (reseed_algorithm: DRBG_working_state -> list Z -> list Z -> DRBG_working_state)
           (min_entropy_length max_entropy_length: Z)
           (max_additional_input_length: Z)
           (entropy_stream: ENTROPY.stream)
           (state_handle: DRBG_state_handle)
           (prediction_resistance_request: bool)
           (additional_input: list Z): ENTROPY.result DRBG_state_handle :=

  let '(working_state, security_strength, prediction_resistance_flag) := state_handle in

  if prediction_resistance_request && (negb prediction_resistance_flag)
  then ENTROPY.error ENTROPY.generic_error entropy_stream
  else
    if Z.gtb (Zlength additional_input) max_additional_input_length
    then ENTROPY.error ENTROPY.generic_error entropy_stream
    else
      (* get_entropy finally called here *)
      match get_entropy security_strength min_entropy_length
                        max_entropy_length prediction_resistance_flag entropy_stream with
      | ENTROPY.error _ s =>
        ENTROPY.error ENTROPY.catastrophic_error s
      | ENTROPY.success entropy_input entropy_stream =>
        (* reseed_algorithm called here -- i'm guessing entropy_input has length > min *)
        let new_working_state := reseed_algorithm working_state
                                                  entropy_input additional_input in
        ENTROPY.success (new_working_state, security_strength,
                         prediction_resistance_flag) entropy_stream
      end.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj8eqsynthconj5 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv0 lv1)).
Admitted.
QuickChick conj8eqsynthconj5.