(*
Pretty print for terms with bruijn indices
(it might be easier to go the other way
and print coq terms with indices)

For a complete pretty print with names
unquote and use Coqs Print Command

It is useful as debugging if a term does not type
 *)

Require Import MetaCoq.Template.All.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction
     PCUICLiftSubst PCUICEquality
     PCUICUnivSubst PCUICTyping PCUICGeneration.

From MetaCoq.PCUIC Require Import TemplateToPCUIC.

Require Import List String.
Require Import Ascii.
Require Import Program Arith Lia PeanoNat.
Import ListNotations MonadNotation Nat.

Definition ascii_to_string (a:ascii) : string := String a (EmptyString).
Definition natToChar (n:nat) : ascii := ascii_of_nat(48+n).

Program Fixpoint natToString (n:nat) {measure n} : string :=
  match leb n 9 with
    true =>
    ascii_to_string (natToChar n)
  | false =>
    append (natToString (Nat.div n 10)) (ascii_to_string(natToChar(Nat.modulo n 10)))
  end.
Next Obligation.
  symmetry in Heq_anonymous.
  apply leb_complete_conv in Heq_anonymous.
  pose proof (divmod_spec n 9 0 9).
  destruct divmod.
  destruct H;trivial.
  cbn. lia.
Qed.

Infix ":s" := String (at level 73).
Infix "+s" := append (at level 72).
Definition linebreak := ascii_to_string(ascii_of_nat 10).

Definition join (xs:list string) : string :=
  fold_left append xs EmptyString.

Require Import String.
Open Scope string_scope.

(* needed for mutual inductive types *)
Definition getInductiveName (ind:kername) (indIndex:nat) :TemplateMonad string :=
  ind <- tmQuoteInductive ind;;
  tmEval lazy match nth_error (trans_minductive_body ind).(ind_bodies) indIndex with
           | None => ""
           | Some b => b.(ind_name)
              end.

Definition getConstructName (ind:kername) (indIndex:nat) (consIndex:nat) :TemplateMonad string :=
  ind <- tmQuoteInductive ind;;
  tmEval lazy match nth_error (trans_minductive_body ind).(ind_bodies) indIndex with
           | None => ""
           | Some b => match nth_error b.(ind_ctors) consIndex with
                        None => ""
                      | Some (s,_,_) => s
                      end
           end.

Definition nameToString (s:name) : string :=
  match s with
    nAnon => "_"
  | nNamed s => s
  end.

Definition concatString (xs:list string) : string :=
  fold_left (fun a b => a +s b) xs "".

Fixpoint bruijn_print_aux (t:term) : TemplateMonad string :=
  match t with
  | tRel n => tmReturn("R" :s (natToString n))
  | tVar ident => tmReturn(ident)
  | tEvar n xs => tmReturn "TODO:EVAR"
  | tSort univ =>
    tmReturn "tSort ?"
  | tProd n t t2 => match n with
                   | nAnon => s1 <- bruijn_print_aux t;;
                             s2 <- bruijn_print_aux t2;;
                             tmReturn("(":s append s1 (append ") -> " s2))
                   | nNamed s => s1 <- bruijn_print_aux t;;
                                s2 <- bruijn_print_aux t2;;
                                tmReturn("∀ (" +s s +s (" : "+s s1) +s "), " +s s2)
                   end
  | tLambda s t t2 => s1 <- bruijn_print_aux t;;
                    s2 <- bruijn_print_aux t2;;
                    tmReturn("λ ("+s match s with
                        nAnon => "_"
                      | nNamed s => s
                      end
                     +s " : "+s s1+s"). "+s s2)
  | tLetIn name t1 t2 t3 =>
    s1 <- bruijn_print_aux t1;;
    s2 <- bruijn_print_aux t2;;
    s3 <- bruijn_print_aux t3;;
    tmReturn("let "+s (nameToString name) +s " := "+s s1 +s " : " +s s2 +s " in "+s linebreak +s s3)
  | tApp t1 t2 =>
    s1 <- bruijn_print_aux t1;;
    s2 <- bruijn_print_aux t2;;
    tmReturn("(" +s s1 +s " " +s s2 +s ")")
  | tConst kn ui => tmReturn(kn)
  | tInd ind ui => getInductiveName ind.(inductive_mind) ind.(inductive_ind)
  | tConstruct ind n ui => getConstructName ind.(inductive_mind) ind.(inductive_ind) n
  | tCase (ind,n) p c brs =>
    sc <- bruijn_print_aux c;;
    sp <- bruijn_print_aux p;;
    sb <- fold_left (fun sa x => match x with (n,t) => st <- bruijn_print_aux t;;sb <- sa;;tmReturn (sb +s " | ("+s(natToString n)+s") " +s st +s linebreak) end) brs (tmReturn "");;
    tmReturn(linebreak +s "match (P:" +s (natToString n) +s ") "+s sc +s " return " +s sp +s " with" +s linebreak +s
            sb +s
             "end")
  | tProj p t => tmReturn "TODO:Proj"
  | tFix mf n =>
    (fix f xs := match xs with
                  nil => tmReturn ""
                | mfb::xs =>
                  sr <- f xs;;
          stype <- bruijn_print_aux (mfb.(dtype));;
          sbody <- bruijn_print_aux (mfb.(dbody));;
          tmReturn (linebreak +s "(fix "+s (nameToString mfb.(dname)) +s " : " +s stype +s " := " +s linebreak +s sbody +s ") "+s sr)
                end
    ) mf
  | _ => tmReturn "TODO"
  end.

Definition bruijn_print (t:term) : TemplateMonad unit :=
  s <- bruijn_print_aux t;;
  val <- tmEval lazy s;;
  tmMsg val.

MetaCoq Quote Definition printTest :=
  (forall (P:nat->Prop) (H0:P 0) (HS: forall n, P n -> P (S n)) (n:nat), P n).

(* MetaCoq Run (bruijn_print (trans printTest)). *)


