(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Defining type safety, page 67.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.

Require Export FormalSyntax.
Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export DynamicSemanticsTypeSubstitution.
Require Export StaticSemanticsKindingAndContextWellFormedness.
Require Export StaticSemantics.
Require Export TypeSafety.
Require Export CpdtTactics.
Require Export TacticNotations.
Require Export GetLemmasRelation.

Require Export StaticSemanticsWellFormednessLemmas.
Require Export StaticSemanticsHeapObjectsLemmas.

Lemma A_2_Term_Weakening_1 :
  forall (d: Delta) (u u' : Upsilon) (g g' : Gamma)
         (x : EVar) (p p' : P) (tau tau' : Tau),
    WFC d (u ++ u') (g ++ g') ->
    gettype u x p tau p' tau' ->
    gettype (u ++ u') x p tau p' tau'.
Proof.
  intros d u u' g g' x p p' tau tau'.
  intros WFCd.
  intros gettypeder.
  gettype_ind_cases (induction gettypeder) Case.
  Case "gettype u x p tau [] tau".
   constructor.
  Case "gettype u x p (cross t0 t1) (i_pe zero_pe :: p') tau".
   constructor.
   apply IHgettypeder in WFCd.
   assumption.
  Case "gettype u x p (cross t0 t1) (i_pe one_pe :: p') tau".
   constructor.
   apply IHgettypeder in WFCd.
   assumption.
  Case "gettype u x p (etype aliases alpha k tau') (u_pe :: p') tau)".
   apply IHgettypeder in WFCd.
   apply gettype_etype with (tau'':= tau'').
   apply getU_Some_Weakening.
   assumption.
   assumption.
Qed.

(* What is really breaking this is the K [] t A which comes from the
   typing of the term but I need down in the strengthening. *)
(* TODO let, open, openstar and function application. *)
Lemma A_2_Term_Weakening_2:
  forall (d: Delta) (u : Upsilon) (g : Gamma)  (e : E) (tau : Tau),
    ltyp d u g e tau ->
    WFC d u g ->
      forall (u' : Upsilon) (g' : Gamma),
        WFC d u' g' ->
        WFC d (u ++ u') (g ++ g') ->
        ltyp d (u ++ u') (g ++ g') e tau.
Proof.
  intros d u g e tau ltypder.
  apply (ltyp_ind_mutual
           (fun (d : Delta) (u : Upsilon) (g : Gamma) (t : Tau) (s : St)
                (st : styp d u g t s) =>
              WFC d u g ->
              forall (u' : Upsilon) (g' : Gamma),
                WFC d u' g' ->
                WFC d (u ++ u') (g ++ g') ->
                styp d (u ++ u') (g ++ g') t s)
           (fun (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t : Tau)
                (lt : ltyp d u g  e t) =>
              WFC d u g ->
              forall (u' : Upsilon) (g' : Gamma),
                WFC d u' g' ->
                WFC d (u ++ u') (g ++ g') ->
                ltyp d (u ++ u') (g ++ g') e t)
           (fun (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t : Tau)
                (rt : rtyp d u g e t) =>
              WFC d u g ->
              forall (u' : Upsilon) (g' : Gamma),
                WFC d u' g' ->
                WFC d (u ++ u') (g ++ g') ->
                rtyp d (u ++ u') (g ++ g') e t)).
  Case "styp_e_3_1".
   intros.
   apply styp_e_3_1 with (tau':= tau').
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_return_3_2".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_seq_3_3".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_while_3_4".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_if_3_5".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H2; try assumption.
   apply H0 with (u':= u') (g':= g') in H2; try assumption.
   apply H1 with (u':= u') (g':= g') in H2; try assumption.
  Case "styp_let_3_6".
  (* OKay this works, modulo alpha conversion but the case is a
      repetitive mess. *)
   intros.
   apply styp_let_3_6 with (tau':=tau'); try assumption.
   AdmitAlphaConversion.
   inversion H2; try assumption.
   assert (Z: WFC d0 u0 ([(x, tau')] ++ g0)).
   constructor; try assumption.
   constructor; try assumption.
   inversion H1; try assumption.
   inversion H3; try assumption.
   apply WFU_strengthening in H12; try assumption.
   apply H with (u':= u') (g':= g') in Z; try assumption.
   constructor; try assumption.
   apply WFDG_xt.
   AdmitAlphaConversion.
   assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
   inversion H3.
   assumption.
   inversion H3; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_open_3_7".
   intros.
   inversion H1.
   inversion H2.
   crush.
   apply styp_open_3_7 with (p:= p) (k:= k) (tau':= tau'); try assumption.
   AdmitAlphaConversion.
   apply H16 in H2; try assumption.
   apply H0; try assumption.
   constructor; try assumption.
   constructor; try assumption.
   constructor; try assumption.
   (*  K ((alpha, k) :: d0) tau' A *)
   admit. (* Don't know where to get this K, it's coming from the pack that is e0. *)
   constructor; try assumption.
   constructor; try assumption.
   constructor; try assumption.
   constructor; try assumption.
   constructor; try assumption.
   constructor; try assumption.
   constructor; try assumption.
   AdmitAlphaConversion.
   (*  K ((alpha, k) :: d0) tau' A *)
   admit. (* Don't know where to get this K. *)
   constructor; try assumption.
   (* WFDG d0 (g0 ++ g') given WFDG d0 g0 *)
   admit. (* WFDG strengthening. *)
   (* What do I have here to make a WFDG true ? *)
   inversion H3; try assumption.
  Case "styp_openstar_3_8".
   admit. (* Will have the similar problems with let. *)
  Case "SL_3_1".
   intros.
   apply SL_3_1 with (tau':=tau'); try assumption.
   apply getG_Some_Weakening; try assumption.
   apply gettype_weakening; try assumption.
   inversion H; try assumption.
   inversion H1; try assumption.
  Case "SL_3_2".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SL_3_3".
   intros.
   apply SL_3_3 with (t1:= t1); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SL_3_4".
   intros.
   apply SL_3_4 with (t0:= t0); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_1".
   intros.
   apply SR_3_1 with (tau':= tau'); try assumption.
   apply getG_Some_Weakening; try assumption.
   apply gettype_weakening; try assumption.
   inversion H; try assumption.
   inversion H1; try assumption.
  Case "SR_3_2".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_3".
   intros.
   apply SR_3_3 with (t1:= t1); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_4".
   intros.
   apply SR_3_4 with (t0:= t0); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_5".
   intros.
   constructor; try assumption.
  Case "SR_3_6".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_7".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_8".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_9".
   intros.
   apply SR_3_9 with (tau':= tau'); try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_10".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_11".
   intros.
   apply SR_3_11 with (k:=k); try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_12".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  (* TODO two cases and then I'm done without rtype weakening. *)
  Case "SR_3_13".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   AdmitAlphaConversion.
   admit.
   admit.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   admit.
   admit.
  Case "SR_3_14".
   intros.
   admit.
  Case "base".
   assumption.
Qed.

Lemma A_2_Term_Weakening_3:
  forall (d: Delta) (u : Upsilon) (g : Gamma)  (e : E) (tau : Tau),
    rtyp d u g e tau ->
    WFC d u g ->
      forall (u' : Upsilon) (g' : Gamma),
        WFC d u' g' ->
        WFC d (u ++ u') (g ++ g') ->
        rtyp d (u ++ u') (g ++ g') e tau.
Proof.
  intros d u g e tau ltypder.
  apply (rtyp_ind_mutual
           (fun (d : Delta) (u : Upsilon) (g : Gamma) (t : Tau) (s : St)
                (st : styp d u g t s) =>
              WFC d u g ->
              forall (u' : Upsilon) (g' : Gamma),
                WFC d u' g' ->
                WFC d (u ++ u') (g ++ g') ->
                styp d (u ++ u') (g ++ g') t s)
           (fun (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t : Tau)
                (lt : ltyp d u g  e t) =>
              WFC d u g ->
              forall (u' : Upsilon) (g' : Gamma),
                WFC d u' g' ->
                WFC d (u ++ u') (g ++ g') ->
                ltyp d (u ++ u') (g ++ g') e t)
           (fun (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t : Tau)
                (rt : rtyp d u g e t) =>
              WFC d u g ->
              forall (u' : Upsilon) (g' : Gamma),
                WFC d u' g' ->
                WFC d (u ++ u') (g ++ g') ->
                rtyp d (u ++ u') (g ++ g') e t)).
(*
  Case "styp_e_3_1".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_return_3_2".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_seq_3_3".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_while_3_4".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_if_3_5".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H2; try assumption.
   apply H0 with (u':= u') (g':= g') in H2; try assumption.
   apply H1 with (u':= u') (g':= g') in H2; try assumption.
  Case "styp_let_3_6".
   intros.
   apply styp_let_3_6 with (tau':=tau'); try assumption.
   AdmitAlphaConversion.
   inversion H2; try assumption.
   assert (Z: WFC d0 u0 ([(x, tau')] ++ g0)). (* How do I get this ? *)
   constructor; try assumption.
   constructor; try assumption.
   admit.
   admit.
   admit.
   admit.
   admit.
   (*
   apply H with (u':= u') (g':= g') in Z; try assumption.
   admit.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
   *)
  Case "styp_open_3_7".
   admit. (* Will have the similar problems with let. *)
  Case "styp_openstar_3_8".
   admit. (* Will have the similar problems with let. *)
  Case "SL_3_1".
  (* Should use the previous theorem.
   intros.
   apply SL_3_1 with (tau':= tau0); try assumption.
   apply getG_Some_Weakening; try assumption.
   apply gettype_weakening; try assumption.
   inversion H; try assumption.
   inversion H1; try assumption.
   *)
  admit.
  Case "SL_3_2".
   intros.
   admit. (* constructor; try assumption. *)
   (* apply H with (u':= u') (g':= g') in H0; try assumption. *)
  Case "SL_3_3".
   intros.
   apply SL_3_3 with (t1:= t1); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SL_3_4".
   intros.
   apply SL_3_4 with (t0:= t0); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_1".
   intros.
   apply SR_3_1 with (tau':= tau'); try assumption.
   apply getG_Some_Weakening; try assumption.
   apply gettype_weakening; try assumption.
   inversion H; try assumption.
   inversion H1; try assumption.
  Case "SR_3_2".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_3".
   intros.
   apply SR_3_3 with (t1:= t1); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_4".
   intros.
   apply SR_3_4 with (t0:= t0); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_5".
   intros.
   constructor; try assumption.
  Case "SR_3_6".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_7".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_8".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_9".
   intros.
   apply SR_3_9 with (tau':= tau'); try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_10".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_11".
   intros.
   apply SR_3_11 with (k:=k); try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_12".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_13".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   AdmitAlphaConversion.
   admit.
   admit.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   admit.
   admit.
  Case "SR_3_14".
   admit.
  Case "base".
   assumption.
Qed.
*)
Admitted.

Lemma A_2_Term_Weakening_4:
  forall (d: Delta) (u : Upsilon) (g : Gamma)  (s : St) (tau : Tau),
    styp d u g tau s ->
    WFC d u g ->
      forall (u' : Upsilon) (g' : Gamma),
        WFC d u' g' ->
        WFC d (u ++ u') (g ++ g') ->
        styp d (u ++ u') (g ++ g') tau s.
Proof.
  intros d u g e tau ltypder.
  apply (styp_ind_mutual
           (fun (d : Delta) (u : Upsilon) (g : Gamma) (t : Tau) (s : St)
                (st : styp d u g t s) =>
              WFC d u g ->
              forall (u' : Upsilon) (g' : Gamma),
                WFC d u' g' ->
                WFC d (u ++ u') (g ++ g') ->
                styp d (u ++ u') (g ++ g') t s)
           (fun (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t : Tau)
                (lt : ltyp d u g  e t) =>
              WFC d u g ->
              forall (u' : Upsilon) (g' : Gamma),
                WFC d u' g' ->
                WFC d (u ++ u') (g ++ g') ->
                ltyp d (u ++ u') (g ++ g') e t)
           (fun (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t : Tau)
                (rt : rtyp d u g e t) =>
              WFC d u g ->
              forall (u' : Upsilon) (g' : Gamma),
                WFC d u' g' ->
                WFC d (u ++ u') (g ++ g') ->
                rtyp d (u ++ u') (g ++ g') e t)).
  Case "styp_e_3_1".
   intros.
   apply styp_e_3_1 with (tau':= tau').
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_return_3_2".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_seq_3_3".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_while_3_4".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "styp_if_3_5".
   intros.
   constructor.
   apply H with (u':= u') (g':= g') in H2; try assumption.
   apply H0 with (u':= u') (g':= g') in H2; try assumption.
   apply H1 with (u':= u') (g':= g') in H2; try assumption.
  Case "styp_let_3_6".
   admit.
   (*
   intros.
   apply styp_let_3_6 with (tau':=tau'); try assumption.
   AdmitAlphaConversion.
   inversion H2; try assumption.
   assert (Z: WFC d0 u0 ([(x, tau')] ++ g0)). (* How do I get this ? *)
   constructor; try assumption.
   constructor; try assumption.

   apply H with (u':= u') (g':= g') in Z; try assumption.
   admit.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
    *)
  Case "styp_open_3_7".
   admit. (* Will have the similar problems with let. *)
  Case "styp_openstar_3_8".
   admit. (* Will have the similar problems with let. *)
  Case "SL_3_1".
   intros.
   apply SL_3_1 with (tau':=tau'); try assumption.
   apply getG_Some_Weakening; try assumption.
   apply gettype_weakening; try assumption.
   inversion H; try assumption.
   inversion H1; try assumption.
  Case "SL_3_2".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SL_3_3".
   intros.
   apply SL_3_3 with (t1:= t1); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SL_3_4".
   intros.
   apply SL_3_4 with (t0:= t0); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_1".
   intros.
   apply SR_3_1 with (tau':= tau'); try assumption.
   apply getG_Some_Weakening; try assumption.
   apply gettype_weakening; try assumption.
   inversion H; try assumption.
   inversion H1; try assumption.
  Case "SR_3_2".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_3".
   intros.
   apply SR_3_3 with (t1:= t1); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_4".
   intros.
   apply SR_3_4 with (t0:= t0); try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_5".
   intros.
   constructor; try assumption.
  Case "SR_3_6".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H0; try assumption.
  Case "SR_3_7".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_8".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_9".
   intros.
   apply SR_3_9 with (tau':= tau'); try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   apply H0 with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_10".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_11".
   intros.
   apply SR_3_11 with (k:=k); try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_12".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
  Case "SR_3_13".
   intros.
   constructor; try assumption.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   AdmitAlphaConversion.
   admit.
   admit.
   apply H with (u':= u') (g':= g') in H1; try assumption.
   admit.
   admit.
  Case "SR_3_14".
   admit.
  Case "base".
   assumption.

Admitted.


(** * Extraction of a counter contract with refinement types to Midlang *)

(** The contract uses refinement types to specify some functional correctness properties *)
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import Serializable.
From ConCert.Extraction Require Import Common.
From ConCert.Extraction Require Import ElmExtract.
From ConCert.Extraction Require Import PrettyPrinterMonad.
From MetaCoq.TypedExtraction Require Import Extraction.
From MetaCoq.TypedExtraction Require Import ResultMonad.
From MetaCoq.Template Require Import Kernames.
From MetaCoq.Template Require Import All.
From Coq Require Import List.
From Coq Require Import Lia.
From Coq Require Import String.
From Coq Require Import ZArith.

Import MCMonadNotation.
Open Scope string.

#[local]
Instance MidlangBoxes : ElmPrintConfig :=
  {| term_box_symbol := "()";
     type_box_symbol := "()";
     any_type_symbol := "()";
     false_elim_def := "false_rec ()";
     print_full_names := false |}.

Definition midlang_translation_map :=
  [(<%% @current_slot %%>, "current_slot");
  (<%% @address_eqb %%>, "address_eq");
  (<%% @ctx_amount %%>, "amount");
  (<%% @ctx_from %%>, "from");
  (<%% @Chain %%>, "ConCertChain");
  (<%% @ContractCallContext %%>, "ConCertCallContext");
  (<%% @ConCert.Execution.Blockchain.ActionBody %%>, "ConCertAction");
  (<%% @ChainBase %%>, "ChainBaseWTF");
  (<%% @ctx_contract_address %%>, "contract_address")].

Definition midlang_translate (name : kername) : option string :=
  match find (fun '(key, _) => eq_kername key name) midlang_translation_map with
  | Some (_, val) => Some val
  | None => None
  end.

Module CounterRefinmentTypes.

  Open Scope Z.
  Definition storage := Z.

  Inductive msg := Inc (_ : Z) | Dec (_ : Z).

  Program Definition inc_counter (st : storage) (inc : {z : Z | 0 <? z}) :
    {new_st : storage | st <? new_st} :=
    st + proj1_sig inc.
  Next Obligation.
    unfold is_true in *.
    rewrite <- Zlt_is_lt_bool in *; lia.
  Qed.

  Program Definition dec_counter (st : storage) (dec : {z : Z | 0 <? z}) :
    {new_st : storage | new_st <? st} :=
    st - proj1_sig dec.
  Next Obligation.
    unfold is_true in *.
    rewrite <- Zlt_is_lt_bool in *; lia.
  Qed.

  Definition my_bool_dec := Eval compute in Bool.bool_dec.

  Inductive SimpleActionBody :=
  | Act_transfer : nat -> Z -> SimpleActionBody.

  Definition Transaction := list SimpleActionBody.
  Definition Transaction_none : Transaction := [].

  Definition counter (msg : msg) (st : storage)
    : option (Transaction * storage) :=
    match msg with
    | Inc i =>
      match (my_bool_dec (0 <? i) true) with
      | left h => Some (Transaction_none, proj1_sig (inc_counter st (exist i h)))
      | right _ => None
      end
    | Dec i =>
      match (my_bool_dec (0 <? i) true) with
      | left h => Some (Transaction_none, proj1_sig (dec_counter st (exist i h)))
      | right _ => None
      end
    end.
End CounterRefinmentTypes.

MetaCoq Run
        (p <- tmQuoteRecTransp (CounterRefinmentTypes.counter) false;;
        tmDefinition "counter_env"%bs p.1).

Definition counter_name := <%% CounterRefinmentTypes.counter %%>.

(** A translation table for various constants we want to rename *)

Definition TT : list (kername * string) := Eval compute in
  [   remap <%% Z.add %%> "add"
    ; remap <%% Z.sub %%> "sub"
    ; remap <%% Z.leb %%> "le"
    ; remap <%% Z.ltb %%> "lt"
    ; remap <%% Z %%> "Int"
    ; ((<%% Z %%>.1, "Z0"%bs),"0")
    ; remap <%% nat %%> "AccountAddress"
    ; remap <%% CounterRefinmentTypes.Transaction %%> "Transaction"
    ; remap <%% CounterRefinmentTypes.Transaction_none %%> "Transaction.none"
    ; remap <%% bool %%> "Bool" ].

Definition midlang_counter_translate (name : kername) : option string :=
  match find (fun '(key, _) => eq_kername key name) (TT ++ midlang_translation_map) with
  | Some (_, val) => Some val
  | None => None
  end.

Definition ignored_concert_types :=
  Eval compute in
        [<%% @ActionBody %%>;
         <%% @Address %%>;
         <%% @Amount %%>;
         <%% @ChainBase %%>;
         <%% @Chain %%>;
         <%% @ContractCallContext %%>;
         <%% @SerializedValue %%>].

Definition counter_extract :=
    Eval vm_compute in
    extract_template_env_within_coq
      counter_env
      (KernameSet.singleton counter_name)
      (fun kn => List.existsb (eq_kername kn)
                              (ignored_concert_types
                                 ++ map fst midlang_translation_map
                                 ++ map fst TT)).

Definition counter_result := Eval compute in
     (env <- counter_extract ;;
      '(_, lines) <- finish_print_lines (print_env env midlang_counter_translate);;
      ret lines).

Definition wrap_in_delimiters s :=
  concat Common.nl [""; "{-START-} "; s; "{-END-}"].

Definition midlang_prelude :=
   ["import Basics exposing (..)";
    "import Blockchain exposing (..)";
    "import Bool exposing (..)";
    "import Int exposing (..)";
    "import Maybe exposing (..)";
    "import Order exposing (..)";
    "import Transaction exposing (..)";
    "import Tuple exposing (..)"].

MetaCoq Run (match counter_result with
             | Ok s => tmMsg "Extraction of counter succeeded"%bs
             | Err err => tmFail (String.of_string err)
             end).

Definition midlang_counter :=
  match counter_result with
  | Ok s => monad_map tmMsg (map String.of_string (midlang_prelude ++ s))
  | Err s => tmFail (String.of_string s)
  end.

Redirect "../extraction/tests/extracted-code/midlang-extract/CounterRefTypesMidlang.midlang"
  MetaCoq Run midlang_counter.


Require Import Coqlib.
Require Import ITreelib.
Require Import ImpPrelude.
Require Import STS.
Require Import Behavior.
Require Import ModSem.
Require Import Skeleton.
Require Import IntroHeader.

Set Implicit Arguments.

(***
F.f(n) {
  if (n < 0) {
    r := -1
  } else if (n == 0) {
    r := ...
  } else {
    r := 5 * Ncall P Q G.g(n)
  }
  r
}
***)

Section PROOF.

  Definition fF: list val -> itree Es val :=
    fun varg =>
      `n: Z <- (pargs [Tint] varg)?;;
      assume (intrange_64 n);;;
      if (n <? 0)%Z
      then `_: val <- ccallU "log" [Vint n];; Ret (Vint (- 1))
      else if (n =? 0)%Z
           then Ret (Vint 0)
           else r <- (Ncall True (fun r => r = Vint (5 * n - 2)) "g" [Vint n]);;
                res <- (vadd (Vint 2) r)?;;
                Ret res
  .

  (* Definition Ncall {X Y} (f: string) (x: X): itree Es Y := *)
  (*   `b: bool <- trigger (Choose bool);; *)
  (*   if b then ccallU f x else trigger (Choose _) *)
  (* . *)

  (* Definition fF: list val -> itree Es val := *)
  (*   fun varg => *)
  (*     `n: Z <- (pargs [Tint] varg)?;; *)
  (*     assume (intrange_64 n);;; *)
  (*     assume ((Z.to_nat n) < max);;; *)
  (*     if (n <? 0)%Z *)
  (*     then `_: val <- ccallU "log" [Vint n];; Ret (Vint (- 1)) *)
  (*     else if (n =? 0)%Z *)
  (*          then Ret (Vint 0) *)
  (*          else (Ncall "g" [Vint n]) *)
  (* . *)

  Definition FSem: ModSem.t := {|
    ModSem.fnsems := [("f", cfunU fF)];
    ModSem.mn := "F";
    ModSem.initial_st := tt↑;
  |}
  .

  Definition F: Mod.t := {|
    Mod.get_modsem := fun _ => FSem;
    Mod.sk := [("f", Sk.Gfun)];
  |}
  .

End PROOF.


(** * A box to decrypt data (part of TCB) *)
Require Import Coq.Program.Basics Coq.Strings.String.
Require Import FunctionApp EncryptionInterface.

Local Open Scope program_scope.

Set Implicit Arguments.

(** ** Summary

    We implement a box that decrypts data:

<<
                      ┌─────────┐
    encrypted data in │         │
    ----------------> │         │ unencrypted data out
                      │ Decrypt │ -------------------->
    set master key    │   Box   │
    ----------------> │         │
                      │         │
                      └─────────┘

>> *)

Module TrustedDecryptBox (DataTypes : EncryptionDataTypes) (Algorithm : EncryptionAlgorithm DataTypes).
  Import DataTypes.

  Section trustedDecryptBox.
    (** Because the box is asynchronous, we enable tagging data with
        identifiers.  The identifiers are passed unchanged with the
        encrypted data. *)

    Variable dataTagT : Type.

    Record DecryptBoxState :=
      { masterKey : option { key : masterKeyT | Algorithm.isValidMasterKey key = true } }.

    Inductive dbInput :=
    | dbSetMasterKey (key : masterKeyT)
    | dbDecrypt (encryptedData : encryptedDataT) (tag : dataTagT).

    Inductive dbErrorOutput :=
    | dbErrorInvalidData (data : encryptedDataT) (tag : dataTagT)
    | dbErrorInvalidMasterKey (key : masterKeyT) (pf : Algorithm.isValidMasterKey key = false)
    | dbErrorNoMasterKey.

    Inductive dbEventOutput :=
    | dbDecrypted (data : rawDataT) (tag : dataTagT).

    Definition dbOutput := (dbErrorOutput + dbEventOutput)%type.

    Context (world : Type)
            (handle : dbOutput -> action world).

    Definition initState : DecryptBoxState :=
      {| masterKey := None |}.

    Definition decryptBoxLoopPreBody
               (st : DecryptBoxState)
    : dbInput -> option dbOutput * DecryptBoxState
      := fun i =>
           match i with

             | dbSetMasterKey key
               => match Sumbool.sumbool_of_bool (Algorithm.isValidMasterKey key) with
                    | left pf => (None,
                                  {| masterKey := Some (exist _ key pf) |})
                    | right pf => (Some (inl (@dbErrorInvalidMasterKey key pf)),
                                   {| masterKey := None |})
                  end
             | dbDecrypt data tag
               => (match st.(masterKey) with
                     | None => Some (inl dbErrorNoMasterKey)
                     | Some (exist key pf)
                       => match Algorithm.decrypt key pf data with
                            | inl rawData => Some (inr (dbDecrypted rawData tag))
                            | inr InvalidEncryptedData => Some (inl (dbErrorInvalidData data tag))
                          end
                   end,
                   st)
           end.

    Definition decryptBoxLoopBody {T}
               (decryptBoxLoop : DecryptBoxState -> T)
               (st : DecryptBoxState)
    : dbInput -> action world * T
      := fun i => let outs := fst (decryptBoxLoopPreBody st i) in
                  (match outs with
                     | None => id
                     | Some out => handle out
                   end,
                   decryptBoxLoop (snd (decryptBoxLoopPreBody st i))).

    CoFixpoint decryptBoxLoop (st : DecryptBoxState) :=
      Step (decryptBoxLoopBody decryptBoxLoop st).

    Definition decryptBox : process _ _ := decryptBoxLoop initState.
  End trustedDecryptBox.
End TrustedDecryptBox.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require map.Map.

(* Why3 assumption *)
Definition unit  := unit.

(* Why3 assumption *)
Inductive ref (a:Type) {a_WT:WhyType a} :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a] [a_WT]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a}(v:(ref a)): a :=
  match v with
  | (mk_ref x) => x
  end.

Axiom pointer : Type.
Parameter pointer_WhyType : WhyType pointer.
Existing Instance pointer_WhyType.

Axiom pointer_dec : forall (p1:pointer) (p2:pointer), (p1 = p2) \/
  ~ (p1 = p2).

(* Why3 assumption *)
Definition next  := (map.Map.map pointer pointer).

Parameter null: pointer.

(* Why3 assumption *)
Inductive is_list : (map.Map.map pointer pointer) -> pointer -> Prop :=
  | is_list_null : forall (next1:(map.Map.map pointer pointer)) (p:pointer),
      (p = null) -> (is_list next1 p)
  | is_list_next : forall (next1:(map.Map.map pointer pointer)) (p:pointer),
      (~ (p = null)) -> ((is_list next1 (map.Map.get next1 p)) ->
      (is_list next1 p)).

Axiom ft : forall (a:Type) {a_WT:WhyType a}, Type.
Parameter ft_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ft a).
Existing Instance ft_WhyType.

Parameter in_ft: pointer -> (ft pointer) -> Prop.

Axiom set_eq : forall (ft1:(ft pointer)) (ft2:(ft pointer)),
  (forall (q:pointer), (in_ft q ft1) <-> (in_ft q ft2)) -> (ft1 = ft2).

Parameter list_ft: (map.Map.map pointer pointer) -> pointer -> (ft pointer).

Axiom list_ft_node_null_cor : forall (next1:(map.Map.map pointer pointer))
  (q:pointer) (p:pointer), (q = null) -> ~ (in_ft p (list_ft next1 q)).

Axiom list_ft_node_next1 : forall (next1:(map.Map.map pointer pointer))
  (q:pointer) (p:pointer), (~ (q = null)) -> ((is_list next1
  (map.Map.get next1 q)) -> ((in_ft p (list_ft next1 (map.Map.get next1
  q))) -> (in_ft p (list_ft next1 q)))).

Axiom list_ft_node_next2 : forall (next1:(map.Map.map pointer pointer))
  (q:pointer), (~ (q = null)) -> ((is_list next1 (map.Map.get next1 q)) ->
  (in_ft q (list_ft next1 q))).

Axiom list_ft_node_next_inv : forall (next1:(map.Map.map pointer pointer))
  (q:pointer) (p:pointer), (~ (q = null)) -> ((is_list next1
  (map.Map.get next1 q)) -> ((~ (q = p)) -> ((in_ft p (list_ft next1 q)) ->
  (in_ft p (list_ft next1 (map.Map.get next1 q)))))).

(* Why3 goal *)
Theorem frame_list : forall (next1:(map.Map.map pointer pointer)) (p:pointer)
  (q:pointer) (v:pointer), (~ (in_ft q (list_ft next1 p))) -> ((is_list next1
  p) -> (is_list (map.Map.set next1 q v) p)).
Proof.
intros.
induction H0.
apply (is_list_null _ _ H0).
apply (is_list_next _ _ H0).
assert (q<>p) by (intro eq;apply H;rewrite eq;clear eq;apply (list_ft_node_next2 _ _ H0 H1)).
rewrite (Map.Select_neq _ _ _ _ H2).
apply IHis_list.
contradict H.
exact (list_ft_node_next1 _ _ _ H0 H1 H).
Qed.


From synrl Require Import Preamble Coequalizer.

Set Primitive Projections.

Class Modal (P : Type → Prop) (A : Type) : Prop :=
  mod : P A.

Definition connected (P : Type → Prop) (A : Type) : Prop :=
  ∀ B, Modal P B → @is_isomorphism B (A → B) const.

Class RepleteSubuniverse (P : Type → Prop) :=
  replete : ∀ A B (f : A → B), is_isomorphism f → P A → P B.

Arguments replete P {_} A [B] f iso : rename.

Class LexSubuniverse P : Prop :=
  {connected_eq : ∀ A, connected P A → ∀ x y : A, connected P (x = y)}.

Class DenseSubuniverse (P : Type → Prop) : Prop :=
  {modal_false : P False}.

Class RegularSubuniverse (P : Type → Prop) : Prop :=
  {modal_exists : ∀ A (B : A → Prop), P A → (∀ x : A, P (B x)) → P (∃ x : A, B x)}.

Module Mod.
  Class ModalOperator (P : Type → Prop) :=
    {T : Type → Type;
     modal : ∀ {A}, P (T A);
     unit : ∀ {A}, A → T A}.

  (** A dependent idempotent modality will support a dependent elimination rule, and will be closed under sigma types. *)
  Class DepModality (P : Type → Prop) :=
    {DepModality_Operator :> ModalOperator P;
     DepModality_RepleteSubuniverse :> RepleteSubuniverse P;
     depmod_ump : ∀ {A B} `{∀ x, Modal P (B x)}, @is_isomorphism (∀ x : T A, B x) (∀ x : A, B (unit x)) (λ f a, f (unit a))}.

  (** A simple idempotent modality will support a simple elimination rule, and will be closed under product types. *)
  Class SimpleModality (P : Type → Prop) :=
    {SimpleModality_Operator :> ModalOperator P;
     SimpleModality_RepleteSubuniverse :> RepleteSubuniverse P;
     simpmod_ump : ∀ {A B} `{Modal P B}, @is_isomorphism (T A → B) (A → B) (λ f, f ∘ unit)}.

  Arguments T P {_}.

  Section Dep.
    Context {P} `{DepModality P}.

    Definition ind {A} (B : T P A → Type) `{∀ x : T P A, Modal P (B x)} (f : ∀ x : A, B (unit x)) : ∀ x : T P A, B x.
    Proof. by apply: iso_inv _ depmod_ump _. Defined.

    Lemma ind_beta {A B} `{∀ x : T P A, Modal P (B x)} (f : ∀ x : A, B (unit x)) (a : A) : ind B f (unit a) = f a.
    Proof.
      case: (depmod_ump f)=> f' [h1 h2].
      rewrite -h1.
      move: (unit a).
      apply: equal_f_dep.
      by apply: funcompr_compute.
    Qed.

    Global Instance Dep_to_Simple : SimpleModality P.
    Proof.
      unshelve esplit.
      - apply: DepModality_RepleteSubuniverse.
      - move=> A B ?.
        abstract apply: depmod_ump.
    Defined.
  End Dep.

  Section Simple.
    Context {P} `{SimpleModality P}.

    Global Instance Modal_T {A} : Modal P (T P A).
    Proof. by apply: modal. Qed.

    Definition rec {A B} `{Modal P B} (f : A → B) : T P A → B.
    Proof. by apply: iso_inv _ simpmod_ump _. Defined.

    Lemma rec_beta {A B} `{Modal P B} (f : A → B) (a : A) : rec f (unit a) = f a.
    Proof.
      case: (simpmod_ump f)=> f' [h1 h2].
      rewrite -h1 /comp.
      move: (unit a).
      apply: equal_f.
      by apply: funcompr_compute.
    Qed.

    Opaque rec.

    Definition alg {A} `{Modal P A} : T P A → A.
    Proof. by apply: rec. Defined.

    Lemma alg_beta {A} `{Modal P A} : ∀ x : A, alg (unit x) = x.
    Proof. by move=>?; rewrite /alg rec_beta. Qed.

    Lemma alg_eta {A} `{Modal P A} : ∀ x : T P A, x = unit (alg x).
    Proof.
      apply: equal_f.
      apply: (iso_injective _ simpmod_ump).
      apply: funext=> x//=.
      by rewrite alg_beta.
    Qed.

    Opaque alg.

    Lemma alg_iso {A} `{Modal P A} : @is_isomorphism (T P A) A alg.
    Proof.
      move=> x.
      exists (unit x); split.
      - by rewrite alg_beta.
      - move=> x' <-.
        by rewrite -alg_eta.
    Qed.

    Lemma unit_iso_to_modal {A} : is_isomorphism (unit : A → T P A) → Modal P A.
    Proof.
      move=> iso.
      rewrite /Modal.
      apply: (replete P _ (iso_inv _ iso)).
      - apply: iso_inv_iso.
      - apply: modal.
    Qed.
  End Simple.
End Mod.

Section Instances.
  Context {P} `{LexSubuniverse P} `{DenseSubuniverse P} `{RegularSubuniverse P}.

  Global Instance Modal_false : Modal P False.
  Proof. by apply: modal_false. Qed.

  Global Instance Modal_exists {A} {B : A → Prop} `{Modal P A} `{∀ x : A, Modal P (B x)} : Modal P (∃ x : A, B x).
  Proof. by apply: modal_exists. Qed.
End Instances.

Section SimpleInstances.
  Context {P} `{Mod.SimpleModality P}.

  Global Instance Modal_true : Modal P True.
  Proof.
    apply: Mod.unit_iso_to_modal.
    move=> x.
    exists I; split.
    - move: x.
      apply: equal_f.
      apply: (iso_injective _ Mod.simpmod_ump).
      by apply: funext; case.
    - by case.
  Qed.

  Global Instance Modal_prod {A B} `{Modal P A} `{Modal P B} : Modal P (A * B).
  Proof.
    apply: Mod.unit_iso_to_modal=> p.
    unshelve esplit.
    - split.
      + apply: Mod.alg; move: p; apply: Mod.rec.
        move=> p; apply: Mod.unit; move: p.
        apply: fst.
      + apply: Mod.alg; move: p; apply: Mod.rec.
        move=> p; apply: Mod.unit; move: p.
        apply: snd.
    - split.
      + move: p.
        apply: equal_f.
        apply: (iso_injective _ Mod.simpmod_ump).
        apply: funext=> x//=.
        congr Mod.unit.
        rewrite ?Mod.rec_beta ?Mod.alg_beta.
        by case: x.
      + case=> x y <-.
        by rewrite ?Mod.rec_beta ?Mod.alg_beta.
  Qed.

  Global Instance Modal_and {A B : Prop} `{Modal P A} `{Modal P B} : Modal P (A ∧ B).
  Proof.
    rewrite /Modal.
    apply: (replete P (A * B)).
    - by move=> p; split; move: p; [apply: fst | apply: snd].
    - move=> ? p.
      unshelve esplit=>//.
      split; move: p; [apply: proj1 | apply: proj2].
    - change P with (Modal P).
      typeclasses eauto.
  Qed.

  Global Instance Modal_fun {A B} `{Modal P B} : Modal P (A → B).
  Proof.
    apply: Mod.unit_iso_to_modal=> f.
    unshelve esplit.
    - move=> a.
      move: f.
      apply: Mod.rec.
      by apply.
    - split.
      + move: f.
        apply: equal_f.
        apply: (iso_injective _ Mod.simpmod_ump).
        apply: funext=> f//=.
        congr Mod.unit.
        apply: funext=> x.
        by rewrite Mod.rec_beta.
      + move=> f' <-.
        apply: funext=>?.
        by rewrite Mod.rec_beta.
  Qed.

  Global Instance IsProp_T {A} `{IsProp A} : IsProp (Mod.T P A).
  Proof.
    move=> x.
    apply: equal_f.
    move: x.
    apply: equal_f.
    apply: (iso_injective _ Mod.simpmod_ump).
    apply: funext=> x//=.
    apply: (iso_injective _ Mod.simpmod_ump).
    apply: funext=> y //=.
    congr Mod.unit.
    apply: irr.
  Qed.

  Global Instance Modal_eq {A} {x y : A} `{Modal P A} : Modal P (x = y).
  Proof.
    apply: Mod.unit_iso_to_modal=> e.
    unshelve esplit.
    - move: e.
      apply: equal_f.
      apply: (iso_injective _ Mod.simpmod_ump).
      by apply: funext=>//=.
    - split=>//=.
      apply: irr.
  Qed.

  Global Instance Modal_not {A} `{DenseSubuniverse P} : Modal P (not A).
  Proof. by rewrite /not; typeclasses eauto. Qed.
End SimpleInstances.

Section DepInstances.
  Context {P} `{Mod.DepModality P}.

  Global Instance Modal_T {A} : Modal P (Mod.T P A).
  Proof. by apply: Mod.modal. Defined.

  Global Instance Modal_pi {A B} `{∀ x : A, Modal P (B x)} : Modal P (∀ x : A, B x).
  Proof.
    apply: Mod.unit_iso_to_modal=> f.
    unshelve esplit.
    - move=> a.
      move: f.
      apply: Mod.rec.
      by apply.
    - split.
      + move: f.
        apply: equal_f_dep.
        apply: (iso_injective _ Mod.simpmod_ump).
        rewrite /comp //=.
        apply: funext=> ?; f_equal.
        apply: depfunext=> x.
        by rewrite Mod.rec_beta.
      + move=> f' <-.
        apply: depfunext=> x.
        by rewrite Mod.rec_beta.
  Qed.

  Global Instance Modal_sg {A B} `{Modal P A} `{∀ x : A, Modal P (B x)} : Modal P {x : A & B x}.
  Proof.
    apply: Mod.unit_iso_to_modal=> p.
    unshelve esplit.
    - unshelve esplit.
      + apply: Mod.alg; move: p.
        apply: Mod.rec=> u.
        apply: Mod.unit.
        move: u.
        apply: projT1.
      + apply: Mod.alg; move: p.
        apply: Mod.ind; case=> a b.
        apply: Mod.unit.
        rewrite (_ : (Mod.alg _) = a) //=.
        abstract by rewrite Mod.rec_beta Mod.alg_beta.
      - split=>//=.
        + move: p.
          apply: equal_f_dep.
          apply: (iso_injective _ Mod.simpmod_ump).
          apply: funext; case=> a b //=.
          congr Mod.unit.
          apply: eq_sigT=>//=.
          * by rewrite Mod.rec_beta Mod.alg_beta.
          * move=> ?.
            rewrite Mod.ind_beta Mod.alg_beta rew_compose.
            by simplify_eqs.
        + case=> a b//= <-.
          apply: eq_sigT=>//=.
          * by rewrite Mod.rec_beta Mod.alg_beta.
          * move=> ?.
            rewrite Mod.ind_beta Mod.alg_beta rew_compose.
            by simplify_eqs.
  Qed.
End DepInstances.

Module ModP.
  Definition T P `{Mod.ModalOperator P} (A : Prop) := PropTrunc.T (Mod.T P A).

  Lemma unit {P} `{Mod.ModalOperator P} {A : Prop} : A → T P A.
  Proof. by move/Mod.unit/PropTrunc.unit. Defined.

  Section Dep.
    Context {P} `{Mod.DepModality P}.

    Definition ind {A} (B : T P A → Type) `{∀ x : T P A, Modal P (B x)} (f : ∀ x : A, B (unit x)) : ∀ x : T P A, B x.
    Proof.
      move=> a.
      rewrite -[a]PropTrunc.alg_eta.
      move: (PropTrunc.alg a).
      by apply/Mod.ind/f.
    Defined.

    Lemma ind_beta {A B} `{∀ x : T P A, Modal P (B x)} (f : ∀ x : A, B (unit x)) (a : A) : ind B f (unit a) = f a.
    Proof.
      apply: JMeq_eq.
      rewrite /ind /unit; simplify_eqs.
      by rewrite PropTrunc.alg_beta Mod.ind_beta.
    Qed.

    Opaque ind.
  End Dep.

  Section Simple.
    Context {P} `{Mod.SimpleModality P}.

    Global Instance Modal_T {A} : Modal P (T P A).
    Proof.
      apply: Mod.unit_iso_to_modal=> p.
      unshelve esplit.
      - apply: PropTrunc.unit.
        move: p.
        apply: Mod.rec.
        apply: (@PropTrunc.rec (Mod.T P A) (Mod.T P A) _ id).
      - split=>//=.
        apply: irr.
    Qed.

    Definition rec {A : Prop} {B} `{Modal P B} (f : A → B) : T P A → B.
    Proof.
      move/PropTrunc.alg.
      by apply/Mod.rec/f.
    Defined.

    Lemma rec_beta {A : Prop} {B} `{Modal P B} (f : A → B) (a : A) : rec f (unit a) = f a.
    Proof. by rewrite /rec /unit PropTrunc.alg_beta Mod.rec_beta. Qed.

    Opaque rec.
  End Simple.
End ModP.

Section SeparatedReflection.
  Context P `{Mod.DepModality P}.

  Definition separated (P : Type → Prop) : Type → Prop :=
    λ A, ∀ x y : A, P (x = y).

  Instance separated_replete : RepleteSubuniverse (separated P).
  Proof.
    move=> A B f iso sepA x y.
    pose g := iso_inv f iso.
    apply: (replete P (g x = g y)).
    - by apply/iso_injective/iso_inv_iso.
    - move=> ? h.
      unshelve esplit=>//.
      by rewrite h.
    - by apply: sepA.
  Qed.

  Definition modally_eq (A : Type) (x y : A) : Prop :=
    ModP.T P (x = y).

  Global Instance Reflexive_modally_eq {A} : RelationClasses.Reflexive (modally_eq A).
  Proof. by move=>?; apply: ModP.unit. Qed.

  Global Instance Symmetric_modally_eq {A} : RelationClasses.Symmetric (modally_eq A).
  Proof. by move=>??; apply: ModP.rec=>->; apply: ModP.unit. Qed.

  Global Instance Transitive_modally_eq {A} : RelationClasses.Transitive (modally_eq A).
  Proof. by move=> ???; apply: ModP.rec=>->. Qed.

  Global Instance Equivalence_modally_eq {A} : RelationClasses.Equivalence (modally_eq A).
  Proof. by split; typeclasses eauto. Qed.

  Definition Sep A := Quotient.T A (modally_eq A).

  Notation Separated := (Modal (separated P)).

  Global Instance Separated_Sep {A} : Separated (Sep A).
  Proof.
    apply: Quotient.indp=> x.
    apply: Quotient.indp=> y.
    apply: (replete P _ Quotient.glue).
    - by apply: Quotient.glue_is_iso.
    - by apply: ModP.Modal_T.
  Qed.

  Global Instance separated_ModalOperator : Mod.ModalOperator (separated P).
  Proof.
    unshelve esplit.
    - by apply: Sep.
    - by move=>?; apply: Separated_Sep.
    - by move=>?; apply: Quotient.intro.
  Defined.

  Global Instance Modal_EqOfSeparated {A} `{Separated A} {x y : A} : Modal P (x = y).
  Proof. by apply: (mod x y). Qed.

  Global Instance DepModality_separated : Mod.DepModality (separated P).
  Proof.
    unshelve esplit; first by typeclasses eauto.
    move=> A B HB f.
    unshelve esplit.
    - unshelve apply: Quotient.ind.
      + by apply: f.
      + by move=>??; apply: ModP.ind=>?; simplify_eqs.
    - split=>//=.
      move=> h <-.
      by apply: depfunext; apply: Quotient.indp.
  Defined.
End SeparatedReflection.

Notation Separated := (λ P, Modal (separated P)).


(* This includes everything that should be defined in GHC/Base.hs, but cannot
   be generated from Base.hs.

The types defined in GHC.Base:

  list, (), Int, Bool, Ordering, Char, String

are all mapped to corresponding Coq types. Therefore, the Eq/Ord classes must
be defined in this module so that we can create instances for these types.

 *)

(********************* Types ************************)

Require Export GHC.Prim.

Require Export GHC.Tuple.

(* List notation *)
Require Export Coq.Lists.List.

(* Booleans *)
Require Export Bool.Bool.

(* Int and Integer types *)
Require NArith.
Require Import ZArith.
Require Export GHC.Num.

(* Char type *)
Require Export GHC.Char.
Definition unsafeChr := Z.to_N.
Definition ord := Z.of_N.

(* Strings *)
Require Coq.Strings.String.
Definition String := list Char.

Bind Scope string_scope with String.string.
Fixpoint hs_string__ (s : String.string) : String :=
  match s with
  | String.EmptyString => nil
  | String.String c s  => &#c :: hs_string__ s
  end.
Notation "'&' s" := (hs_string__ s) (at level 1, format "'&' s").

(* IO --- PUNT *)
Definition FilePath := String.

(* ASZ: I've been assured that this is OK *)
Inductive IO (a : Type) : Type :=.
Inductive IORef (a : Type) : Type :=.
Inductive IOError : Type :=.

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

(* function composition *)
Require Export Coq.Program.Basics.

Notation "[,]"  := (fun x y => (x,y)).
Notation "[,,]" := (fun x0 y1 z2 => (x0, y1, z2)).
Notation "[,,,]" := (fun x0 x1 x2 x3 => (x0,x1,x2,x3)).
Notation "[,,,,]" := (fun x0 x1 x2 x3 x4 => (x0,x1,x2,x3,x4)).
Notation "[,,,,,]" := (fun x0 x1 x2 x3 x4 x5 => (x0,x1,x2,x3,x4,x5)).
Notation "[,,,,,,]" := (fun x0 x1 x2 x3 x4 x5 x6 => (x0,x1,x2,x3,x4,x5,x6)).
Notation "[,,,,,,,]" := (fun x0 x1 x2 x3 x4 x5 x6 x7 => (x0,x1,x2,x3,x4,x5,x6,x7)).

Notation "'_++_'"   := (fun x y => x ++ y).
Notation "'_::_'"   := (fun x y => x :: y).

Notation "[->]"  := arrow.

(* Configure type argument to be maximally inserted *)
Arguments List.app {_} _ _.

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

Definition Synonym {A : Type} (_uniq : Type) (x : A) : A := x.
Arguments Synonym {A}%type _uniq%type x%type.

(*********** built in classes Eq & Ord **********************)

(* Don't clash with Eq constructor for the comparison type. *)
Record Eq___Dict a := Eq___Dict_Build {
  op_zeze____ : (a -> (a -> bool)) ;
  op_zsze____ : (a -> (a -> bool)) }.

Definition Eq_ a := forall r, (Eq___Dict a -> r) -> r.
Existing Class Eq_.

Definition op_zeze__ {a} {g : Eq_ a} := g _ (op_zeze____ _).
Definition op_zsze__ {a} {g : Eq_ a} := g _ (op_zsze____ _).

Notation "'_/=_'" := (op_zsze__).
Infix "/=" := (op_zsze__) (no associativity, at level 70).
Notation "'_==_'" := (op_zeze__).
Infix "==" := (op_zeze__) (no associativity, at level 70).

Definition eq_default {a} (eq : a -> a -> bool) : Eq_ a :=
  fun _ k => k {|op_zeze____ := eq; op_zsze____ := fun x y => negb (eq x y) |}.

Record Ord__Dict a := Ord__Dict_Build {
  op_zl____ : a -> a -> bool ;
  op_zlze____ : a -> a -> bool ;
  op_zg____ : a -> a -> bool ;
  op_zgze____ : a -> a -> bool ;
  compare__ : a -> a -> comparison ;
  max__ : a -> a -> a ;
  min__ : a -> a -> a }.

Definition Ord a `{Eq_ a} :=
  forall r, (Ord__Dict a -> r) -> r.

Existing Class Ord.

Definition op_zl__ `{g : Ord a} : a -> a -> bool :=
  g _ (op_zl____ a).

Definition op_zlze__ `{g : Ord a} : a -> a -> bool :=
  g _ (op_zlze____ a).

Definition op_zg__ `{g : Ord a} : a -> a -> bool :=
  g _ (op_zg____ a).

Definition op_zgze__ `{g : Ord a} : a -> a -> bool :=
  g _ (op_zgze____ a).

Definition compare `{g : Ord a} : a -> a -> comparison :=
  g _ (compare__ a).

Definition max `{g : Ord a} : a -> a -> a :=
  g _ (max__ a).

Definition min `{g : Ord a} : a -> a -> a :=
  g _ (min__ a).

Notation "'_<_'" := (op_zl__).
Infix "<" := (op_zl__) (no associativity, at level 70).

Notation "'_<=_'" := (op_zlze__).
Infix "<=" := (op_zlze__) (no associativity, at level 70).

Notation "'_>_'" := (op_zg__).
Infix ">" := (op_zg__) (no associativity, at level 70).

Notation "'_>=_'" := (op_zgze__).
Infix ">=" := (op_zgze__) (no associativity, at level 70).

(*********** Eq/Ord for primitive types **************************)

Instance Eq_Int___ : Eq_ Int := fun _ k => k {|
                               op_zeze____ := fun x y => (x =? y)%Z;
                               op_zsze____ := fun x y => negb (x =? y)%Z;
                               |}.

Instance Ord_Int___ : Ord Int := fun _ k => k {|
  op_zl____   := fun x y => (x <? y)%Z;
  op_zlze____ := fun x y => (x <=? y)%Z;
  op_zg____   := fun x y => (y <? x)%Z;
  op_zgze____ := fun x y => (y <=? x)%Z;
  compare__   := Z.compare%Z ;
  max__       := Z.max%Z;
  min__       := Z.min%Z;
|}.

Instance Eq_Integer___ : Eq_ Integer := fun _ k => k {|
                               op_zeze____ := fun x y => (x =? y)%Z;
                               op_zsze____ := fun x y => negb (x =? y)%Z;
                             |}.

Instance Ord_Integer___ : Ord Integer := fun _ k => k {|
  op_zl____   := fun x y => (x <? y)%Z;
  op_zlze____ := fun x y => (x <=? y)%Z;
  op_zg____   := fun x y => (y <? x)%Z;
  op_zgze____ := fun x y => (y <=? x)%Z;
  compare__   := Z.compare%Z ;
  max__       := Z.max%Z;
  min__       := Z.min%Z;
|}.

Instance Eq_Word___ : Eq_ Word := fun _ k => k {|
                               op_zeze____ := fun x y => (x =? y)%N;
                               op_zsze____ := fun x y => negb (x =? y)%N;
                             |}.

Instance Ord_Word___ : Ord Word := fun _ k => k {|
  op_zl____   := fun x y => (x <? y)%N;
  op_zlze____ := fun x y => (x <=? y)%N;
  op_zg____   := fun x y => (y <? x)%N;
  op_zgze____ := fun x y => (y <=? x)%N;
  compare__   := N.compare%N ;
  max__       := N.max%N;
  min__       := N.min%N;
|}.

Instance Eq_Char___ : Eq_ Char := fun _ k => k {|
                               op_zeze____ := fun x y => (x =? y)%N;
                               op_zsze____ := fun x y => negb (x =? y)%N;
                             |}.

Instance Ord_Char___ : Ord Char := fun _ k => k {|
  op_zl____   := fun x y => (x <? y)%N;
  op_zlze____ := fun x y => (x <=? y)%N;
  op_zg____   := fun x y => (y <? x)%N;
  op_zgze____ := fun x y => (y <=? x)%N;
  compare__   := N.compare%N ;
  max__       := N.max%N;
  min__       := N.min%N;
|}.

Instance Eq_bool___ : Eq_ bool := fun _ k => k {|
                               op_zeze____ := eqb;
                               op_zsze____ := fun x y => negb (eqb x y);
                             |}.

Definition compare_bool (b1:bool)(b2:bool) : comparison :=
  match b1 , b2 with
  | true , true => Eq
  | false, false => Eq
  | true , false => Gt
  | false , true => Lt
  end.

Instance Ord_bool___ : Ord bool := fun _ k => k {|
  op_zl____   := fun x y => andb (negb x) y;
  op_zlze____ := fun x y => orb (negb x) y;
  op_zg____   := fun x y => orb (negb y) x;
  op_zgze____ := fun x y => andb (negb y) x;
  compare__   := compare_bool;
  max__       := orb;
  min__       := andb
|}.

Instance Eq_unit___ : Eq_ unit := fun _ k => k {|
                               op_zeze____ := fun x y => true;
                               op_zsze____ := fun x y => false;
                             |}.

Instance Ord_unit___ : Ord unit := fun _ k => k {|
  op_zl____   := fun x y => false;
  op_zlze____ := fun x y => true;
  op_zg____   := fun x y => false;
  op_zgze____ := fun x y => true;
  compare__   := fun x y => Eq ;
  max__       := fun x y => tt;
  min__       := fun x y => tt;
|}.

Definition eq_comparison (x : comparison) (y: comparison) :=
  match x , y with
  | Eq, Eq => true
  | Gt, Gt => true
  | Lt, Lt => true
  | _ , _  => false
end.

Instance Eq_comparison___ : Eq_ comparison := fun _ k => k
{|
  op_zeze____ := eq_comparison;
  op_zsze____ := fun x y => negb (eq_comparison x y);
|}.

Definition compare_comparison  (x : comparison) (y: comparison) :=
  match x , y with
  | Eq, Eq => Eq
  | _, Eq  => Gt
  | Eq, _  => Lt
  | Lt, Lt => Eq
  | _, Lt  => Lt
  | Lt, _  => Gt
  | Gt, Gt => Eq
end.

Definition ord_default {a} (comp : a -> a -> comparison) `{Eq_ a} : Ord a :=
  fun _ k => k (Ord__Dict_Build _
  (fun x y => (comp x y) == Lt)
  ( fun x y => negb ((comp y x) == Lt))
  (fun x y => (comp y x) == Lt)
  (fun x y => negb ((comp x y) == Lt))
  comp
  (fun x y =>
     match comp x y with
     | Lt => y
     | _  => x
     end)
  (fun x y =>   match comp x y with
             | Gt => y
             | _  => x
             end)).

Instance Ord_comparison___ : Ord comparison := ord_default compare_comparison.

Definition eq_pair {t1} {t2} `{Eq_ t1} `{Eq_ t2} (a b : (t1 * t2)) :=
  match a, b with
  | (a1, a2), (b1, b2) =>
    (a1 == b1) && (a2 == b2)
  end.

Definition compare_pair {t1} {t2} `{Ord t1} `{Ord t2} (a b : (t1 * t2)) :=
  match a, b with
  | (a1, a2), (b1, b2) =>
    match compare a1 b1 with
    | Lt => Lt
    | Gt => Gt
    | Eq => compare a2 b2
    end
  end.

Instance Eq_pair___ {a} {b} `{Eq_ a} `{Eq_ b} : Eq_ (a * b) := fun _ k => k
  {| op_zeze____ := eq_pair;
     op_zsze____ := fun x y => negb (eq_pair x y)
  |}.

Instance Ord_pair___ {a} {b} `{Ord a} `{Ord b} : Ord (a * b) :=
  ord_default compare_pair.

(* TODO: are these available in a library somewhere? *)
Definition eqlist {a} `{Eq_ a} : list a -> list a -> bool :=
	fix eqlist xs ys :=
	    match xs , ys with
	    | nil , nil => true
	    | x :: xs' , y :: ys' => andb (x == y) (eqlist xs' ys')
	    | _ ,  _ => false
	    end.

Fixpoint compare_list {a} `{Ord a} (xs :  list a) (ys : list a) : comparison :=
    match xs , ys with
    | nil , nil => Eq
    | nil , _   => Lt
    | _   , nil => Gt
    | x :: xs' , y :: ys' =>
      match compare x y with
          | Lt => Lt
          | Gt => Gt
          | Eq => compare_list xs' ys'
      end
    end.

Instance Eq_list {a} `{Eq_ a} : Eq_ (list a) := fun _ k => k
  {| op_zeze____ := eqlist;
     op_zsze____ := fun x y => negb (eqlist x y)
  |}.

Instance Ord_list {a} `{Ord a}: Ord (list a) :=
  ord_default compare_list.

(* ********************************************************* *)
(* Some Haskell functions we cannot translate (yet)          *)

(* The inner nil case is impossible. So it is left out of the Haskell version. *)
Fixpoint scanr {a b:Type} (f : a -> b -> b) (q0 : b) (xs : list a) : list b :=
  match xs with
  | nil => q0 :: nil
  | y :: ys => match scanr f q0 ys with
              | q :: qs =>  f y q :: (q :: qs)
              | nil => nil
              end
end.

(* The inner nil case is impossible. So it is left out of the Haskell version. *)
Fixpoint scanr1 {a :Type} (f : a -> a -> a) (q0 : a) (xs : list a) : list a :=
  match xs with
  | nil => q0 :: nil
  | y :: nil => y :: nil
  | y :: ys => match scanr1 f q0 ys with
              | q :: qs =>  f y q :: (q :: qs)
              | nil => nil
              end
end.

Definition foldl {a}{b} k z0 xs :=
  fold_right (fun (v:a) (fn:b->b) => (fun (z:b) => fn (k z v))) (id : b -> b) xs z0.

Definition foldl' {a}{b} k z0 xs :=
  fold_right (fun(v:a) (fn:b->b) => (fun(z:b) => fn (k z v))) (id : b -> b) xs z0.

(* Less general type for build *)
Definition build {a} : (forall {b}, (a -> b -> b) -> b -> b) -> list a :=
  fun g => g _ (fun x y => x :: y) nil.

(* A copy of it, to facilitate the rewrite rule in the edits file *)
Definition build' : forall {a}, (forall {b}, (a -> b -> b) -> b -> b) -> list a := @build.

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

(* Definition oneShot {a} (x:a) := x. *)

(** Qualified notation for the notation defined here **)

Module ManualNotations.
Infix "GHC.Base./=" := (op_zsze__) (no associativity, at level 70).
Notation "'_GHC.Base./=_'" := (op_zsze__).
Infix "GHC.Base.==" := (op_zeze__) (no associativity, at level 70).
Notation "'_GHC.Base.==_'" := (op_zeze__).
Infix "GHC.Base.<" := (op_zl__) (no associativity, at level 70).
Notation "'_GHC.Base.<_'" := (op_zl__).
Infix "GHC.Base.<=" := (op_zlze__) (no associativity, at level 70).
Notation "'_GHC.Base.<=_'" := (op_zlze__).
Infix "GHC.Base.>" := (op_zg__) (no associativity, at level 70).
Notation "'_GHC.Base.>_'" := (op_zg__).
Infix "GHC.Base.>=" := (op_zgze__) (no associativity, at level 70).
Notation "'_GHC.Base.>=_'" := (op_zgze__).

Require String Ascii.
Export String.StringSyntax Ascii.AsciiSyntax.
End ManualNotations.


Definition foo '(x,y) := x + y.
Print foo.
Check forall '(a,b), a /\ b.

Require Import Utf8.
Print foo.
Check forall '(a,b), a /\ b.


From prelude Require Export co_pset.
From program_logic Require Export model.
From program_logic Require Import ownership wsat.
Local Hint Extern 10 (_ ≤ _) => omega.
Local Hint Extern 100 (@eq coPset _ _) => set_solver.
Local Hint Extern 100 (_ ∉ _) => set_solver.
Local Hint Extern 10 (✓{_} _) =>
  repeat match goal with
  | H : wsat _ _ _ _ |- _ => apply wsat_valid in H; last omega
  end; solve_validN.

Program Definition pvs_def {Λ Σ} (E1 E2 : coPset) (P : iProp Λ Σ) : iProp Λ Σ :=
  {| uPred_holds n r1 := ∀ rf k Ef σ,
       0 < k ≤ n → (E1 ∪ E2) ∩ Ef = ∅ →
       wsat k (E1 ∪ Ef) σ (r1 ⋅ rf) →
       ∃ r2, P k r2 ∧ wsat k (E2 ∪ Ef) σ (r2 ⋅ rf) |}.
Next Obligation.
  intros Λ Σ E1 E2 P r1 r2 n HP Hr rf k Ef σ ?? Hwsat; simpl in *.
  apply HP; auto. by rewrite (dist_le _ _ _ _ Hr); last lia.
Qed.
Next Obligation.
  intros Λ Σ E1 E2 P r1 r2 n1 n2 HP [r3 ?] Hn ? rf k Ef σ ?? Hws; setoid_subst.
  destruct (HP (r3⋅rf) k Ef σ) as (r'&?&Hws'); rewrite ?(assoc op); auto.
  exists (r' ⋅ r3); rewrite -assoc; split; last done.
  apply uPred_weaken with k r'; eauto using cmra_included_l.
Qed.

Definition pvs_aux : { x | x = @pvs_def }. by eexists. Qed.
Definition pvs := proj1_sig pvs_aux.
Definition pvs_eq : @pvs = @pvs_def := proj2_sig pvs_aux.

Arguments pvs {_ _} _ _ _%I.
Instance: Params (@pvs) 4.

Notation "|={ E1 , E2 }=> Q" := (pvs E1 E2 Q%I)
  (at level 199, E1, E2 at level 50, Q at level 200,
   format "|={ E1 , E2 }=>  Q") : uPred_scope.
Notation "|={ E }=> Q" := (pvs E E Q%I)
  (at level 199, E at level 50, Q at level 200,
   format "|={ E }=>  Q") : uPred_scope.

Section pvs.
Context {Λ : language} {Σ : iFunctor}.
Implicit Types P Q : iProp Λ Σ.
Implicit Types m : iGst Λ Σ.

Global Instance pvs_ne E1 E2 n : Proper (dist n ==> dist n) (@pvs Λ Σ E1 E2).
Proof.
  rewrite pvs_eq.
  intros P Q HPQ; split=> n' r1 ??; simpl; split; intros HP rf k Ef σ ???;
    destruct (HP rf k Ef σ) as (r2&?&?); auto;
    exists r2; split_and?; auto; apply HPQ; eauto.
Qed.
Global Instance pvs_proper E1 E2 : Proper ((≡) ==> (≡)) (@pvs Λ Σ E1 E2).
Proof. apply ne_proper, _. Qed.

Lemma pvs_intro E P : P ⊑ |={E}=> P.
Proof.
  rewrite pvs_eq. split=> n r ? HP rf k Ef σ ???; exists r; split; last done.
  apply uPred_weaken with n r; eauto.
Qed.
Lemma pvs_mono E1 E2 P Q : P ⊑ Q → (|={E1,E2}=> P) ⊑ (|={E1,E2}=> Q).
Proof.
  rewrite pvs_eq. intros HPQ; split=> n r ? HP rf k Ef σ ???.
  destruct (HP rf k Ef σ) as (r2&?&?); eauto.
  exists r2; eauto using uPred_in_entails.
Qed.
Lemma pvs_timeless E P : TimelessP P → (▷ P) ⊑ (|={E}=> P).
Proof.
  rewrite pvs_eq uPred.timelessP_spec=> HP.
  uPred.unseal; split=>-[|n] r ? HP' rf k Ef σ ???; first lia.
  exists r; split; last done.
  apply HP, uPred_weaken with n r; eauto using cmra_validN_le.
Qed.
Lemma pvs_trans E1 E2 E3 P :
  E2 ⊆ E1 ∪ E3 → (|={E1,E2}=> |={E2,E3}=> P) ⊑ (|={E1,E3}=> P).
Proof.
  rewrite pvs_eq. intros ?; split=> n r1 ? HP1 rf k Ef σ ???.
  destruct (HP1 rf k Ef σ) as (r2&HP2&?); auto.
Qed.
Lemma pvs_mask_frame E1 E2 Ef P :
  Ef ∩ (E1 ∪ E2) = ∅ → (|={E1,E2}=> P) ⊑ (|={E1 ∪ Ef,E2 ∪ Ef}=> P).
Proof.
  rewrite pvs_eq. intros ?; split=> n r ? HP rf k Ef' σ ???.
  destruct (HP rf k (Ef∪Ef') σ) as (r'&?&?); rewrite ?(assoc_L _); eauto.
  by exists r'; rewrite -(assoc_L _).
Qed.
Lemma pvs_frame_r E1 E2 P Q : ((|={E1,E2}=> P) ★ Q) ⊑ (|={E1,E2}=> P ★ Q).
Proof.
  rewrite pvs_eq. uPred.unseal; split; intros n r ? (r1&r2&Hr&HP&?) rf k Ef σ ???.
  destruct (HP (r2 ⋅ rf) k Ef σ) as (r'&?&?); eauto.
  { by rewrite assoc -(dist_le _ _ _ _ Hr); last lia. }
  exists (r' ⋅ r2); split; last by rewrite -assoc.
  exists r', r2; split_and?; auto; apply uPred_weaken with n r2; auto.
Qed.
Lemma pvs_openI i P : ownI i P ⊑ (|={{[i]},∅}=> ▷ P).
Proof.
  rewrite pvs_eq. uPred.unseal; split=> -[|n] r ? Hinv rf [|k] Ef σ ???; try lia.
  apply ownI_spec in Hinv; last auto.
  destruct (wsat_open k Ef σ (r ⋅ rf) i P) as (rP&?&?); auto.
  { rewrite lookup_wld_op_l ?Hinv; eauto; apply dist_le with (S n); eauto. }
  exists (rP ⋅ r); split; last by rewrite (left_id_L _ _) -assoc.
  eapply uPred_weaken with (S k) rP; eauto using cmra_included_l.
Qed.
Lemma pvs_closeI i P : (ownI i P ∧ ▷ P) ⊑ (|={∅,{[i]}}=> True).
Proof.
  rewrite pvs_eq. uPred.unseal; split=> -[|n] r ? [? HP] rf [|k] Ef σ ? HE ?; try lia.
  exists ∅; split; [done|].
  rewrite left_id; apply wsat_close with P r.
  - apply ownI_spec, uPred_weaken with (S n) r; auto.
  - set_solver +HE.
  - by rewrite -(left_id_L ∅ (∪) Ef).
  - apply uPred_weaken with n r; auto.
Qed.
Lemma pvs_ownG_updateP E m (P : iGst Λ Σ → Prop) :
  m ~~>: P → ownG m ⊑ (|={E}=> ∃ m', ■ P m' ∧ ownG m').
Proof.
  rewrite pvs_eq. intros Hup.
  uPred.unseal; split=> -[|n] r ? /ownG_spec Hinv rf [|k] Ef σ ???; try lia.
  destruct (wsat_update_gst k (E ∪ Ef) σ r rf m P) as (m'&?&?); eauto.
  { apply cmra_includedN_le with (S n); auto. }
  by exists (update_gst m' r); split; [exists m'; split; [|apply ownG_spec]|].
Qed.
Lemma pvs_allocI E P : ¬set_finite E → ▷ P ⊑ (|={E}=> ∃ i, ■ (i ∈ E) ∧ ownI i P).
Proof.
  rewrite pvs_eq. intros ?; rewrite /ownI; uPred.unseal.
  split=> -[|n] r ? HP rf [|k] Ef σ ???; try lia.
  destruct (wsat_alloc k E Ef σ rf P r) as (i&?&?&?); auto.
  { apply uPred_weaken with n r; eauto. }
  exists (Res {[ i := to_agree (Next (iProp_unfold P)) ]} ∅ ∅).
  split; [|done]. by exists i; split; rewrite /uPred_holds /=.
Qed.

(** * Derived rules *)
Import uPred.
Global Instance pvs_mono' E1 E2 : Proper ((⊑) ==> (⊑)) (@pvs Λ Σ E1 E2).
Proof. intros P Q; apply pvs_mono. Qed.
Global Instance pvs_flip_mono' E1 E2 :
  Proper (flip (⊑) ==> flip (⊑)) (@pvs Λ Σ E1 E2).
Proof. intros P Q; apply pvs_mono. Qed.
Lemma pvs_trans' E P : (|={E}=> |={E}=> P) ⊑ (|={E}=> P).
Proof. apply pvs_trans; set_solver. Qed.
Lemma pvs_strip_pvs E P Q : P ⊑ (|={E}=> Q) → (|={E}=> P) ⊑ (|={E}=> Q).
Proof. move=>->. by rewrite pvs_trans'. Qed.
Lemma pvs_frame_l E1 E2 P Q : (P ★ |={E1,E2}=> Q) ⊑ (|={E1,E2}=> P ★ Q).
Proof. rewrite !(comm _ P); apply pvs_frame_r. Qed.
Lemma pvs_always_l E1 E2 P Q `{!AlwaysStable P} :
  (P ∧ |={E1,E2}=> Q) ⊑ (|={E1,E2}=> P ∧ Q).
Proof. by rewrite !always_and_sep_l pvs_frame_l. Qed.
Lemma pvs_always_r E1 E2 P Q `{!AlwaysStable Q} :
  ((|={E1,E2}=> P) ∧ Q) ⊑ (|={E1,E2}=> P ∧ Q).
Proof. by rewrite !always_and_sep_r pvs_frame_r. Qed.
Lemma pvs_impl_l E1 E2 P Q : (□ (P → Q) ∧ (|={E1,E2}=> P)) ⊑ (|={E1,E2}=> Q).
Proof. by rewrite pvs_always_l always_elim impl_elim_l. Qed.
Lemma pvs_impl_r E1 E2 P Q : ((|={E1,E2}=> P) ∧ □ (P → Q)) ⊑ (|={E1,E2}=> Q).
Proof. by rewrite comm pvs_impl_l. Qed.
Lemma pvs_wand_l E1 E2 P Q R :
  P ⊑ (|={E1,E2}=> Q) → ((Q -★ R) ★ P) ⊑ (|={E1,E2}=> R).
Proof. intros ->. rewrite pvs_frame_l. apply pvs_mono, wand_elim_l. Qed.
Lemma pvs_wand_r E1 E2 P Q R :
  P ⊑ (|={E1,E2}=> Q) → (P ★ (Q -★ R)) ⊑ (|={E1,E2}=> R).
Proof. rewrite comm. apply pvs_wand_l. Qed.
Lemma pvs_sep E P Q:
  ((|={E}=> P) ★ (|={E}=> Q)) ⊑ (|={E}=> P ★ Q).
Proof. rewrite pvs_frame_r pvs_frame_l pvs_trans //. set_solver. Qed.

Lemma pvs_mask_frame' E1 E1' E2 E2' P :
  E1' ⊆ E1 → E2' ⊆ E2 → E1 ∖ E1' = E2 ∖ E2' →
  (|={E1',E2'}=> P) ⊑ (|={E1,E2}=> P).
Proof.
  intros HE1 HE2 HEE.
  rewrite (pvs_mask_frame _ _ (E1 ∖ E1')); last set_solver.
  by rewrite {2}HEE -!union_difference_L.
Qed.

Lemma pvs_mask_frame_mono E1 E1' E2 E2' P Q :
  E1' ⊆ E1 → E2' ⊆ E2 → E1 ∖ E1' = E2 ∖ E2' →
  P ⊑ Q → (|={E1',E2'}=> P) ⊑ (|={E1,E2}=> Q).
Proof. intros HE1 HE2 HEE ->. by apply pvs_mask_frame'. Qed.

(** It should be possible to give a stronger version of this rule
   that does not force the conclusion view shift to have twice the
   same mask. However, even expressing the side-conditions on the
   mask becomes really ugly then, and we have not found an instance
   where that would be useful. *)
Lemma pvs_trans3 E1 E2 Q :
  E2 ⊆ E1 → (|={E1,E2}=> |={E2}=> |={E2,E1}=> Q) ⊑ (|={E1}=> Q).
Proof. intros HE. rewrite !pvs_trans; set_solver. Qed.

Lemma pvs_mask_weaken E1 E2 P : E1 ⊆ E2 → (|={E1}=> P) ⊑ (|={E2}=> P).
Proof. auto using pvs_mask_frame'. Qed.

Lemma pvs_ownG_update E m m' : m ~~> m' → ownG m ⊑ (|={E}=> ownG m').
Proof.
  intros; rewrite (pvs_ownG_updateP E _ (m' =)); last by apply cmra_update_updateP.
  by apply pvs_mono, uPred.exist_elim=> m''; apply uPred.const_elim_l=> ->.
Qed.
End pvs.

(** * Frame Shift Assertions. *)
(* Yes, the name is horrible...
   Frame Shift Assertions take a mask and a predicate over some type (that's
   their "postcondition"). They support weakening the mask, framing resources
   into the postcondition, and composition witn mask-changing view shifts. *)
Notation FSA Λ Σ A := (coPset → (A → iProp Λ Σ) → iProp Λ Σ).
Class FrameShiftAssertion {Λ Σ A} (fsaV : Prop) (fsa : FSA Λ Σ A) := {
  fsa_mask_frame_mono E1 E2 Φ Ψ :
    E1 ⊆ E2 → (∀ a, Φ a ⊑ Ψ a) → fsa E1 Φ ⊑ fsa E2 Ψ;
  fsa_trans3 E Φ : (|={E}=> fsa E (λ a, |={E}=> Φ a)) ⊑ fsa E Φ;
  fsa_open_close E1 E2 Φ :
    fsaV → E2 ⊆ E1 → (|={E1,E2}=> fsa E2 (λ a, |={E2,E1}=> Φ a)) ⊑ fsa E1 Φ;
  fsa_frame_r E P Φ : (fsa E Φ ★ P) ⊑ fsa E (λ a, Φ a ★ P)
}.

Section fsa.
Context {Λ Σ A} (fsa : FSA Λ Σ A) `{!FrameShiftAssertion fsaV fsa}.
Implicit Types Φ Ψ : A → iProp Λ Σ.

Lemma fsa_mono E Φ Ψ : (∀ a, Φ a ⊑ Ψ a) → fsa E Φ ⊑ fsa E Ψ.
Proof. apply fsa_mask_frame_mono; auto. Qed.
Lemma fsa_mask_weaken E1 E2 Φ : E1 ⊆ E2 → fsa E1 Φ ⊑ fsa E2 Φ.
Proof. intros. apply fsa_mask_frame_mono; auto. Qed.
Lemma fsa_frame_l E P Φ : (P ★ fsa E Φ) ⊑ fsa E (λ a, P ★ Φ a).
Proof. rewrite comm fsa_frame_r. apply fsa_mono=>a. by rewrite comm. Qed.
Lemma fsa_strip_pvs E P Φ : P ⊑ fsa E Φ → (|={E}=> P) ⊑ fsa E Φ.
Proof.
  move=>->. rewrite -{2}fsa_trans3.
  apply pvs_mono, fsa_mono=>a; apply pvs_intro.
Qed.
Lemma fsa_mono_pvs E Φ Ψ : (∀ a, Φ a ⊑ (|={E}=> Ψ a)) → fsa E Φ ⊑ fsa E Ψ.
Proof. intros. rewrite -[fsa E Ψ]fsa_trans3 -pvs_intro. by apply fsa_mono. Qed.
End fsa.

Definition pvs_fsa {Λ Σ} : FSA Λ Σ () := λ E Φ, (|={E}=> Φ ())%I.
Instance pvs_fsa_prf {Λ Σ} : FrameShiftAssertion True (@pvs_fsa Λ Σ).
Proof.
  rewrite /pvs_fsa.
  split; auto using pvs_mask_frame_mono, pvs_trans3, pvs_frame_r.
Qed.

Lemma pvs_mk_fsa {Λ Σ} E (P Q : iProp Λ Σ) :
  P ⊑ pvs_fsa E (λ _, Q) →
  P ⊑ |={E}=> Q.
Proof. by intros ?. Qed.


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_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 -> ty -> 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_ty (T : tytree) (t : ty) : bool :=
  match T, t with
  | t_top, top => true
  | t_bot, bot => true

  | t_sel_upp x1 L1 _, sel x2 L2 => (eq_var x1 x2) && (eq_label L1 L2)

  | t_sel_low x1 L1 _, sel x2 L2 => (eq_var x1 x2) && (eq_label L1 L2)

  | t_sel_equ x1 L1 _, sel x2 L2 => (eq_var x1 x2) && (eq_label L1 L2)

  | t_sel_nom x1 L1 _, sel x2 L2 => (eq_var x1 x2) && (eq_label L1 L2)

  | t_rfn_top Ds, (top str σs rts) => eq_tree_decls Ds σs

  | t_rfn_sel x1 L1 Ds _, ((sel x2 L2) str σs rts) => (eq_var x1 x2) && (eq_label L1 L2) && (eq_tree_decls Ds σs)

  | t_sha_top x1 L1 σs1, ((sel x2 L2) str σs2 rts) => (eq_var x1 x2) && (eq_label L1 L2) && (eq_decls σs1 σs2)

  | t_sha_sel x1 L1 σs1 _, ((sel x2 L2) str σs2 rts) => (eq_var x1 x2) && (eq_label L1 L2) && (eq_decls σs1 σs2)

  | t_all T1 T2, all t1 ∙ t2 => (eq_tree_ty T1 t1) && (eq_tree_ty T2 t2)

  | _, _ => false
  end

with
eq_tree_decl (D : tytree) (σ : decl) : bool :=
  match D, σ with
  | t_upp L1 T, type L2 ⩽ t => andb (eq_label L1 L2) (eq_tree_ty T t)
  | t_low L1 T, type L2 ⩾ t => andb (eq_label L1 L2) (eq_tree_ty T t)
  | t_equ L1 T, type L2 ≝ t => andb (eq_label L1 L2) (eq_tree_ty T t)
  | t_nom L1  _ T, type L2 ⪯ t => andb (eq_label L1 L2) (eq_tree_ty T t)
  | _, _ => false
  end

with
eq_tree_decls (Ds : tytree)(σs : decls) : bool :=
  match Ds, σs with
  | t_nil, d_nil => true
  | t_con D Ds', d_con σ σs' => andb (eq_tree_decl D σ) (eq_tree_decls Ds' σs')
  | _, _ => 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)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  | 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)

  | t_rfn_sel x1 L1 Ts1 T1', t_sha_top x2 L2 ss2 => (eq_var x1 x2) && (eq_label L1 L2) && (eq_tree_decls Ts1 ss2)

  | t_rfn_sel x1 L1 Ts1 T1', t_sha_sel x2 L2 ss2 T2' => (eq_var x1 x2) && (eq_label L1 L2) && (eq_tree_decls Ts1 ss2)

  | t_sha_top x1 L1 ss1, t_rfn_sel x2 L2 Ts2 T2' => (eq_var x1 x2) && (eq_label L1 L2) && (eq_tree_decls Ts2 ss1)

  | 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_top x1 L1 ss1, t_sha_sel x2 L2 ss2 T2' => (eq_var x1 x2) && (eq_label L1 L2) && (eq_decls ss1 ss2)

  | t_sha_sel x1 L1 ss1 T1', t_rfn_sel x2 L2 Ts2 T2' => (eq_var x1 x2) && (eq_label L1 L2) && (eq_tree_decls Ts2 ss1)

  | t_sha_sel x1 L1 ss1 T1', 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)

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

(*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_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_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_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)
                          | _ => 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 (subtype 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 T1' => match T2 with
                   | t_upp L2 T2' => andb (eq_label L1 L2)
                                         (subtype T1' T2')
                   | t_nom L2 t2 T2' => (eq_label L1 L2) && eq_ty 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.
  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.
  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.

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 <> t_nom L t' 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 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 <> t_nom L t' 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 T); auto.
  contradiction (H3); auto.
  contradiction (H4 T1 T2); auto.
Qed.


(*Inductive mFalse :=.
Check mFalse_rect.*)
Unset Elimination Schemes.
Inductive mFalse :=.

Definition mFalse_rect : forall (P : mFalse -> Type) (m : mFalse), P m.
intros P m.
destruct m.
Show Proof.

Inductive mTrue
Unset Elimination Schemes.