(*
  Author(s):
    Felix Jahn (1)
    Yannick Forster (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

Require Export Undecidability.Axioms.EA.
Require Export Undecidability.Shared.Pigeonhole.
Require Export Undecidability.Synthetic.FinitenessFacts.
Require Export Undecidability.Synthetic.reductions Undecidability.Synthetic.truthtables.
Require Export Undecidability.Synthetic.DecidabilityFacts Undecidability.Synthetic.EnumerabilityFacts Undecidability.Synthetic.SemiDecidabilityFacts.
Require Export Undecidability.Shared.ListAutomation.
Require Export Undecidability.Synthetic.simple.
Require Export Undecidability.Shared.embed_nat.
Require Export List Arith.

Export EmbedNatNotations.

Local Notation "q << p" := (forall x, q x -> p x) (at level 50).

Lemma proof_computation {X} (p : X -> Prop) f:
 enumerator f p -> (exists y, p y)
  -> exists n y, f n = Some y.
Proof.
  intros E [y [n py] % E].
  eauto.
Qed.

Definition mu_enum_NN_sig {X} (p : X -> Prop) f:
  enumerator f p -> ex p ->
    {n | (exists x, f n = Some x) /\
      (forall n1, (exists x1, (f n1) = Some x1) -> n <= n1) }.
Proof.
  intros E H.
  assert (exists n x, f n = Some x) by exact (proof_computation p f E H).
  eapply mu_nat_dep_least in H0 as (? & ?).
  - exists x. firstorder. eapply H2. lia. eauto.
  - intros n. destruct (f n).
    + left. eauto.
    + right. intros []. inversion H1.
Defined.

Definition mu_enum_NN {X} (p: X -> Prop) f E H : nat
:= proj1_sig (mu_enum_NN_sig p f E H).

Definition mu_enum_NN_spec {X} (p: X -> Prop) f E H
:= proj2_sig (mu_enum_NN_sig p f E H).

Definition mu_enum_sig {X} (p : X -> Prop) f :
forall E H, {x | p x /\ Some x = f (mu_enum_NN p f E H)}.
Proof.
intros E H.
- destruct (f (mu_enum_NN p f E H)) eqn: H2.
  + exists x.
    intuition. apply E. eauto.
  + exfalso. remember (mu_enum_NN_spec p f E H). destruct a as [[x a1] a2].
    unfold mu_enum_NN in H2. rewrite a1 in H2. discriminate.
Defined.

Definition mu_enum {X} (p: X -> Prop) f E H : X
:= proj1_sig (mu_enum_sig p f E H).

Definition mu_enum_spec {X} (p: X -> Prop) f E H
:= proj2_sig (mu_enum_sig p f E H).

Definition wo_enum_sig {X} (p : X -> Prop) f:
  enumerator f p -> (exists x, p x) -> {x | p x}.
Proof.
  intros E H. destruct (mu_enum_sig p f E H).
  exists x. intuition.
Defined.

Lemma constant_mu_enum_NN {X} (p : X -> Prop) f E:
  forall H1 H2, mu_enum_NN p f E H1 = mu_enum_NN p f E H2.
Proof.
  intros H1 H2.
  set (W1:= mu_enum_NN_spec p f E H1).
  set (W2:= mu_enum_NN_spec p f E H2).
  destruct W1 as [p1 L1], W2 as [p2 L2].
  specialize (L2 (mu_enum_NN p f E H1)).
  specialize (L1 (mu_enum_NN p f E H2)).
  apply L2 in p1. apply L1 in p2.
  unfold mu_enum_NN in *. lia.
Qed.

Lemma mu_enum_agree {X} (p : X -> Prop) f E H:
  f (mu_enum_NN p f E H) = Some (mu_enum p f E H).
Proof.
  remember (mu_enum_spec p f E H). cbn in a. destruct a as [a1 a2].
  unfold mu_enum. rewrite a2. trivial.
Qed.

Lemma constant_mu_enum {X} (p : X -> Prop) f E:
  forall H1 H2, mu_enum p f E H1 = mu_enum p f E H2.
Proof.
  intros H1 H2.
  assert
    (Some (mu_enum p f E H1) = Some (mu_enum p f E H2)).
  - rewrite <- (mu_enum_agree p f E H1).
    rewrite <- (mu_enum_agree p f E H2).
    rewrite (constant_mu_enum_NN p f E H1 H2).
    trivial.
  - inversion H. trivial.
Qed.

Section ComplToBound.

  Definition complToBound L b : list nat
    := filter (fun x => Dec (~ In x L)) (seq 0 (S b)).

  Lemma complToBound_Bound L b :
    forall x, In x (complToBound L b) -> x <= b.
  Proof.
    intros x [H % in_seq ?] % in_filter_iff. lia.
  Qed.

  Lemma filter_length {X} f (l : list X) :
    length l = length (filter f l) + length (filter (fun x => (negb (f x))) l).
  Proof.
    induction l; cbn.
    - reflexivity.
    - destruct f; cbn; lia.
  Qed.

  Lemma filter_NoDup {X} f (l : list X) :
    NoDup l -> NoDup (filter f l).
  Proof.
    induction 1; cbn.
    - econstructor.
    - destruct f; eauto. econstructor; auto.
      intros ? % in_filter_iff. firstorder.
  Qed.

  Lemma complToBound_length L b:
    length (complToBound L b) + length L >= S b.
  Proof.
    rewrite <- (seq_length (S b) 0).
    erewrite filter_length with (l := seq 0 (S b)).
    unfold complToBound.
    eapply plus_le_compat_l.
    generalize (seq_NoDup (S b) 0).
    generalize (seq 0 (S b)). clear.
    intros. erewrite filter_ext with (g := fun x => Dec (In x L)).
    2:{ intros a. destruct Dec; cbn; destruct Dec; firstorder congruence. }
    eapply NoDup_incl_length. now eapply filter_NoDup.
    clear. induction l; cbn.
    - firstorder.
    - destruct Dec; cbn. 2: eauto.
      intros ? [-> | ]; eauto.
  Qed.

  Lemma complToBound_NoDup L b:
    NoDup (complToBound L b).
  Proof.
    eapply filter_NoDup, seq_NoDup.
  Qed.

  Lemma firstn_In {X} (l : list X) n x : In x (firstn n l) -> In x l.
  Proof.
    induction n in x, l |- *; destruct l; cbn; firstorder.
  Qed.

  Lemma firstn_NoDup {X} (l : list X) n : NoDup l -> NoDup (firstn n l).
  Proof.
    induction 1 in n |- *; destruct n; cbn; try now econstructor.
    econstructor; eauto.
    now intros ? % firstn_In.
  Qed.

End ComplToBound.

Section fix_ct.

  (* Assuming enumerator of semidecidable predicates W and its semidecidability *)

  (* Variable W : nat -> nat -> Prop.  *)
  Lemma es : forall p : nat -> Prop, semi_decidable p <-> exists c, forall x, W c x <-> p x.
  Proof.
    intros p. rewrite <- enum_iff, W_spec. firstorder.
  Qed.

  Variable W_SDec: nat * nat -> nat -> bool.
  Variable W_semidecider: semi_decider W_SDec (fun '(c,x) => W c x).

  Variable c_top : nat.
  Variable c_top_spec: forall x, W c_top x.

  (* Auxiliary Predicate C *)

  Definition C : (nat*nat) -> Prop
    := fun '(c,x) => W c x /\ x > 2*c.

  Lemma C_nonempty:
    C (c_top, 1 + 2 * c_top).
  Proof.
    split.
    - apply c_top_spec.
    - lia.
  Qed.

  Definition C_SDec: (nat*nat) -> nat -> bool
    := fun '(c,x) n => andb (W_SDec (c,x) n) (2*c <? x).

  Lemma C_semidecider:
    semi_decider C_SDec C.
  Proof.
    intros [c x].
    split.
    - intros [Wcx E].
      apply (W_semidecider(c,x)) in Wcx as [n Wcx].
      exists n.
      apply leb_correct_conv in E. unfold C_SDec. rewrite Nat.ltb_antisym, Wcx, E. firstorder.
    - intros [n Ccx].
      apply RelationClasses.eq_Symmetric, Bool.andb_true_eq in Ccx as [H1 H2].
      split.
      + apply (W_semidecider (c,x)). exists n. firstorder.
      + apply leb_complete_conv.
        rewrite Nat.leb_antisym.
        rewrite <- H2. firstorder.
  Qed.

  Definition iso_three_nat_func : nat -> (nat * nat) * nat
    := fun! ⟨n1, n2⟩ => (unembed n1, n2).

  Definition surjective {X} {Y} (f : X -> Y) := forall y, exists x, f x = y.

  Lemma iso_three_nat_func_spec:
    surjective iso_three_nat_func.
  Proof.
    intros [[n1 n2] n3].
    exists ⟨ ⟨n1,n2⟩, n3⟩.
    unfold iso_three_nat_func.
    now rewrite !embedP.
  Qed.
(*
  Definition C_Enum: nat -> nat * nat
    := enum_To_StrongenumF (semidec_To_enumF C_SDec iso_three_nat_func) (c_top, 1 + 2 * c_top).
 *)

  Lemma C_strong_enumerator:
    ∑ C_Enum, strong_enumerator C_Enum C.
  Proof.
    eexists.
    eapply enumerator_strong_enumerator with (x0 := (c_top, 1 + 2 * c_top)).
    - exact C_nonempty.
    - eapply semi_decider_enumerator. exact _. exact C_semidecider.
  Qed.

  Definition C_Enum := proj1_sig C_strong_enumerator.
  Definition C_enumerator : strong_enumerator C_Enum C := proj2_sig C_strong_enumerator.

  Definition DomC : nat -> Prop
    := fun c => exists x, C (c,x).

  Lemma DomC_nonempty: DomC c_top.
  Proof.
    exists (1+2*c_top).
    exact C_nonempty.
  Qed.

  Definition DomC_Enum : nat -> nat
    := fun n => fst (C_Enum n).

  Lemma DomC_enumerator:
    strong_enumerator DomC_Enum DomC.
  Proof.
    intros c; split; unfold DomC_Enum.
    - intros [x H]. apply C_enumerator in H as [n H].
      exists n. rewrite H. trivial.
    - intros [n H]. exists (snd (C_Enum n)). rewrite <- H.
      apply C_enumerator. exists n. apply surjective_pairing.
  Qed.

  Definition RangeC c : nat -> Prop
    := fun x => C(c,x).

  Definition RangeC_Enum c : nat -> option nat
    := fun n => match C_Enum n with (c1,x) => if c =? c1 then Some x else None end.

  Lemma RangeC_Enum_spec c:
    enumerator (RangeC_Enum c) (RangeC c).
  Proof.
    intros x. split.
    - intros Ccx. unfold RangeC in Ccx. apply C_enumerator in Ccx as [n Ccx].
      exists n. unfold RangeC_Enum. rewrite Ccx.
      now rewrite Nat.eqb_refl.
    - intros [n H]. apply C_enumerator.
      exists n. unfold RangeC_Enum in H.
      destruct (C_Enum n) as [c1 x1].
      destruct (Nat.eqb_spec c c1).
      + rewrite e. now inversion H.
      + discriminate.
  Qed.

  (* Definition of psi via recursive mu-operator for enumerable predicates *)

  Definition psi: forall c, DomC c -> nat .
  Proof.
    intros c H.
    apply (mu_enum (fun x => C (c,x)) (RangeC_Enum c)).
    - apply RangeC_Enum_spec.
    - exact H.
  Defined.

  Lemma psi_spec c H:
     C (c,psi c H).
  Proof.
    eapply (mu_enum_spec (fun x => C (c,x))).
  Qed.

  Lemma psi_spec1 c H:
    psi c H > 2*c.
  Proof.
    exact (proj2 (psi_spec c H)).
  Qed.

  Lemma psi_PI c H1 H2:
    psi c H1 = psi c H2.
  Proof.
    apply (constant_mu_enum (fun x => C (c, x)) (RangeC_Enum c)
    (RangeC_Enum_spec c) H1 H2).
  Qed.

  (* Definition of the simple predicate S as the range of psi *)

  Definition S : nat -> Prop
    := fun x => exists c H, psi c H = x.

  (* S is semidecidable *)

  Definition DomC_proof n: DomC (DomC_Enum n).
  Proof.
    apply DomC_enumerator.
    eauto.
  Qed.

  Definition S_Enum : nat -> nat
    := fun n => let c := DomC_Enum n in
                  let H := DomC_proof n in
                     psi c H.

  Lemma S_enumerator:
    strong_enumerator S_Enum S.
  Proof.
    intros x.
    split.
    - intros [c [H E]].
      assert (exists n, DomC_Enum n = c) as [n H1].
      apply DomC_enumerator. exact H.
      exists n. unfold S_Enum.
      revert E. revert H. rewrite <- H1. intros H E.
      rewrite <- E.
      exact (psi_PI (DomC_Enum n) (DomC_proof n) H).
    - intros [n H].
      unfold S_Enum in H.
      exists (DomC_Enum n).
      exists (DomC_proof n).
      exact H.
  Qed.

  Corollary S_SemiDec:
    semi_decidable S.
  Proof.
    eapply enumerable_semi_decidable. eapply discrete_iff. econstructor. exact _.
    enough (strongly_enumerable S) as ? %  enumerable_strongly_enumerable_iff by tauto.
    exists S_Enum. exact S_enumerator.
  Qed.

  (* Complement of S contains no semidecidable, infinite subset *)

  Lemma S_No_S_Inf_Subset:
    forall (q: nat -> Prop), ~ exhaustible q -> semi_decidable q -> ~ (q << (compl S)).
  Proof.
    intros q Inf [c Se] % es H.
    apply Inf.
    exists (seq 0 (1+2*c)).
    intros x qx.
    assert (x <= 2*c).
    - destruct (Nat.le_gt_cases x (2*c)).
      + exact H0.
      + exfalso.
        assert (exists x, C (c,x)).
        * exists x. split. apply Se, qx. exact H0.
        * assert (exists x0, q x0 /\ S x0) as [x0 [qx0 Sx0]].
          { exists (psi c H1). split.
            - apply Se. apply psi_spec.
            - exists c. exists H1. trivial.
          }
          apply (H x0 qx0), Sx0.
    - apply in_seq. lia.
  Qed.

  (* Co-Infinity Proof of S *)

  Lemma DomC_pullback n L:
    (forall x, In x L -> S x /\ x <= 2 * n) -> forall x, In x L
      -> exists c H, psi c H = x /\ c < n.
  Proof.
    intros H1 x [[c [H Sx]] E] % H1.
    exists c. exists H. intuition. rewrite <- Sx in E.
    assert (psi c H > 2 * c) by apply psi_spec1.
    lia.
  Qed.

  Lemma DomC_pullback_list n L:
    NoDup L -> (forall x, In x L -> S x /\ x <= 2 * n) ->
      exists (LC: list nat), NoDup LC /\ length LC = length L /\
        forall c, In c LC -> exists H, In (psi c H) L /\ c < n.
  Proof.
    intros ND Sub.
    induction L.
    - exists nil.
      intuition.
    - remember (DomC_pullback n (a::L) Sub a).
      assert (In a (a::L)) as H0 by intuition .
      apply e in H0 as [c0 [H0 [E1 E2]]].
      assert (NoDup L) by (inversion ND; intuition).
      apply IHL in H as [LC H].
      exists (c0::LC).
      intuition.
      + constructor. intros In. apply H3 in In as [H0' E].
        assert (a = psi c0 H0') by (rewrite <- E1; exact (psi_PI c0 H0 H0')).
        rewrite <- H2 in E. inversion ND. intuition. exact H1.
      + cbn. rewrite H. trivial.
      + destruct H2.
        * rewrite <- H2.  exists H0. rewrite E1. intuition.
        * apply H3 in H2 as [H4 E]. exists H4. intuition.
      + intros y In1. assert (In y (a::L)) by intuition.
        apply Sub in H1. exact H1.
  Qed.

  Lemma S_List_Bound n L:
    NoDup L -> (forall x, In x L -> S x /\ x <= 2 * n)
      -> length L <= n.
  Proof.
    intros ND [LC H] % DomC_pullback_list; intuition.
    rewrite <- H.
    assert (incl LC (seq 0 n)).
    - intros c [_ [_ H3]] % H2. apply in_seq. lia.
    - apply pigeonhole_length in H1.
      + now rewrite seq_length in H1.
      + intros. decide (x1 = x2); tauto.
      + exact H0.
  Qed.

  (* Listing of predicates up to a bound b *)

  Definition PredListTo p : list nat -> nat -> Prop
    := fun L b => forall x, In x L <-> p x /\ x <= b.

  Lemma PredListTo_spec {p L b}:
    PredListTo p L b -> forall x, In x L -> p x /\ x <= b.
  Proof.
    intros H x I % H.
    apply I.
  Qed.

  Lemma PredListTo_Bound {p L b}:
    PredListTo p L b -> forall x, In x L -> x <= b.
  Proof.
    intros H x I % H.
    apply I.
  Qed.

  Lemma NoDupBoundH {L} b:
    NoDup L -> (forall x, In x L -> x <= b) -> forall x, x > b -> NoDup (x::L).
  Proof.
    intros ND H x E.
    constructor.
    - intros H1 % H. lia.
    - exact ND.
  Qed.

  Lemma PredNoDupListTo_NNExist p:
    forall b, ~~ exists L, PredListTo p L b /\ NoDup L.
  Proof.
    induction b; intros H.
    - ccase (p 0) as [H0 | H0]; apply H.
      + exists [0]. split; try split.
        * intros [E | E]; (try contradiction E).
          rewrite <- E. intuition.
        * intros E. assert (x = 0) by lia.
          rewrite H1. intuition.
        * constructor; intuition; constructor.
      + exists nil. split; try split.
        * contradiction.
        * intros E. assert (x = 0) by lia.
          rewrite H1 in E. firstorder.
        * constructor.
    - apply IHb. intros [L H1].
      ccase (p (1 + b)) as [H0 | H0]; apply H.
      + exists ((1+ b) :: L). split; try split.
        * intros [E | E]; try (rewrite <- E; intuition).
          apply H1 in E. intuition.
        * intros [E1 E2]. assert (x <= b \/ x = 1 + b) as [E | E] by lia.
          ** right. apply H1. intuition.
          ** left. lia.
        * apply (NoDupBoundH b).
          ** apply H1.
          ** intros x H3 % H1. lia.
          ** lia.
      + exists L. split; try split.
        * intros E % H1. intuition.
        * intros [E1 E2]. assert (x <= b \/ x = 1 + b) as [E | E] by lia.
          ** apply H1. intuition.
          ** rewrite E in E1. firstorder.
        * apply H1.
  Qed.

  Lemma complToBound_compl p L b:
    PredListTo p L b -> PredListTo (compl p) (complToBound L b) b.
  Proof.
    intros H x. split.
    - intros [H1 H1'] % in_filter_iff.
      destruct Dec; cbn in H1'; try congruence.
      enough (x <= b).
      + intuition. intros npx. firstorder.
      + apply in_seq in H1. lia.
    - intros [H1 H2]. eapply in_filter_iff. split.
      + apply in_seq; lia.
      + destruct Dec; cbn; try tauto. exfalso. firstorder.
  Qed.

  (* Length of listings of S up to 2*n is bounded by n *)

  Lemma S_Listing:
    forall n, ~~ exists L, NoDup L /\ length L <= n /\ PredListTo S L (2*n).
  Proof.
    intros n H. apply (PredNoDupListTo_NNExist S (2*n)).
    intros [L H1]. apply H. exists L; intuition.
    apply S_List_Bound.
    - exact H2.
    - apply H0.
  Qed.

  (* Weak Existence Infinite Criterion *)

  Lemma ComplS_Listing:
  forall (n: nat) ,~~ exists L, length L >= n /\ NoDup L
                                /\ forall x, In x L -> ~ S x.
  Proof.
    intros n H.
    apply (S_Listing n). intros [L H1].
    apply H. exists (complToBound L (2*n)). repeat split.
    - remember (complToBound_length L (2*n)). lia.
    - apply complToBound_NoDup.
    - intros x I % (complToBound_compl S); intuition.
  Qed.

  Lemma S_coInfinite:
    ~ exhaustible (compl S).
  Proof.
    eapply weakly_unbounded_non_finite.
    intros n H. eapply ComplS_Listing with (n := n).
    intros (l & ? & ? & H2).
    eapply H.
    exists (firstn n l).
    repeat split.
    - rewrite firstn_length. lia.
    - now eapply firstn_NoDup.
    - intros ? ? % firstn_In. now eapply H2.
  Qed.

  (* S is a simple predicate *)

  Corollary S_simple:
    simple S.
  Proof.
    split.
    - eapply semi_decidable_enumerable; eauto. exact S_SemiDec.
    - split.
      + exact S_coInfinite.
      + intros (? & ? % enumerable_semi_decidable & ? & ?); eauto.
        eapply S_No_S_Inf_Subset; eauto.
  Qed.

End fix_ct.

Section S_Star.
  Import  Coq.Init.Nat.

  Variable W_SDec: nat * nat -> nat -> bool.
  Variable W_semidecider: semi_decider W_SDec (fun '(c,x) => W c x).

  Variable c_top : nat.
  Variable c_top_spec: forall x, W c_top x.

  Definition S' : nat -> Prop
    := S W_SDec W_semidecider c_top c_top_spec.

  (* Auxiliary List *)

  Definition S_Pow n : list nat
    := seq (2^n - 1) (2^n).

  Lemma pow_pos n:
    2^n > n.
  Proof.
    induction n; cbn; lia.
  Qed.

  Lemma pow_sum n:
    2 ^ n - 1 + 2 ^ n = 2 ^ (1 + n) - 1.
  Proof.
    induction n; cbn in *; lia.
  Qed.

  Lemma S_Pow_injective x n1 n2:
    In x (S_Pow n1) /\ In x (S_Pow n2) -> n1 = n2.
  Proof.
    intros [H1 H2].
    apply in_seq in H1. apply in_seq in H2.
    assert (n1 = n2 \/ 1 + n1 <= n2 \/ 1 + n2 <= n1) by lia.
    destruct H as [H | [H | H]].
    - exact H.
    - assert (2 ^ (1 + n1) - 1 <= x).
      + enough (2 ^ (1 + n1) <= 2 ^ n2) by lia.
        apply Nat.pow_le_mono_r; lia.
      + assert (2 ^ n1 - 1 + 2 ^ n1 = 2 ^ (1 + n1) - 1) by apply pow_sum.
        lia.
    - assert (2 ^ (1 + n2) - 1 <= x).
      + enough (2 ^ (1 + n2) <= 2 ^ n1) by lia.
        apply Nat.pow_le_mono_r; lia.
      + assert (2 ^ n2 - 1 + 2 ^ n2 = 2 ^ (1 + n2) - 1) by apply pow_sum.
        lia.
  Qed.

  (* Definition S* *)

  Definition S_Star : nat -> Prop
    := fun x => S' x
                  \/ exists n, (fun '(c,x0) => W c x0) (unembed n)
                                /\ In x (S_Pow n).

  Definition S_Star_compl : nat -> Prop
    := fun x => (compl S') x /\ ~ exists n, ((fun '(c,x0) => W c x0) (unembed n)
                                              /\ In x (S_Pow n )).

  Lemma S_Star_comp_agree:
    forall x, (compl S_Star) x <-> S_Star_compl x.
  Proof.
    intros x. unfold S_Star_compl,  S_Star, compl, not. now rewrite Decidable.not_or_iff.
  Qed.

  (* S* is semidecidable *)

  Lemma S_Star_semidec:
    semi_decidable S_Star.
  Proof.
    apply semi_decidable_or.
    - apply S_SemiDec.
    - eapply semi_decidable_ex.
      eapply semi_decidable_and.
      + exists (fun pa n => W_SDec (unembed (fst pa)) n).
        intros [n0 x0]; specialize (W_semidecider (unembed n0)); firstorder.
      + apply decidable_semi_decidable. eapply dec_decidable.
        intros pa. exact _.
  Qed.

  (* Complement of S* contains no semidecidable, infinite subset *)

  Lemma S_Star_No_S_Inf_Subset:
    forall (q: nat -> Prop), ~ exhaustible q -> semi_decidable q -> ~ (q << (compl (S_Star))).
  Proof.
    intros q H1 H2 H3.
    eapply (S_No_S_Inf_Subset).
    - exact H1.
    - exact H2.
    - intros x qx % H3.
      intros nSx. apply qx. left. exact nSx.
  Qed.

  (* Co-Infinite Proof of S* *)

  Lemma W_empty: exists c_bot, forall x, ~ W c_bot x.
  Proof.
    destruct (es (fun _ => False)) as [[c_bot]_].
    - exists (fun _ _ => false). red. firstorder congruence. congruence.
    - exists c_bot. firstorder.
  Qed.

  Lemma W_CoInfinite:
    ~ exhaustible (compl (fun '(c,x) => W c x)).
  Proof.
    destruct W_empty as [c_bot H].
    eapply unbounded_non_finite.
    intros n.
    exists (map (fun x => (c_bot, x)) (seq 0 n)).
    repeat split.
    - now rewrite map_length, seq_length.
    - eapply NoDup_map. now intros ? ? [= ->]. eapply seq_NoDup.
    - intros [? ?] (? & [= <- <-] & ? % in_seq) % in_map_iff. eapply H.
  Qed.

  Lemma WNat_CoInfinite:
    ~ exhaustible (compl (fun n => (fun '(c,x) => W c x) (unembed n))).
  Proof.
    destruct W_empty as [c_bot H].
    eapply unbounded_non_finite.
    intros n.
    exists (map (fun x => ⟨c_bot, x⟩) (seq 0 n)).
    repeat split.
    - now rewrite map_length, seq_length.
    - eapply NoDup_map. 2: eapply seq_NoDup. intros ? ? ? % (f_equal unembed).
      rewrite !embedP in H1. congruence.
    - intros x (? & <- & ? % in_seq) % in_map_iff. red. now rewrite embedP.
  Qed.

  Lemma S_Pow_NotInS n:
    ~ Forall S' (S_Pow n).
  Proof.
    intros H.
    assert (length (S_Pow n) <= 2^n - 1).
    - eapply S_List_Bound.
      + apply seq_NoDup.
      + intros x. split.
        * revert H0. apply Forall_forall. exact H.
        * apply in_seq in H0. lia.
    - unfold S_Pow in H0. rewrite seq_length in H0. clear H.
      induction n; cbn in H0; lia.
  Qed.

  Lemma Not_Forall_2_WeakEx {X} (p: X -> Prop) L:
    (~ Forall p L) -> ~~ exists x, In x L /\ ~ p x.
  Proof.
    intros H1 H2.
    induction L.
    - now apply H1.
    - ccase (p a) as [H | H].
      + apply IHL.
        * contradict H1. now constructor.
        * contradict H2. destruct H2. exists x; firstorder.
      + apply H2. exists a. firstorder.
  Qed.

  Lemma S_Pow_WeakEx_NotS n:
    ~~ exists x, In x (S_Pow n) /\ (compl S') x.
  Proof.
    apply Not_Forall_2_WeakEx, S_Pow_NotInS.
  Qed.

  Lemma S_Star_coInfinite:
    ~ exhaustible (compl S_Star).
  Proof.
    eapply non_finite_nat.
    intros n0.
    assert (~ ~ (exists n : nat, n >= n0 + 1/\ compl (fun n : nat => let '(c, x) := unembed n in W c x) n)).
    - eapply non_finite_nat. apply WNat_CoInfinite.
    - contradict H. intros [n H2].
      apply (S_Pow_WeakEx_NotS n).
      intros [x [H3 H4]]. apply H.
      exists x; split.
      + apply in_seq in H3. enough (2 ^ n > n) by lia. apply pow_pos.
      + apply S_Star_comp_agree.
        unfold S_Star_compl. split.
        * exact H4.
        * intros [n1 [H5 H6]].
          assert (n = n1) by now apply (S_Pow_injective x).
          apply H2. now rewrite H0.
  Qed.

  (* S* is simple *)

  Corollary S_Star_simple:
    simple S_Star.
  Proof.
    split.
    - eapply semi_decidable_enumerable; eauto. exact S_Star_semidec.
    - split.
      + exact S_Star_coInfinite.
      + intros (? & ? % enumerable_semi_decidable & ? & ?); eauto.
        eapply S_Star_No_S_Inf_Subset; eauto.
  Qed.

  (* W truth-table reduces to S* *)

  Lemma S_Star_split L:
    Forall S_Star L
      -> Forall S' L \/ exists n, (fun '(c,x) => W c x) (unembed n) /\ exists x, In x L /\ In x (S_Pow n).
  Proof.
    induction 1.
    - left; constructor.
    - destruct IHForall.
      + destruct H.
        * left; now constructor.
        * right. destruct H.
          exists x0. intuition.
          exists x; intuition.
      + right. destruct H1.
        exists x0. intuition. destruct H3.
        exists x1; intuition.
  Qed.

  Lemma Forall2_equiv {X} {Y} {p : X -> Prop} {q : Y -> Prop} l1 l2:
    Forall2 (fun x y => q y <-> p x) l1 l2 ->
    Forall p l1 <-> Forall q l2.
  Proof.
    induction 1.
    - split; now econstructor.
    - split; intros H1; inv H1; econstructor; firstorder.
  Qed.

  Lemma Forall_map {X} {p : X -> Prop} l :
    Forall (fun P => P) (map p l) <-> Forall p l.
  Proof.
    induction l; cbn.
    - split; econstructor.
    - split; intros H1; inv H1; econstructor; firstorder.
  Qed.

  Lemma tt_red_W_S_Star:
    (fun '(c,x) => W c x) ⪯ₜₜ S_Star.
  Proof.
    unshelve eexists (fun '(c, x) => existT (let n := embed (c,x) in S_Pow n) (mk_tt (fun L => if (Forall_dec (fun b => b = true) _ L) then true else false))).
    1:{ intros b. cbn. decide (b = true); tauto. }
    1:{ refine (length (S_Pow ⟨c, x⟩)). }
    intros [c x] L. cbn.
    unfold reflects. intros H1.
    rewrite eval_tt_mk_tt'.
    2:{ eapply list.Forall2_length in H1.
        now rewrite H1, map_length. }
    unshelve edestruct (Forall_dec (fun b => b = true)) as [H0 | H0].
    - intuition.
      assert (Forall S_Star (S_Pow ⟨c,x⟩)). {
       eapply Forall2_equiv in H1.
       rewrite Forall_map in H1. now eapply H1. }
      clear H0. rename H2 into H0.
      apply S_Star_split in H0 as [H0 | H0].
      + apply S_Pow_NotInS in H0. contradict H0.
      + destruct H0 as [n [H0 [x0 H3]]].
        apply S_Pow_injective in H3.
        subst. now rewrite embedP in H0.
    - split; intros; try congruence.
      contradict H0.
      assert (Forall S_Star (S_Pow (embed (c,x)))).
      * apply Forall_forall.
        intros x0 H3. right.
        exists (embed (c, x)). rewrite embedP. intuition.
      * eapply Forall2_equiv. exact H1.
        now eapply Forall_map.
  Qed.

End S_Star.


From exercises Require Export language.

(** * Polymorphic, existential and recursive types in HeapLang *)
(** In order to define a type system for HeapLang (in the file [typed.v]), we
need to extend HeapLang with constructs for polymorphic functions (i.e.,
type-level lambdas and application), existential types (i.e., pack and
unpack), and iso-recursive types (i.e., fold and unfold). Since HeapLang is an
untyped language, it does natively have these constructs. *)

(** We retrofit type-level lambdas and application on HeapLang by defining them
as mere thunks, and ordinary application, respectively. This ensures that
polymorphic programs satisfy a **value restriction**, which is needed to obtain
type safety in the presence of mutable state. *)
Notation "Λ: e" := (λ: <>, e)%E (at level 200, only parsing) : expr_scope.
Notation "Λ: e" := (λ: <>, e)%V (at level 200, only parsing) : val_scope.
Notation "e '<_>'" := (App e%E #()) (at level 10, only parsing) : expr_scope.

(** We also use ordinary lambdas and application to retrofit [pack] and
[unpack] on HeapLang. This time we first define some helper functions so that
we can have a nice notation for these constructs. *)
Definition exist_pack : val := λ: "x", "x".
Definition exist_unpack : val := λ: "x" "y", "x" "y".

Notation "'pack:' e" := (exist_pack e%E)
  (at level 200, e at level 200,
   format "'[' 'pack:'  e ']'") : expr_scope.

Notation "'unpack:' x := e1 'in' e2" := (exist_unpack (Lam x%binder e2%E) e1%E)
  (at level 200, x at level 1, e1, e2 at level 200,
   format "'[' 'unpack:'  x  :=  '[' e1 ']'  'in'  '/' e2 ']'") : expr_scope.
Notation "'unpack:' x := e1 'in' e2" := (exist_unpack (LamV x%binder e2%E) e1%E)
  (at level 200, x at level 1, e1, e2 at level 200,
   format "'[' 'unpack:'  x  :=  '[' e1 ']'  'in'  '/' e2 ']'") : val_scope.

(** And we apply the trick one more to retrofit [fold] and [unfold] on
HeapLang. *)
Definition rec_fold : val := λ: "x", "x".
Definition rec_unfold : val := λ: "x", "x".

Notation "'fold:' e" := (rec_fold e%E)
  (at level 200, e at level 200,
   format "'[' 'fold:'  e ']'") : expr_scope.

Notation "'unfold:' e" := (rec_unfold e%E)
  (at level 200, e at level 200,
   format "'[' 'unfold:'  e ']'") : expr_scope.

(** ** Exercise (swap_poly, easy) *)
(** Below we define a polymorphic version of the [swap] function. *)
Definition swap_poly : val := Λ: λ: "l1" "l2",
  let: "x" := !"l1" in
  "l1" <- !"l2";;
  "l2" <- "x".

(** Prove the following specification. *)
Lemma wp_swap_poly `{!heapG Σ} l1 l2 v1 v2 :
  l1 ↦ v1 -∗
  l2 ↦ v2 -∗
  WP swap_poly <_> #l1 #l2 {{ v, ⌜ v = #() ⌝ ∗ l1 ↦ v2 ∗ l2 ↦ v1 }}.
Proof.
  (* exercise *)
Admitted.


Require Import AutoSep.

(** * Like TrivialMem, but tests use of equality prover in symbolic evaluation *)

Definition readS : spec := SPEC("x", "y") reserving 1
  Al v,
  PRE[V] V "x" =*> v
  POST[R] [| R = v |] * V "x" =*> v.

Definition read := bmodule "read" {{
  bfunction "read"("x", "y", "z") [readS]
    If ("x" = "y") {
      "z" <-* "y"
    } else {
      "z" <-* "x"
    };;
    Return "z"
  end
}}.

Theorem readOk : moduleOk read.
(*TIME  Clear Timing Profile. *)
  vcgen; abstract sep_auto.
(*TIME  Print Timing Profile. *)
Qed.


Require Export Coq.Program.Tactics Coq.Classes.SetoidTactics Coq.Classes.CMorphisms .

Set Universe Polymorphism.

Delimit Scope category_theory_scope with category_theory.
Open Scope category_theory_scope.

Infix "∧" := prod (at level 80, right associativity) : category_theory_scope.

Class Setoid A := {
  equiv : crelation A;
  setoid_equiv :> Equivalence equiv
}.

Notation "f ≈ g" := (equiv f g) (at level 79) : category_theory_scope.

Open Scope list_scope.

Generalizable All Variables.

Fixpoint list_equiv `{Setoid A} (xs ys : list A) : Type :=
  match xs, ys with
  | nil, nil => True
  | x :: xs, y :: ys => x ≈ y ∧ list_equiv xs ys
  | _, _ => False
  end.

Axiom proof_admitted : False.
Tactic Notation "admit" := abstract case proof_admitted.

Program Instance list_equivalence `{Setoid A} : Equivalence list_equiv.
Next Obligation.
  repeat intro.
  induction x; simpl; split; auto.
  reflexivity.
Qed.
Next Obligation.
  repeat intro.
  generalize dependent y.
  induction x, y; simpl; intros; auto.
  destruct X; split.
    now symmetry.
  intuition.
Qed.
Next Obligation.
admit.
Defined.


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 D1 D2 IAB IAC IBD E F : Universe, ((wd_ IAB IAC /\ (wd_ IAB IBD /\ (wd_ IAB F /\ (wd_ IBD F /\ (wd_ IAB E /\ (wd_ IAC E /\ (wd_ B1 B2 /\ (wd_ D1 D2 /\ (wd_ A1 A2 /\ (wd_ C1 C2 /\ (wd_ IAC IBD /\ (col_ A1 A2 IAB /\ (col_ B1 B2 IAB /\ (col_ A1 A2 IAC /\ (col_ C1 C2 IAC /\ (col_ B1 B2 IBD /\ (col_ D1 D2 IBD /\ (col_ IBD IAB F /\ col_ IAC IAB E)))))))))))))))))) -> col_ B1 B2 F)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Import CpdtTactics.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.
Require Import wyv_common.
Set Implicit Arguments.

(*
Here we model the case where an unseparated type on the left hand side, and
a pure material is on the the right hand side.

Here we know that following the syntax and the subtype semantics of Decidable
Wyvern, every subsequent subtype check will feature a Material on the right
hand side. We also know that if the left hand side is a shape, the only way
to proceed
would require a shape refinement on the right hand side. As we have already
noted, this is not possible. Thus we can easily demonstrate termination as
without shapes, cycles are not possible on the right hand side, and the
algorithm is thus bound by the finiteness of specified types.
 *)

Inductive tytree : Type :=
| t_top : tytree
| t_bot : tytree

| t_sel_upp : var -> label -> tytree -> tytree
| t_sel_low : var -> label -> tytree -> tytree
| t_sel_equ : var -> label -> tytree -> tytree
| t_sel_nom : var -> label -> tytree -> tytree
| t_sel_bnd : var -> label -> tytree

| t_rfn_top : tytree -> tytree                         (*first tytree is actually a list of trees constructed by t_nil and t_con*)
| t_rfn_sel : var -> label -> tytree -> tytree -> tytree  (*first tytree is actually a list of trees constructed by t_nil and t_con*)
| t_sha_top : var -> label -> decls -> tytree
| t_sha_sel : var -> label -> decls -> tytree -> tytree
| t_all : tytree -> tytree -> tytree

| t_upp : label -> tytree -> tytree
| t_low : label -> tytree -> tytree
| t_equ : label -> tytree -> tytree
| t_nom : label -> tytree -> tytree

| t_nil : tytree
| t_con : tytree -> tytree -> tytree.

Inductive Tree (A: Set): Set :=
| Leaf: A -> Tree A
| Node: list (Tree A) -> Tree A.

Fixpoint bind' {A B:Set} (k:A -> Tree B) (m:Tree A) : Tree B :=
  match m with
  | Leaf a => k a
  | Node ts => Node (map (bind' k) ts)
  end.

Definition bind (A B:Set) m (k:A -> Tree B) := bind' k m.

Fixpoint shape_depth (T : tytree) : nat :=
  match T with
  | t_sel_upp x L T' => 1 + shape_depth T'
  | t_sel_low x L T' => 1 + shape_depth T'
  | t_sel_equ x L T' => 1 + shape_depth T'
  | t_sel_nom x L T' => 1 + shape_depth T'
  | t_rfn_top Ts => 1 + shape_depth Ts
  | t_rfn_sel _ _ Ts T' => 1 + shape_depth Ts + shape_depth T'
  | t_sha_sel _ _ _ T' => 1 + shape_depth T'
  | t_all T1 T2 => 1 + shape_depth T1 + shape_depth T2

  | t_upp _ T' => 1 + shape_depth T'
  | t_low _ T' => 1 + shape_depth T'
  | t_equ _ T' => 1 + shape_depth T'
  | t_nom _ T' => 1 + shape_depth T'

  | t_con T Ts => 1 + shape_depth T + shape_depth Ts

  | _ => 1
  end.

Definition shape_depth_p (P : tytree * tytree) := let (T1, T2) := P in shape_depth T1 + shape_depth T2.

Function zip (Ts1 Ts2 : list tytree) : option (list (tytree * tytree)) :=
  match Ts1, Ts2 with
  | _, nil => Some nil
  | T1::Ts1', T2::Ts2' => match zip Ts1' Ts2' with
                         | None => None
                         | Some Ps => Some ((T1, T2)::Ps)
                         end
  | nil, _::_ => None
  end.

Check fold_right andb true (map negb nil).
Compute fold_right andb true (map negb nil).

Fixpoint fold_mapb {A B : Type} (f : A * B -> bool) (Ps : list (A * B)) : bool :=
  match Ps with
  | nil => true
  | P::Ps' => andb (f P) (fold_mapb f Ps')
  end.

Definition zip_mapb {A B : Type} (f : A * B -> bool) (o : option (list (A * B))) : bool :=
  match o with
  | None => false
  | Some Ps => fold_mapb f Ps
  end.

(*Definition map {A B} (xs : list A) (f : forall (x:A), In x xs -> B) : list B.
Proof.
  induction xs.
  exact nil.
  refine (f a _ :: IHxs _).
    - left. reflexivity.
    - intros. eapply f. right. eassumption.
Defined.*)

(*Fixpoint map {A B} (xs : list A) : forall (f : forall (x:A), In x xs -> B), list B :=
  match xs with
   | nil => fun _ => nil
   | x :: xs => fun f => f x (or_introl eq_refl) :: map xs (fun y h => f y (or_intror h))
  end.*)

(*forall P0 : tytree * tytree, shape_depth P0 < shape_depth P -> bool*)

Check in_cons.

Definition map_tree (P1 :  tytree * tytree)
           (f : forall P2 : tytree * tytree, shape_depth_p P2 < shape_depth_p P1 -> bool)
           (Ps : list (tytree * tytree))
           (lt : forall P2 : tytree * tytree, In P2 Ps -> shape_depth_p P2 < shape_depth_p P1) : list bool.
Proof.
  induction Ps.
  exact nil.
  assert (HIna : In a (a :: Ps));
    [apply in_eq|apply lt in HIna].
  refine (f a HIna :: IHPs _).
  intros. apply lt, in_cons; auto.
Defined.

(*Fixpoint map  (P1 :  tytree * tytree)
         (f : forall P2 : tytree * tytree, shape_depth P2 < shape_depth P1 -> bool)
         (Ps : list (tytree * tytree))
         (lt : forall P2 : tytree * tytree, In P2 Ps -> shape_depth P2 < shape_depth P1) : list bool :=
  match Ps with
  | nil => nil
  | P::Ps' => (f P lt)::(map P1 f Ps' lt)
  end.*)

Fixpoint eq_ty (t1 t2 : ty): bool :=
  match t1, t2 with
  | top, top => true
  | bot, bot => true
  | sel x1 L1 , sel x2 L2 => eq_var x1 x2 && eq_label L1 L2
  | t1 str ss1 rts, t2 str ss2 rts => eq_ty t1 t2 && eq_decls ss1 ss2
  | all t1 ∙ t1', all t2 ∙ t2' => eq_ty t1 t2 && eq_ty t1' t2'
  | _, _ => false
  end

with
eq_decl (s1 s2 : decl) : bool :=
  match s1, s2 with
  | type L1 ⩽ t1, type L2 ⩽ t2 => eq_label L1 L2 && eq_ty t1 t2
  | type L1 ⩾ t1, type L2 ⩾ t2 => eq_label L1 L2 && eq_ty t1 t2
  | type L1 ≝ t1, type L2 ≝ t2 => eq_label L1 L2 && eq_ty t1 t2
  | type L1 ⪯ t1, type L2 ⪯ t2 => eq_label L1 L2 && eq_ty t1 t2
  | _, _ => false
  end

with
eq_decls (ss1 ss2 : decls) : bool :=
  match ss1, ss2 with
  | d_nil, d_nil => true
  | d_con s1 ss1, d_con s2 ss2 => eq_decl s1 s2 && eq_decls ss1 ss2
  | _, _ => false
  end.

Fixpoint eq_tree (T1 T2 : tytree) : bool :=
  match T1, T2 with
  | t_top, t_top => true

  | t_bot, t_bot => true

  | t_sel_upp x1 L1 T1', t_sel_upp x2 L2 T2' => (eq_var x1 x2) && (eq_label L1 L2) && (eq_tree T1' T2')

  | t_sel_low x1 L1 T1', t_sel_low x2 L2 T2' => (eq_var x1 x2) && (eq_label L1 L2) && (eq_tree T1' T2')

  | t_sel_equ x1 L1 T1', t_sel_equ x2 L2 T2' => (eq_var x1 x2) && (eq_label L1 L2) && (eq_tree T1' T2')

  | t_sel_nom x1 L1 T1', t_sel_nom x2 L2 T2' => (eq_var x1 x2) && (eq_label L1 L2) && (eq_tree T1' T2')

  | t_all Ta1 Tb1, t_all Ta2 Tb2 => (eq_tree Ta1 Ta2) && (eq_tree Tb1 Tb2)

  | t_rfn_top Ts1, t_rfn_top Ts2 => (eq_tree Ts1 Ts2)

  | t_rfn_sel x1 L1 Ts1 T1', t_rfn_sel x2 L2 Ts2 T2' => (eq_var x1 x2) && (eq_label L1 L2) && (eq_tree Ts1 Ts2) && (eq_tree T1' T2')

  | t_sha_top x1 L1 ss1, t_sha_top x2 L2 ss2 => (eq_var x1 x2) && (eq_label L1 L2) && (eq_decls ss1 ss2)

  | t_sha_sel x1 L1 ss1 T1', t_sha_sel x2 L2 ss2 T2' => (eq_var x1 x2) && (eq_label L1 L2) && (eq_decls ss1 ss2) && (eq_tree T1' T2')

  | t_upp L1 T1', t_upp L2 T2' => (eq_label L1 L2) && (eq_tree T1' T2')

  | t_low L1 T1', t_low L2 T2' => (eq_label L1 L2) && (eq_tree T1' T2')

  | t_equ L1 T1', t_equ L2 T2' => (eq_label L1 L2) && (eq_tree T1' T2')

  | t_nom L1 T1', t_nom L2 T2' => (eq_label L1 L2) && (eq_tree T1' T2')

  | t_nil, t_nil => true

  | t_con T1' Ts1, t_con T2' Ts2 => (eq_tree T1' T2') && (eq_tree Ts1 Ts2)
  | _, _ => false
  end.

Parameter eq_tree_refl :
  forall T, eq_tree T T = true.

Parameter eqb_tree_eq :
  forall T1 T2, eq_tree T1 T2 = true ->
           T1 = T2.

Parameter neqb_tree_neq :
  forall T1 T2, eq_tree T1 T2 = false ->
           T1 <> T2.

Parameter eq_tree_dec :
  forall T1 T2, {eq_tree T1 T2 = true} + {eq_tree T1 T2 = false}.

Program Fixpoint subtype (T1 T2 : tytree) {measure (shape_depth T1 + shape_depth T2)} : bool :=
  match T1 with
  | t_top => match T2 with
            | t_top => true
            | t_sel_low x L T2' => subtype T1 T2'
            | t_sel_equ x L T2' => subtype T1 T2'
            | _ => false
            end

  | t_bot => match T2 with
            | t_upp _ _ => false
            | t_low _ _ => false
            | t_equ _ _ => false
            | t_nom _ _ => false
            | t_nil     => false
            | t_con _ _ => false
            | _ => true
            end

  | t_sel_upp x1 L1 T1' => match T2 with
                          | t_top => true
                          | t_sel_low x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (orb (subtype T1' T2) (subtype T1 T2'))
                          | t_sel_equ x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (orb (subtype T1' T2) (subtype T1 T2'))
                          | t_sel_upp x2 L2 _ => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1' T2)
                          | t_sel_nom x2 L2 _ => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1' T2)
                          | t_sel_bnd x2 L2 => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1' T2)
                          | t_upp L2 T2' => false
                          | t_low L2 T2' => false
                          | t_equ L2 T2' => false
                          | t_nom L2 T2' => false
                          | t_nil     => false
                          | t_con _ _ => false
                          | _ => subtype T1' T2
                          end

  | t_sel_equ x1 L1 T1' => match T2 with
                          | t_top => true
                          | t_sel_low x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (orb (subtype T1' T2) (subtype T1 T2'))
                          | t_sel_equ x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (orb (subtype T1' T2) (subtype T1 T2'))
                          | t_sel_upp x2 L2 _ => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1' T2)
                          | t_sel_nom x2 L2 _ => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1' T2)
                          | t_sel_bnd x2 L2 => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1' T2)
                          | t_upp L2 T2' => false
                          | t_low L2 T2' => false
                          | t_equ L2 T2' => false
                          | t_nom L2 T2' => false
                          | t_nil     => false
                          | t_con _ _ => false
                          | _ => subtype T1' T2
                          end

  | t_sel_nom x1 L1 T1' => match T2 with
                          | t_top => true
                          | t_sel_low x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (orb (subtype T1' T2) (subtype T1 T2'))
                          | t_sel_equ x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (orb (subtype T1' T2) (subtype T1 T2'))
                          | t_sel_upp x2 L2 _ => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1' T2)
                          | t_sel_nom x2 L2 _ => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1' T2)
                          | t_sel_bnd x2 L2 => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1' T2)
                          | t_upp L2 T2' => false
                          | t_low L2 T2' => false
                          | t_equ L2 T2' => false
                          | t_nom L2 T2' => false
                          | t_nil     => false
                          | t_con _ _ => false
                          | _ => subtype T1' T2
                          end

  | t_sel_low x1 L1 T1' => match T2 with
                          | t_top => true
                          | t_sel_low x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1 T2')
                          | t_sel_equ x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1 T2')
                          | t_sel_upp x2 L2 _ => andb (eq_var x1 x2) (eq_label L1 L2)
                          | t_sel_nom x2 L2 _ => andb (eq_var x1 x2) (eq_label L1 L2)
                          | t_sel_bnd x2 L2 => andb (eq_var x1 x2) (eq_label L1 L2)
                          | _ => false
                          end

  | t_sel_bnd x1 L1 => match T2 with
                      | t_top => true
                      | t_sel_low x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1 T2')
                      | t_sel_equ x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1 T2')
                      | t_sel_upp x2 L2 _ => andb (eq_var x1 x2) (eq_label L1 L2)
                      | t_sel_nom x2 L2 _ => andb (eq_var x1 x2) (eq_label L1 L2)
                      | t_sel_bnd x2 L2 => andb (eq_var x1 x2) (eq_label L1 L2)
                      | _ => false
                      end

  | t_rfn_top Ts1 => match T2 with
                    | t_top => true
                    | t_sel_low x L T => subtype T1 T
                    | t_sel_equ x L T => subtype T1 T
                    | t_rfn_top Ts2 => subtype Ts1 Ts2
                    | _ => false
                    end

  | t_rfn_sel x1 L1 Ts1 T' => match T2 with
                             | t_top => true
                             | t_sel_low x L T => orb (subtype T1 T)
                                                     (subtype T' T2)
                             | t_sel_equ x L T => orb (subtype T1 T)
                                                     (subtype T' T2)
                             | t_rfn_top _ => subtype T' T2
                             | t_rfn_sel x2 L2 Ts2 _ => orb (andb ((andb (eq_var x1 x2) (eq_label L1 L2)))
                                                                 (subtype Ts1 Ts2))
                                                           (subtype T' T2)
                             | t_upp _ _ => false
                             | t_low _ _ => false
                             | t_equ _ _ => false
                             | t_nom _ _ => false
                             | t_nil => false
                             | t_con _ _ => false

                             | _ => subtype T' T2
                             end

  | t_sha_top _ _ _ => match T2 with
                      | t_top => true
                      | t_sel_low x L T => subtype T1 T
                      | t_sel_equ x L T => subtype T1 T
                      | _ => false
                      end

  | t_sha_sel _ _ _ T' => match T2 with
                         | t_top => true
                         | t_sel_low x L T => orb (subtype T1 T)
                                                 (subtype T' T2)
                         | t_sel_equ x L T => orb (subtype T1 T)
                                                 (subtype T' T2)
                         | t_upp _ _ => false
                         | t_low _ _ => false
                         | t_equ _ _ => false
                         | t_nom _ _ => false
                         | t_nil => false
                         | t_con _ _ => false

                         | _ => subtype T' T2
                         end

  | t_all Ta1 Tb1 => match T2 with
                    | t_top => true
                    | t_sel_low x L T => subtype T1 T
                    | t_sel_equ x L T => subtype T1 T
                    | t_all Ta2 Tb2 => andb (eq_tree Ta2 Ta1) (subtype Tb1 Tb2)
                    | _ => false
                    end

  | t_upp L1 T1' => match T2 with
                   | t_upp L2 T2' => andb (eq_label L1 L2)
                                         (subtype T1' T2')
                   | _ => false
                   end

  | t_low L1 T1' => match T2 with
                   | t_low L2 T2' => andb (eq_label L1 L2)
                                         (subtype T2' T1')
                   | _ => false
                   end

  | t_equ L1 T1' => match T2 with
                   | t_upp L2 T2' => andb (eq_label L1 L2)
                                         (subtype T1' T2')
                   | t_low L2 T2' => andb (eq_label L1 L2)
                                         (subtype T2' T1')
                   | t_equ L2 T2' => andb (eq_label L1 L2)
                                         (andb (subtype T1' T2')
                                               (subtype T2' T1'))
                   | _ => false
                   end

  | t_nom L1 T1' => match T2 with
                   | t_upp L2 T2' => andb (eq_label L1 L2)
                                         (subtype T1' T2')
                   | t_nom L2 T2' => (eq_label L1 L2) && eq_tree T1' T2'
                   | _ => false
                   end

  | t_nil => match T2 with
            | t_nil => true
            | _ => false
            end

  | t_con T1' Ts1 => match T2 with
                   | t_nil => true
                   | t_con T2' Ts2 => andb (subtype T1' T2') (subtype Ts1 Ts2)
                   | _ => false
                   end

  end.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  simpl.
  destruct T1'; crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  destruct T1'; crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  destruct T'; crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  crush.
Defined.

Import WfExtensionality.

Lemma subtype_top :
  forall T, (forall L T', T <> t_upp L T') ->
       (forall L T', T <> t_low L T') ->
       (forall L T', T <> t_equ L T') ->
       (forall L T', T <> t_nom L T') ->
       (T <> t_nil) ->
       (forall T' Ts, T <> t_con T' Ts) ->
       subtype T t_top = true.
Proof.
  intros.

  unfold subtype, subtype_func;
    simpl;
    rewrite fix_sub_eq_ext;
    simpl;
    fold subtype_func;
    auto.

  destruct T; simpl; auto.

  contradiction (H l T); auto.
  contradiction (H0 l T); auto.
  contradiction (H1 l T); auto.
  contradiction (H2 l T); auto.
  contradiction (H3); auto.
  contradiction (H4 T1 T2); auto.
Qed.

Lemma subtype_bot :
  forall T, (forall L T', T <> t_upp L T') ->
       (forall L T', T <> t_low L T') ->
       (forall L T', T <> t_equ L T') ->
       (forall L T', T <> t_nom L T') ->
       (T <> t_nil) ->
       (forall T' Ts, T <> t_con T' Ts) ->
       subtype t_bot T = true.
Proof.
  intros.

  unfold subtype, subtype_func;
    simpl;
    rewrite fix_sub_eq_ext;
    simpl;
    fold subtype_func;
    auto.

  destruct T; simpl; auto.

  contradiction (H l T); auto.
  contradiction (H0 l T); auto.
  contradiction (H1 l T); auto.
  contradiction (H2 l T); auto.
  contradiction (H3); auto.
  contradiction (H4 T1 T2); auto.
Qed.


(** Presentable sigs are representable *)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.Categories.
Require Import UniMath.CategoryTheory.catiso.
Require Import UniMath.CategoryTheory.functor_categories.

Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.LModules.

Require Import UniMath.CategoryTheory.DisplayedCats.Auxiliary.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.

Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.EpiFacts.
Require Import UniMath.CategoryTheory.Epis.

Require Import Modules.Prelims.lib.
Require Import Modules.Prelims.modules.
Require Import Modules.Prelims.deriveadj.
Require Import Modules.Prelims.CoproductsComplements.
Require Import Modules.Prelims.LModuleCoproducts.
Require Import Modules.Signatures.HArityCoproduct.
Require Import Modules.Signatures.Signatures.
Require Import Modules.Signatures.aritiesalt.
Require Import Modules.Signatures.HssToArity.
Require Import Modules.Signatures.RawSigToHAr.
Require Import Modules.Signatures.PresentableHArityBinProdR.
Require Import Modules.Signatures.PresentableHArityCoproducts.
Require Import Modules.Signatures.PresentableArity.
Require Import Modules.Signatures.PresentableRawSig.
Require Import Modules.Signatures.Signatures.
Require  Modules.Signatures.FullSignatures.
Require Import Modules.Signatures.FullArToRaw.
Require Import Modules.Signatures.SigEquivRep.
Require Import Modules.Prelims.SetCatComplements.
Require Import UniMath.CategoryTheory.categories.category_hset.

Require Import UniMath.CategoryTheory.categories.category_hset_structures.
Module FAr := FullSignatures.

Section RawSigRep.
Local Notation hom_SET := has_homsets_HSET.
(* Local Notation Sig := (Signature SET has_homsets_HSET hset_precategory has_homsets_HSET). *)
Local Notation EndSet := [hset_category, hset_category].

  Local Notation cp := CoproductsHSET.
  Local Notation bp := BinProductsHSET.
Local Notation bpSET := BinProductsHSET.
  Local Notation bcp := BinCoproductsHSET.
  Local Notation T := TerminalHSET.
  Definition PresentableSignature {C} bpC bcpC Tc cpC :=
    ∑ (O : hSet), O -> (∑ α : arity C, isPresentable bpC bcpC Tc cpC α) × nat.

  Definition base_of_pres_sig
             {C} {bpC} {bcpC} {Tc} {cpC}
             (S : PresentableSignature (C:=C)bpC bcpC Tc cpC)
    : hSet := pr1 S.
Local Notation O := base_of_pres_sig.

Definition ar_of_pres_sig
             {C} {bpC} {bcpC} {Tc} {cpC}
             (S : PresentableSignature (C:=C)bpC bcpC Tc cpC)
  : O S -> arity C := fun o => (pr1 (pr1 (pr2 S o))).
Definition ar_of_pres_sig_isPresentable
             {C} {bpC} {bcpC} {Tc} {cpC}
             (S : PresentableSignature (C:=C)bpC bcpC Tc cpC)
  : ∏ o,   isPresentable bpC bcpC Tc cpC (ar_of_pres_sig S o):= fun o => (pr2 (pr1 (pr2 S o))).

Local Notation α := ar_of_pres_sig.
Definition nat_of_pres_sig
             {C} {bpC} {bcpC} {Tc} {cpC}
             (S : PresentableSignature (C:=C)bpC bcpC Tc cpC)
  : O S -> nat := fun o => ( (pr2 (pr2 S o))).

Let isPresentableSET :=
  isPresentable (C := SET) bp bcp T (λ i : hSet, cp (pr1 i) (setproperty i)).

Definition PresentableSignature_to_signature {C} bpC bcpC TC cpC
           (S : PresentableSignature (C:=C) bpC bcpC TC cpC)
  : signature C :=
  tpair (T := hSet) (fun X => X -> FAr.FullArity C) (O S) (fun o => (α S o ,,
                                                                nat_deriv_HAr bcpC TC
                                                      (nat_of_pres_sig S o))).

(* TODO move to derivadj *)
Definition adj1n n' R :
  ∏ a : arity SET,
  LModule_Mor R (a R) ((nat_deriv_HAr (C := SET) bcp T n') R)
  ≃ LModule_Mor R ((DeBind_HArity (C := SET) bpSET a n') R) (tautological_harity_on_objects R).
Proof.
  intro a.
  eapply equiv_is_rep_ar_to_raw .
  apply deriveadj.adj1.
Defined.

Import FullSignatures.

    (** This uses univalence to transform an isomorphism of category into an equality
       Another proof could be used without univalence though
 (@DeBind_HArity SET bpSET a n',, @tautological_harity SET)
(@DeBind_HArity SET bpSET a n',, @tautological_harity SET)
     *)

Lemma isPresentable_debind ar (har : isPresentableSET ar) n :
  isPresentableSET (DeBind_HArity (C:=SET) bpSET ar n).
Proof.
  revert ar har.
  induction n.
  - exact (fun a h => h).
  - intros ar pres_a.
    simpl.
    apply IHn.
    apply har_binprodR_isPresentable.
    + apply hset_category_isDistributive.
    + intros  F F' G G' f g epif epig.
      apply is_nat_trans_epi_from_pointwise_epis.
      intro a.
      apply isEpiBinProdHSET; apply epi_nt_SET_pw; assumption.
    + exact pres_a.
Qed.

Definition PresentableSignature_to_signature_2 (sig : PresentableSignature (C:=hset_category) bpSET bcp T (λ I : hSet, cp (pr1 I) (setproperty I)))
 : signature hset_category.
Proof.
  exists (O sig).
  intro o.
  exact (DeBind_HArity (C:=hset_category) bpSET (α sig o) (nat_of_pres_sig sig o),, tautological_harity).
Defined.

Definition catiso_Presentable_Raw (sig : PresentableSignature (C:=hset_category) bpSET bcp T (λ I : hSet, cp (pr1 I) (setproperty I))):
  let sig' := PresentableSignature_to_signature _ _  _ _ sig
  in
  catiso (precategory_rep_sig sig')
         (precategory_rep_sig (PresentableSignature_to_signature_2 sig)).
Proof.
  unshelve eapply iso_sig_sig_rep.
  + intros o R.
    cbn.
    apply adj1n.
  + unfold adj1n.
    cbn -[equiv_is_rep_ar_to_raw].
    intro o.
    set (n' := nat_of_pres_sig _ o).
    intros R S f.
    eapply (@equiv_raw_ar_mor_law SET _ _ _ deriveadj.adj1).
    * apply deriveadj.adj_law1.
    * apply deriveadj.adj_law2.
Defined.

Lemma initial_presentable_raw_sig sig (ax:  AxiomOfChoice.AxiomOfChoice_surj) :
  Initial (precategory_rep_sig
             (PresentableSignature_to_signature (C:=SET) bp bcp T
                                                (fun I => cp _ (setproperty I))  sig)).
Proof.
  set (sig' := PresentableSignature_to_signature _ _  _ _ sig).
  eapply (transportb (fun X => Initial X)).
  apply catiso_to_precategory_path.
  - intros ? ? .
    apply isaset_rep_a_sig_mor.
  - exact (catiso_Presentable_Raw sig).
  - (* This is a presentable raw signature, so it is representable *)
    set (rawS :=
           tpair (T := hSet) (fun z => z -> arity _)
                 (O sig)
                 (λ o : O sig, DeBind_HArity (C := SET) bpSET (α _ o) (nat_of_pres_sig _ o)) : rawSig).
    apply (initial_presentable_raw_sig rawS);[|apply ax].
    intro o.
    apply isPresentable_debind.
    apply ar_of_pres_sig_isPresentable.
Qed.

End RawSigRep.


Require Import Coq.Bool.Sumbool.
Require Import Crypto.Reflection.SmartMap.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.Named.Syntax.

Local Open Scope nexpr_scope.
Section language.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          {Name : Type}
          {interp_base_type_bounds : base_type_code -> Type}
          (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst)
          (pick_typeb : forall t, interp_base_type_bounds t -> base_type_code).
  Local Notation pick_type v := (SmartFlatTypeMap pick_typeb v).
  Context (cast_op : forall t tR (opc : op t tR) args_bs,
              op (pick_type args_bs) (pick_type (interp_op_bounds t tR opc args_bs)))
          {BoundsContext : Context Name interp_base_type_bounds}.

  Fixpoint mapf_cast
           (ctx : BoundsContext)
           {t} (e : exprf base_type_code op Name t)
           {struct e}
    : option { bounds : interp_flat_type interp_base_type_bounds t
                        & exprf base_type_code op Name (pick_type bounds) }
    := match e in exprf _ _ _ t return option { bounds : interp_flat_type interp_base_type_bounds t
                                                         & exprf base_type_code op Name (pick_type bounds) } with
       | TT => Some (existT _ tt TT)
       | Pair tx ex ty ey
         => match @mapf_cast ctx _ ex, @mapf_cast ctx _ ey with
            | Some (existT x_bs xv), Some (existT y_bs yv)
              => Some (existT _ (x_bs, y_bs)%core (Pair xv yv))
            | None, _ | _, None => None
            end
       | Var t x
         => option_map
              (fun bounds => existT _ bounds (Var x))
              (lookupb (t:=t) ctx x)
       | LetIn tx n ex tC eC
         => match @mapf_cast ctx _ ex with
            | Some (existT x_bounds ex')
              => option_map
                   (fun eC' => let 'existT Cx_bounds C_expr := eC' in
                               existT _ Cx_bounds (LetIn (pick_type x_bounds)
                                                         (SmartFlatTypeMapInterp2 (t:=tx) (fun _ _ (n : Name) => n) x_bounds n) ex' C_expr))
                   (@mapf_cast (extend (t:=tx) ctx n x_bounds) _ eC)
            | None => None
            end
       | Op t tR opc args
         => option_map
              (fun args'
               => let 'existT args_bounds argsv := args' in
                  existT _
                         (interp_op_bounds _ _ _ args_bounds)
                         (Op (cast_op t tR opc args_bounds) argsv))
              (@mapf_cast ctx _ args)
       end.

  Definition map_cast
             (ctx : BoundsContext)
             {t} (e : expr base_type_code op Name t)
             (input_bounds : interp_flat_type interp_base_type_bounds (domain t))
    : option { output_bounds : interp_flat_type interp_base_type_bounds (codomain t)
                               & expr base_type_code op Name (Arrow (pick_type input_bounds) (pick_type output_bounds)) }
    := option_map
         (fun v => existT
                     _
                     (projT1 v)
                     (Abs (SmartFlatTypeMapInterp2 (fun _ _ (n' : Name) => n') input_bounds (Abs_name e))
                          (projT2 v)))
         (mapf_cast (extend ctx (Abs_name e) input_bounds) (invert_Abs e)).
End language.


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Logic.lib.Coqlib.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.lib.EnsemblesProperties.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.MinimunLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.

Section ContextProperties.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {sL: SeparationLanguage L}
        {Gamma: ProofTheory L}.

Definition context_sepcon (Phi Psi: context): context :=
  fun z => exists x y, z = x * y /\ Phi |-- x /\ Psi |-- y.

Definition context_sepcon_included_l (Phi2 Psi: context): context -> Prop :=
  fun Phi1 => Included _ (context_sepcon Phi1 Phi2) Psi.

Definition context_sepcon_included_r (Phi1 Psi: context): context -> Prop :=
  fun Phi2 => Included _ (context_sepcon Phi1 Phi2) Psi.

Context {SC: NormalSequentCalculus L Gamma}
        {bSC: BasicSequentCalculus L Gamma}
        {fwSC: FiniteWitnessedSequentCalculus L Gamma}
        {minSC: MinimunSequentCalculus L Gamma}
        {ipSC: IntuitionisticPropositionalSequentCalculus L Gamma}
        {AX: NormalAxiomatization L Gamma}
        {minAX: MinimunAxiomatization L Gamma}
        {ipGamma: IntuitionisticPropositionalLogic L Gamma}
        {sGamma: SeparationLogic L Gamma}.

Lemma context_sepcon_derivable:
  forall (Phi Psi: context) z,
    context_sepcon Phi Psi |-- z ->
    exists x y, |-- x * y --> z /\ Phi |-- x /\ Psi |-- y.
Proof.
  intros.
  rewrite derivable_provable in H.
  destruct H as [xs [? ?]].
  revert z H0; induction H; intros.
  + exists TT, TT.
    split; [| split].
    - apply aux_minimun_rule00; auto.
    - apply derivable_impp_refl.
    - apply derivable_impp_refl.
  + pose proof provable_multi_imp_arg_switch1 l x z.
    pose proof modus_ponens _ _ H2 H1.
    specialize (IHForall _ H3); clear H1 H2 H3.
    destruct H as [x' [y' [? [? ?]]]]; subst x.
    destruct IHForall as [x [y [? [? ?]]]].
    exists (x && x'), (y && y').
    split; [| split].
    - clear l H0 H1 H2 H3 H4.
      rewrite (provable_sepcon_andp_right (x && x') y y').
      rewrite (provable_sepcon_andp_left x x' y).
      rewrite (provable_sepcon_andp_left x x' y').
      rewrite (andp_elim1 (x * y) _).
      rewrite (andp_elim2 _ (x' * y')).
      rewrite <- impp_curry_uncurry.
      auto.
    - apply deduction_andp_intros; auto.
    - apply deduction_andp_intros; auto.
Qed.

Lemma context_sepcon_consistent_rev_left:
  forall (Phi1 Phi2 Psi: context),
    Included _ (context_sepcon Phi1 Phi2) Psi ->
    consistent Psi ->
    consistent Phi1.
Proof.
  intros.
  rewrite consistent_spec in H0 |- *.
  intro; apply H0; clear H0.
  rewrite <- (falsep_sepcon TT).
  apply derivable_assum.
  apply H; exists FF, TT; split; [| split]; auto.
  apply derivable_impp_refl.
Qed.

Lemma context_sepcon_included_l_derivable_subset_preserved: forall Phi2 Psi,
  derivable_subset_preserved (context_sepcon_included_l Phi2 Psi).
Proof.
  intros.
  unfold context_sepcon_included_l.
  hnf; intros Phi1 Phi1' ? ?.
  eapply Included_trans; [clear Psi H0 | exact H0].
  unfold Included, Ensembles.In; intros z ?.
  destruct H0 as [x [y [? [? ?]]]].
  exists x, y; split; [| split]; auto.
  apply H; auto.
Qed.

Lemma context_sepcon_included_l_subset_preserved: forall Phi2 Psi,
  subset_preserved (context_sepcon_included_l Phi2 Psi).
Proof.
  intros.
  apply derivable_subset_preserved_subset_preserved.
  apply context_sepcon_included_l_derivable_subset_preserved.
Qed.

Lemma context_sepcon_included_l_finite_captured: forall Phi2 Psi,
  finite_captured (context_sepcon_included_l Phi2 Psi).
Proof.
  intros.
  unfold context_sepcon_included_l.
  hnf; intros.
  unfold Included, Ensembles.In; intros z ?.
  destruct H0 as [x [y [? [? ?]]]].
  apply derivable_finite_witnessed in H1.
  destruct H1 as [xs [? ?]].
  specialize (H _ H1).
  subst z.
  apply H; auto; unfold Ensembles.In.
  exists x, y; split; [| split]; auto.
Qed.

Lemma context_sepcon_included_l_context_orp_captured: forall Phi2 Psi
      (DC: derivable_closed Psi)
      (OW: orp_witnessed Psi),
  context_orp_captured (context_sepcon_included_l Phi2 Psi).
Proof.
  intros.
  unfold context_sepcon_included_l.
  hnf; intros Phi1 Phi1' ?.
  assert (forall z1 z2,
            context_sepcon Phi1 Phi2 z1  ->
            ~ Psi z1 ->
            context_sepcon Phi1' Phi2 z2 ->
            ~ Psi z2 ->
            False) as HH.
  Focus 2. {
    clear - HH; unfold Included, Ensembles.In.
    apply NNPP; intro.
    apply not_or_and in H; destruct H.
    apply not_all_ex_not in H.
    apply not_all_ex_not in H0.
    destruct H as [z1 ?], H0 as [z2 ?].
    specialize (HH z1 z2).
    tauto.
  } Unfocus.
  intros.
  destruct H0 as [x1 [y1 [? [? ?]]]], H2 as [x2 [y2 [? [? ?]]]].
  subst z1 z2.
  assert (context_orp Phi1 Phi1' (x1 || x2));
  [| assert (context_sepcon (context_orp Phi1 Phi1') Phi2 ((x1 || x2) * (y1 && y2)));
     [| assert (Psi |-- (x1 * y1) || (x2 * y2))]].
  + exists x1, x2.
    split; [| split]; auto.
  + exists (x1 || x2), (y1 && y2).
    split; [| split]; auto.
    - apply derivable_assum; auto.
    - apply deduction_andp_intros; auto.
  + apply H in H2.
    apply derivable_assum in H2.
    rewrite sepcon_orp_distr_l in H2.
    rewrite (andp_elim1 y1 y2) in H2 at 1.
    rewrite (andp_elim2 y1 y2) in H2 at 1.
    auto.
  + rewrite <- derivable_closed_element_derivable in H8 by auto.
    apply OW in H8.
    tauto.
Qed.

Lemma wand_deduction_theorem:
  forall (Phi: context) x y,
    context_sepcon Phi (Union _ empty_context (Singleton _ x)) |-- y <->
    Phi |-- x -* y.
Proof.
  intros.
  split; intros.
  + apply context_sepcon_derivable in H.
    destruct H as [x' [y' [? [? ?]]]].
    rewrite deduction_theorem, <- provable_derivable in H1.
    rewrite <- H1 in H.
    apply wand_sepcon_adjoint in H.
    rewrite H in H0; auto.
  + rewrite <- (provable_wand_sepcon_modus_ponens1 x y).
    apply derivable_assum.
    exists (x -* y), x.
    split; [| split]; auto.
    rewrite deduction_theorem.
    apply derivable_impp_refl.
Qed.

Lemma context_sepcon_included_equiv: forall Phi Psi,
  derivable_closed Psi ->
  Same_set _ (context_sepcon_included_l Phi Psi) (context_sepcon_included_r Phi Psi).
Proof.
  intros.
  rewrite Same_set_spec; intros Phi'; split; intros.
  + hnf; intros.
    destruct H1 as [y [z [? [? ?]]]].
    subst x.
    apply H.
    rewrite <- sepcon_comm.
    apply derivable_assum.
    apply H0.
    exists z, y; split; [| split]; auto.
  + hnf; intros.
    destruct H1 as [y [z [? [? ?]]]].
    subst x.
    apply H.
    rewrite <- sepcon_comm.
    apply derivable_assum.
    apply H0.
    exists z, y; split; [| split]; auto.
Qed.

End ContextProperties.


From Perennial.base_logic Require Import ghost_map saved_prop mono_nat.
From Perennial.program_proof Require Import std_proof.
From Perennial.program_proof.mvcc Require Import mvcc_prelude mvcc_ghost.
From Goose.github_com.mit_pdos.go_mvcc Require Import tid.

Local Ltac Zify.zify_post_hook ::= Z.div_mod_to_equations.

Section program.
Context `{!heapGS Σ, !mvcc_ghostG Σ}.

Local Definition sid_of (ts: u64) : u64 := word.modu ts (U64 N_TXN_SITES).

Local Definition gentid_au (γ : mvcc_names) (sid : u64) (Φ : val → iProp Σ) : iProp Σ :=
  (|NC={⊤ ∖ ↑mvccNTID,∅}=>
    ∃ ts : nat, ts_auth γ ts ∗
       (∀ ts' : nat, ts_auth γ ts' ∗ ⌜(ts < ts')%nat⌝ -∗
         |NC={∅,⊤ ∖ ↑mvccNTID}=> ∀ tid : u64, ⌜int.nat tid = ts'⌝ ∗ sid_own γ sid -∗ Φ #tid)).

Local Definition reserved_inv γ γr now (ts : u64): iProp Σ :=
  ∃ Φ, let sid := sid_of ts in
    saved_pred_own γr DfracDiscarded Φ ∗
    sid_own γ sid ∗
    if bool_decide (int.nat ts ≤ now)%nat then
      (* This ts has already happened *)
      sid_own γ sid -∗ Φ #ts
    else
      (* This ts is still in the future *)
      gentid_au γ sid Φ
    .

Local Definition gentid_inv (γ : mvcc_names) now : iProp Σ :=
  ∃ prev (reserved : gmap u64 gname),
    ⌜prev ≤ now⌝%nat ∗ ts_auth γ prev ∗ tsc_lb now ∗
    ghost_map_auth γ.(mvcc_gentid_reserved) 1 reserved ∗
    [∗ map] ts ↦ 'γr ∈ reserved,
      reserved_inv γ γr now ts.

Definition have_gentid (γ : mvcc_names) : iProp Σ :=
  inv mvccNTID (∃ now, gentid_inv γ now).

Local Definition tid_reserved γ γr ts (Φ : val → iProp Σ) : iProp Σ :=
  ghost_map_elem γ.(mvcc_gentid_reserved) ts (DfracOwn 1) γr ∗
  saved_pred_own γr DfracDiscarded Φ.

Global Instance have_gentid_persistent γ : Persistent (have_gentid γ).
Proof. apply _. Qed.

Lemma init_GenTID γ E :
  mvcc_gentid_init γ -∗
  |={E}=> have_gentid γ.
Proof.
  iIntros "[Hts Hres]".
  iMod tsc_lb_0.
  iApply inv_alloc. iNext. iExists _, 0%nat, ∅.
  iFrame. rewrite big_sepM_empty. eauto.
Qed.

Local Lemma gentid_reserve γ now sid Φ :
  gentid_inv γ now -∗
  sid_own γ sid -∗
  gentid_au γ sid Φ -∗
  |==> tsc_lb now ∗
    (* The user can pick a timestamp with the right sid, but only gets something
    out of this if they pick one that is strictly greater than [clock]. *)
    (∀ ts, ⌜sid = sid_of ts⌝ ==∗
       (if bool_decide (now < int.Z ts) then ∃ γr, tid_reserved γ γr ts Φ else True) ∗
       gentid_inv γ now).
Proof.
  iIntros "(%last & %reserved & %Hlast & Hts & #Htsc & Hreserved_map & Hreserved) Hsid HAU".
  iFrame "Htsc". iIntros "!> %ts %Hsid".
  iAssert (⌜reserved !! ts = None⌝)%I as %Hfresh.
  { destruct (reserved !! ts) as [γr|] eqn:Hts; last done. iExFalso.
    iDestruct (big_sepM_lookup _ _ _ _ Hts with "Hreserved") as (Φ2) "(_ & Hsid2 & _)".
    rewrite -Hsid.
    iDestruct (own_valid_2 with "Hsid Hsid2") as %Hval. iPureIntro. move:Hval.
    rewrite singleton_op singleton_valid. done. }
  case_bool_decide; last first.
  { (* They gave us an outdated timestamp. *)
    iSplitR; first done. eauto with iFrame. }
  iMod (saved_pred_alloc Φ DfracDiscarded) as (γr) "#HΦ"; first done.
  iMod (ghost_map_insert ts γr with "Hreserved_map") as "[Hreserved_map Hreserved_ts]"; first done.
  iSplitL "Hreserved_ts".
  { rewrite /tid_reserved. eauto. }
  iExists last, _. iFrame "Hreserved_map Hts". iSplitR; first done.
  iApply big_sepM_insert; first done.
  iFrame. rewrite /reserved_inv. rewrite bool_decide_false; last lia.
  iExists Φ. iFrame "HΦ". rewrite -Hsid. iFrame. done.
Qed.

Local Lemma reserved_inc_clock γ now reserved :
  reserved !! (U64 (S now)) = None →
  ([∗ map] ts↦γr ∈ reserved, reserved_inv γ γr now ts) -∗
  [∗ map] ts↦γr ∈ reserved, reserved_inv γ γr (S now) ts.
Proof.
  intros Hnotnow.
  iIntros "Hm". iApply (big_sepM_impl with "Hm").
  iIntros "!> %ts %γr %Hts (%Φ & HΦ & Hsid & HAU)".
  assert (int.nat ts ≠ S now).
  { intros Heq. rewrite -Heq in Hnotnow.
    replace (U64 (int.nat ts)) with ts in Hnotnow by word. congruence. }
  iExists _. iFrame.
  case_bool_decide.
  - rewrite bool_decide_true. 2:lia. done.
  - rewrite bool_decide_false. 2:lia. done.
Qed.

Local Lemma gentid_inc_clock γ old now :
  (old ≤ now)%nat →
  (now < 2^64) →
  gentid_inv γ old -∗
  tsc_lb now -∗
  |NC={⊤∖↑mvccNTID}=> gentid_inv γ now.
Proof.
  induction 1 using le_ind.
  { eauto. }
  iIntros (?) "Hgentid #Htsc".
  iDestruct (IHle with "Hgentid [Htsc]") as ">Hgentid".
  { lia. }
  { iApply tsc_lb_weaken; last done. lia. }
  iDestruct "Hgentid" as "(%last & %reserved & %Hlast & Hts & _ & Hreserved_map & Hreserved)".
  set ts := S m.
  destruct (reserved !! (U64 ts)) as [γr|] eqn:Hts; last first.
  { (* Nothing reserved at this timestamp, not much to do. *)
    iExists _, _. iFrame. iSplitR; first by eauto with lia.
    iFrame "Htsc".
    iApply reserved_inc_clock; done. }
  (* Bump our timestamp. *)
  iExists ts, _. iFrame. iFrame "Htsc".
  iSplitR; first done.
  rewrite !(big_sepM_delete _ _ _ _ Hts).
  iDestruct "Hreserved" as "[Hthis Hreserved]".
  rewrite !assoc. iSplitR "Hreserved"; last first.
  { iApply reserved_inc_clock; last done.
    rewrite lookup_delete. done. }
  iDestruct "Hthis" as (Φ) "(HΦ & Hsid & HAU)".
  rewrite bool_decide_false. 2:word.
  iMod "HAU" as (ts') "[Hts' Hclose]".
  rewrite /ts_auth.
  iDestruct (mono_nat_auth_own_agree with "Hts Hts'") as %[_ <-].
  iCombine "Hts Hts'" as "Hts".
  iMod (mono_nat_own_update ts with "Hts") as "[[Hts $] _]".
  { lia. }
  iMod ("Hclose" with "[Hts]") as "Hfin".
  { iFrame. eauto with lia. }
  iModIntro. iExists _. iFrame. rewrite bool_decide_true.
  2:word.
  iIntros "Hsid". iApply "Hfin". iFrame. iPureIntro. word.
Qed.

Local Lemma gentid_completed γ γr clock ts Φ :
  £1 -∗
  gentid_inv γ clock -∗
  tid_reserved γ γr ts Φ -∗
  tsc_lb (int.nat ts) -∗
  |NC={⊤∖↑mvccNTID}=> ∃ clock', gentid_inv γ clock' ∗ Φ #ts.
Proof.
  iIntros "LC Hgentid Hreserved Htsc".
  set clock' := max clock (int.nat ts).
  iAssert (|NC={⊤∖↑mvccNTID}=> gentid_inv γ clock')%I with "[Htsc Hgentid]" as ">Hgentid".
  { destruct (decide (clock <= int.nat ts)%nat); last first.
    { replace clock' with clock by lia. done. }
    iMod (gentid_inc_clock with "Hgentid Htsc") as "Hgentid"; first done.
    { word. }
    replace clock' with (int.nat ts) by lia. done.
  }
  iDestruct "Hgentid" as "(%last & %reserved & %Hlast & Hts & #Htsc & Hreserved_map & Hreserved_all)".
  iExists clock'.
  iDestruct "Hreserved" as "[Hmap HΦ]".
  iDestruct (ghost_map_lookup with "Hreserved_map Hmap") as %Hts.
  iMod (ghost_map_delete with "Hreserved_map Hmap") as "Hreserved_map".
  iDestruct (big_sepM_delete _ _ _ _ Hts with "Hreserved_all") as "[Hreserved Hreserved_all]".
  iDestruct "Hreserved" as (Φ') "(HΦ' & Hsid & HAU)".
  iDestruct (saved_pred_agree _ _ _ _ _ (#ts) with "HΦ HΦ'") as "EQ".
  iMod (lc_fupd_elim_later with "LC EQ") as "EQ".
  iRewrite "EQ". clear Φ.
  rewrite bool_decide_true.
  2:lia.
  iModIntro. iSplitR "Hsid HAU".
  - iExists _, _. iFrame. eauto.
  - iApply "HAU". done.
Qed.

(**
 * [int.nat tid = ts] means no overflow, which we would have to assume.
 * It takes around 120 years for TSC to overflow on a 4-GHz CPU.
 *)
(*****************************************************************)
(* func GenTID(sid uint64) uint64                                *)
(*****************************************************************)
Theorem wp_GenTID (sid : u64) γ :
  int.Z sid < N_TXN_SITES →
  ⊢ have_gentid γ -∗
    {{{ sid_own γ sid }}}
    <<< ∀∀ (ts : nat), ts_auth γ ts >>>
      GenTID #sid @ ↑mvccNTID
    <<< ∃∃ ts', ts_auth γ ts' ∗ ⌜(ts < ts')%nat⌝ >>>
    {{{ (tid : u64), RET #tid; ⌜int.nat tid = ts'⌝ ∗ sid_own γ sid }}}.
Proof.
  iIntros "%Hsid #Hinv !>" (Φ) "Hsid HAU".
  wp_call.

  (***********************************************************)
  (* var tid uint64                                          *)
  (***********************************************************)
  wp_apply wp_ref_of_zero; first done.
  iIntros (tidRef) "Htid".
  wp_pure1_credit "LC".
  wp_pures.

  (***********************************************************)
  (* tid = GetTSC()                                          *)
  (***********************************************************)
  wp_apply (wp_GetTSC).
  iInv "Hinv" as "Hgentid" "Hclose".
  iMod (lc_fupd_elim_later with "LC Hgentid") as (clock) "Hgentid".
  iMod (gentid_reserve with "Hgentid Hsid HAU") as "[Hclock Hcont]".
  iApply ncfupd_mask_intro.
  { solve_ndisj. }
  iIntros "Hclose2".
  iExists _. iFrame "Hclock".
  iIntros (clock2) "[%Hclock Hclock2]".
  iMod "Hclose2" as "_".
  set inbounds := bool_decide (int.Z clock2 + 16 < 2^64).
  set clock2_boundsafe := if inbounds then clock2 else 0.
  feed pose proof (u64_round_up_spec clock2_boundsafe (U64 16)) as H.
  { subst clock2_boundsafe inbounds. case_bool_decide; word. }
  { word. }
  move:H.
  set rounded_ts := u64_round_up clock2_boundsafe (U64 16).
  intros (Hmod & Hbound1 & Hbound2).
  set reserved_ts := word.add rounded_ts sid.
  assert ((int.Z rounded_ts + int.Z sid) `mod` 16 = int.Z sid) as Hsidmod.
  { rewrite Z.add_mod. 2:lia.
    rewrite Hmod. rewrite [int.Z sid `mod` _]Z.mod_small. 2:split;[word|done].
    rewrite Z.mod_small. 1:lia. split;[word|done]. }
  assert (int.Z (sid_of reserved_ts) = int.Z sid) as Hsid_of.
  { rewrite /sid_of /reserved_ts.
    rewrite word.unsigned_modu. 2:done.
    rewrite word.unsigned_add. rewrite (wrap_small (_+_)). 2:word.
    rewrite wrap_small. 1:done.
    split.
    - apply Z_mod_nonneg_nonneg. all:try word. all:done.
    - trans (int.Z N_TXN_SITES). 2:done. apply Z.mod_pos_bound. done.
  }
  iMod ("Hcont" $! reserved_ts with "[]") as "[Hreserved Hgentid]".
  { iPureIntro. rewrite /sid_of /reserved_ts. apply word.unsigned_inj. done. }
  iMod ("Hclose" with "[Hgentid]") as "_".
  { eauto. }
  iIntros "!> _".

  (************************************************************************)
  (* tid = ... *)
  (************************************************************************)
  wp_store.
  wp_load.
  wp_apply wp_SumAssumeNoOverflow. iIntros (Hoverflow).
  wp_store.
  wp_pures.

  assert (inbounds = true) as ->.
  { subst inbounds. rewrite bool_decide_true; first done. word. }
  subst clock2_boundsafe.
  rewrite u64_Z_through_nat in Hclock.
  rewrite bool_decide_true.
  2:{ subst reserved_ts. word. }
  iDestruct "Hreserved" as (γr) "Hreserved".

  set tid := (word.add _ _).
  assert (tid = reserved_ts) as -> by done.

  (***********************************************************)
  (* for GetTSC() <= tid {                                   *)
  (* }                                                       *)
  (***********************************************************)
  set P := λ (b : bool), (tidRef ↦[uint64T] #(reserved_ts : u64) ∗
     if b then True else tsc_lb (int.nat reserved_ts))%I.
  wp_apply (wp_forBreak_cond P with "[] [Htid]").
  { clear Φ. iIntros "!> %Φ [Htid _] HΦ".
    wp_apply (wp_GetTSC).
    iMod tsc_lb_0 as "Htsc".
    iApply ncfupd_mask_intro.
    { solve_ndisj. }
    iIntros "Hclose".
    iExists _. iFrame "Htsc".
    iIntros (new_time) "[%Htime Htsc]". iMod "Hclose" as "_".
    iIntros "!> _". wp_load. wp_pures.
    case_bool_decide; wp_pures; iApply "HΦ"; unfold P; iFrame "Htid".
    - done.
    - iApply tsc_lb_weaken; last done. lia.
  }
  { unfold P. iFrame. }
  iIntros "HP". unfold P. clear P. iDestruct "HP" as "[Htid Htsc]".

  wp_pure1_credit "LC1". wp_pure1_credit "LC2".
  iApply ncfupd_wp.
  iInv "Hinv" as "Hgentid" "Hclose".
  iMod (lc_fupd_elim_later with "LC1 Hgentid") as (clock3) "Hgentid".
  iMod (gentid_completed with "LC2 Hgentid Hreserved Htsc") as (clock4) "(Hgentid & HΦ)".
  iMod ("Hclose" with "[Hgentid]") as "_".
  { eauto. }
  iModIntro.

  (***********************************************************)
  (* return tid                                              *)
  (***********************************************************)
  wp_load. iApply "HΦ".
Qed.

End program.

Global Typeclasses Opaque have_gentid.


Require Import Coq.Classes.RelationClasses.
Require Import Coq.Relations.Relation_Definitions.
Require Import Logic.lib.Coqlib.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Model.DownwardsClosure.
Require Import Logic.SeparationLogic.Semantics.WeakSemantics.
Require Import Logic.SeparationLogic.Semantics.StrongSemantics.
Require Import Logic.SeparationLogic.Semantics.UpwardsSemantics.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.

Module Up2Flat.
Section Up2Flat.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {MD: Model}
        {kMD: KripkeModel MD}
        {M: Kmodel}
        {R: Relation (Kworlds M)}
        {po_R: PreOrder Krelation}
        {J: Join (Kworlds M)}
        {SA: SeparationAlgebra (Kworlds M)}
        {uSA: UpwardsClosedSeparationAlgebra (Kworlds M)}
        {SM: Semantics L MD}
        {kiSM: KripkeIntuitionisticSemantics L MD M SM}
        {usepconSM: UpwardsSemantics.SepconSemantics L MD M SM}
        {uwandSM: UpwardsSemantics.WandSemantics L MD M SM}.

Definition fwandSM: @FlatSemantics.WandSemantics L wandL MD kMD M _ (DownwardsClosure_J) SM.
Proof.
  hnf; intros.
  unfold WeakSemantics.wand.
  split; unfold Included, Ensembles.In; intros m ?.
  + rewrite (app_same_set (UpwardsSemantics.denote_wand _ _) m) in H.
    intros.
    destruct H0 as [m' [m1' [? [? ?]]]].
    apply (H  _ _ _ H0 H3).
    eapply sat_mono; eauto.
  + rewrite (app_same_set (UpwardsSemantics.denote_wand _ _) m).
    hnf; intros.
    apply (H m1 m2); auto.
    exists m0, m1.
    split; [| split]; auto.
    reflexivity.
Qed.

Definition fsepconSM: @FlatSemantics.SepconSemantics L sepconL MD kMD M _ (DownwardsClosure_J) SM.
Proof.
  hnf; intros.
  unfold WeakSemantics.sepcon.
  split; unfold Included, Ensembles.In; intros m ?.
  + rewrite (app_same_set (UpwardsSemantics.denote_sepcon _ _) m) in H.
    destruct H as [m1 [m2 [? [? ?]]]].
    exists m1, m2.
    split; [| split]; auto.
    exists m1, m2.
    split; [| split]; auto; reflexivity.
  + rewrite (app_same_set (UpwardsSemantics.denote_sepcon _ _) m).
    destruct H as [m1 [m2 [[n1 [n2 [? [? ?]]]] [? ?]]]].
    exists n1, n2.
    split; [| split]; auto; eapply sat_mono; eauto.
Qed.

Definition feSM {empL: EmpLanguage L} {USA': UnitalSeparationAlgebra' (Kworlds M)} {uempSM: UpwardsSemantics.EmpSemantics L MD M SM}: @FlatSemantics.EmpSemantics L _ MD _ M _ (DownwardsClosure_J) SM.
Proof.
  constructor;
  intros m; simpl; unfold Ensembles.In; unfold WeakSemantics.emp;
  rewrite <- DownwardsClosure_increasing;
  apply UpwardsSemantics.denote_emp.
Qed.

End Up2Flat.
End Up2Flat.


(** * Dependently-typed events *)

(** A _type family_ is given by a parameter type [I : Type] and a type function
    [F : I -> Type].

    A type family [(I, F : I -> Type)] can be encoded as an indexed type
    [E : Type -> Type].
    A value [i : I] can be seen as a "flat representation" of a value [e : E X]
    (for arbitrary [X]), while [F i : Type] gives the type index [X] of this [e].

    This encoding can be seen as a kind of "dependently-typed event",
    although the general use indexed types for event types already provides an
    equally expressive form of dependency.
 *)

(* begin hide *)
From ITree Require Import
     Basics.Basics
     Core.ITreeDefinition
     Indexed.Sum
     Core.Subevent.

Import Basics.Basics.Monads.
(* end hide *)

Variant depE {I : Type} (F : I -> Type) : Type -> Type :=
| Dep (i : I) : depE F (F i).

Arguments Dep {I F} &.

Definition dep {I F E} `{depE F -< E} (i : I) : itree E (F i) :=
  trigger (Dep (F := F) i).

Definition undep {I F} (f : forall i : I, F i) :
  depE F ~> identity :=
  fun _ d =>
    match d with
    | Dep i => f i
    end.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrnat.
Require Import seq.
Require Import cfmap.
Require Import cfreducible.
Require Import configurations.
Require Import job235to238.
Require Import job239to253.
Require Import job254to270.
Require Import job271to278.
Require Import job279to282.

Lemma red234to282 : reducible_in_range 234 282 the_configs.
Proof.
CatReducible red234to238 red238to253 red253to270 red270to278 red278to282.
Qed.


(* Todo: *)

(*   -list method -> list ty ==> list (method * ty)
     -write refinesADT'
*)

Require Import FiatFormal.Language.Step.
Require Import FiatFormal.Language.TyJudge.

Set Printing Projections.

Definition refines (x1 x2 : exp) :=
  forall pb ds pbOK v,
    STEPS pb ds pbOK x2 v
    -> STEPS pb ds pbOK x1 v.
Definition refinesP (p1 p2 : prog) :=
  forall pb ds pbOK v,
    STEPSP pb ds pbOK p2 v
    -> STEPSP pb ds pbOK p1 v.

Definition getRepType (a : adt) :=
  match a with
  | IADT r ms ss => r
  end.
Definition getMethods (a : adt) :=
  match a with
  | IADT r ms ss => ms
  end.
Definition getSigs (a : adt) :=
  match a with
  | IADT r ms ss => ss
  end.
Definition getArity (m : method) :=
  m.(arity).
Definition getDom (m : method) :=
  m.(dom).
Definition getCod (m : method) :=
  m.(cod).
Definition getBody (m : method) :=
  m.(body).

Inductive refinesADT
           (ProofBuilder : propcon -> list exp -> Prop)
           (ds : defs)
           (ProofBuilderOK : forall ke te pc xs ts,
               ProofBuilder pc xs
               -> getPropDef pc ds = Some (DefProp pc ts)
               -> Forall2 (TYPE ds ke te) xs ts)
  : adt -> adt -> Prop :=
| CREFINE :
    forall methodsNew repNew sigsNew methodsOld repOld sigsOld,
    (exists (R : exp -> exp -> Prop),
    forall n arity dom bodyOld bodyNew cod
      v vs repNew' repsNew repsOld,
      get n methodsOld = Some (mkMethod arity dom bodyOld cod)
      -> get n methodsNew = Some (mkMethod arity dom bodyNew cod)
      -> Forall wnfX vs
      -> Forall2 R repsOld repsNew
      -> STEPS ProofBuilder ds ProofBuilderOK
              (XNApp (bodyNew) (repsNew >< vs))
              (XTup ((nil :> v) :> repNew'))
      -> (exists repOld',
          STEPS ProofBuilder ds ProofBuilderOK
                (XNApp (bodyOld) (repsOld >< vs))
                (XTup ((nil :> v) :> repOld'))
          /\ R repOld' repNew'))
          -> refinesADT ProofBuilder ds ProofBuilderOK
                        (IADT repOld methodsOld sigsOld)
                        (IADT repNew methodsNew sigsNew).

Theorem refinementSoundess : forall pb ds pbOK ao an p,
    refinesADT pb ds pbOK ao an ->
    refinesP (PLET ao p) (PLET an p).
Proof.
  unfold refinesP.
  intros.
  inverts H.
  dest H1.
Admitted.