Require Import Template.All.
Require Import List String.
Load Cedille.

Inductive myNat : Type :=
|zz : myNat
|ss : myNat -> myNat.

Inductive ntree (A : Type) : Type :=
| leaf : (ntree A)
| node : A -> myNat -> (ntree A) -> (ntree A) -> (ntree A).

Fixpoint testfix (a : ntree nat) : myNat :=
  match a with
  | leaf _ => zz
  | node _  a n l r => n
  end.

Quote Recursively Definition rt := ntree.
Quote Recursively Definition rfix := testfix.
Print rt.

(* Definitions *)
Definition rTerm := prod global_declarations term.
Definition ctor  := (prod (prod ident term) nat).
Record env : Set := mkEnv { kername : string ; tyAndCtors : list (string * (list string)); lced : list ced }.

Definition emptyenv : env := mkEnv "empty" nil nil.

Definition setKername (e : env) (name : string ) : env :=
  match e with
  | {| kername:=k ; tyAndCtors:=xs ;  lced:=ys |} => mkEnv name nil ys
  end.

Definition updateProg ( e : env) (c : ced ): env :=
  match e with
  | {| kername:=k ; tyAndCtors:=xs ;  lced:=ys |} => mkEnv k xs (cons c ys)
  end.

Definition updateTyAndCtors (e : env ) (x : string * (list string)) : env :=
  match e with
  | {| kername:=k ; tyAndCtors:=xs ;  lced:=ys |} => mkEnv k (cons x xs) ys
  end.

(* Helpers, Get methods *)
Definition getOneIndBody (t : mutual_inductive_body) := (head (t.(ind_bodies))).

(* Previous work----------------------- *)

Inductive Functor : Type :=
| unit : Functor
| carry : Functor
| coprod : Functor -> Functor -> Functor
| prod : Functor -> Functor -> Functor
| const : string -> Functor
(* garbage *)
| empty : Functor.

Fixpoint glue ( f : list Functor) : Functor :=
  match f with
  | nil => empty
  | x :: nil => x
  | x :: xs => (coprod x (glue xs))
  end.

Fixpoint convertF ( f : Functor ) : ced :=
  match f with
  | unit => (tvar "Unit")
  | carry => (tvar "R")
  | const str => (tvar str)
  | coprod t1 t2 => (tyAppty (tyAppty (tvar "Sum") (convertF t1)) (convertF t2))
  | prod t1 t2 => (tyAppty (tyAppty (tvar "Product") (convertF t1)) (convertF t2))
  | _  => star
  end.

Fixpoint Kind (t : term) : ced :=
  match t with
  | tProd _ _ (tSort _ ) => (arr (arr star star) star)
  | tProd _ _ rt => (arr (Kind rt) star)
  | _ => star
  end.

Definition total_map (A : Type)  := Datatypes.nat -> A.
Definition t_empty { A : Type } ( v : A ) : total_map A :=
  (fun _ => v).
Definition t_update { A: Type } ( m : total_map A) (n : Datatypes.nat) (v : A) :=
  (fun n' =>  if (Nat.eqb n n') then v else m n').

Fixpoint hToFunctor (t : term ) (n : Datatypes.nat) (m : total_map ident) : Functor :=
  match t with
  (*map  lookups *)
  | (tRel n') => (const (m (n-n'-1)))
  | (tApp (tRel n') _ ) => (const (m (n-n'-1))) (* todo: specific type application *)
  | (tApp (tInd ind _ ) _) => (const ind.(inductive_mind))
  | (tInd ind _ ) => (const ind.(inductive_mind))
  (* insert to map *)
  | tProd (nNamed tyname) (tSort _) rt => (hToFunctor rt (n+1) (t_update m n tyname))

  (* recursively process *)
  | tProd _ rt1 rt2 => (prod (hToFunctor rt1 n m) (hToFunctor rt2 (n+1) m))

  (* error *)
  | _ => empty
  end.

Definition toFunctor (t : term ) (name : ident) : Functor :=
  (hToFunctor t 1 (t_update (t_empty "NULL") 0 name)).

(* looks for the carrier type in const *)
Fixpoint findCarry (f : Functor) (name : string ) : Functor :=
  match f with
  | const n => if (eq_string n name) then carry else (const n)
  | coprod t rt => (coprod (findCarry t name) (findCarry rt name))
  | prod t rt => (prod (findCarry t name) (findCarry rt name))
  | unit => unit
  | carry => carry
  | empty => empty
  end.

Fixpoint replaceCarry (f : Functor ) : Functor :=
  match f with
  | prod t carry => t
  | prod t rt => (prod t (replaceCarry rt))
  | coprod carry rt => coprod unit (replaceCarry rt)
  | coprod t rt => coprod t (replaceCarry rt)
  | const n => const n
  | unit => unit
  | carry => carry
  | empty => empty
  end.

Definition TypeToFunctor (ts : list ctor) :=
  let pieces := map (fun c => (toFunctor (snd (fst c)) "ERROR NAME")) ts
  in
  (replaceCarry (findCarry (glue pieces) "ERROR NAME")).

Fixpoint hbinders (t : term) (body : ced ): ced :=
  match t with
  | tProd (nNamed name) _ (tSort _) => pLambda name body  (* end *)
  | tProd (nNamed name) _ rt => pLambda name (hbinders rt body)
  | _ => body
  end.

Definition binders (b : one_inductive_body ) : ced :=
  (hbinders b.(ind_type) (pLambda "R" (convertF (TypeToFunctor b.(ind_ctors))))).

(* ------------------------------------ *)

(*
 (* inject *)
 Definition inFunctor ( f : Functor ) : ced :=
   match f with
   | Prod l r => (tmApptm (tvar "in") (tmApptm (tvar "in2") (tmApptm (tvar "pair")
   end.
   (tmApptm (tvar "in") (tmApptm (tvar "in1") (

 (* peel sum types *)
 Fixpoint smtc ( f : Functor  ) : list ced :=
   match f with
   | Sum l r =>
   | Prod l r =>
   |
   end.

Definition tosmt (ts : list ctor)(e : env) :=
  let pieces := map (fun c => (pair (fst (fst c)) (toFunctor (snd (fst c)) "ERROR NAME"))) ts
  in
  let strfun := map (fun c => (pair (fst c) (replaceCarry (findCarry (snd c) "ERROR NAME"))))  pieces
  in
  let cnames := map fst strfun
  in (updateTyAndCtors e (pair e.(kername) cnames)).
 *)

Fixpoint asdf (t : term) : ced :=
  match t with
  | tProd (nNamed name) _ (tSort _) => (tvar name)
  | tProd (nNamed name) _  rt => (tyAppty (asdf rt) (tvar name))
  | _ => (tvar "ERROR")
  end.

Definition makeFunctor (b : one_inductive_body) ( e : env) : env :=
  (updateProg e (def ((b.(ind_name))++"F") (Kind b.(ind_type)) (binders b))).

Definition makeFixFunctor (b : one_inductive_body) (e : env) : env :=
  (updateProg e (def (b.(ind_name)) (Kind b.(ind_type)) (hbinders b.(ind_type) (tyAppty (tvar "FixM") (tyAppty (tvar (b.(ind_name)++"F")) (asdf b.(ind_type))))))).

Definition makeSmartCons (b : one_inductive_body) (e : env) : env :=
  e.

Definition processInductive (b : mutual_inductive_body)(e:env) :=
  match (getOneIndBody b) with
  | Some x => let e'  := (makeFunctor x e) in
              let e'' := (makeFixFunctor x e') in
              let e''':= (makeSmartCons x e'') in
              e'''
  | None => e
  end.

Definition processConstant (b : constant_body)(e:env) := e.

Definition processDecls' (decl : global_decl) (e : env) :  env :=
  match decl with
   | InductiveDecl kername mut_ind_body => (processInductive mut_ind_body (setKername e kername))
   | ConstantDecl kername body => (processConstant body (setKername e kername))
  end.

Fixpoint  processDecls (decls : list global_decl ) ( e : env) : env :=
  match decls with
  | nil => e
  | x::xs  => (processDecls xs (processDecls' x e))
  end.

Definition convert (r : rTerm) : env :=
  (processDecls (fst r) emptyenv).

Definition printAll (r : rTerm ) : list string :=
  map print (convert r).(lced).

Inductive fourc : Type :=
|c1 : fourc
|c2 : fourc -> fourc
|c3 : fourc -> fourc
|c4 : fourc -> fourc.
Quote Recursively Definition r := fourc.

Print rt.
Compute (convert r).
Compute (convert rt).
Compute (printAll rt).
Compute (convert rfix).
Compute (printAll rfix).

Print rfix.

Inductive testtype  (A B : Type ) ( a : A ) (b : A -> B) : Type :=
| cc1 : testtype A B a b .

Quote Recursively Definition rtt := testtype.
Print rtt.


From L Require Import Reductions.MPCP_PCP.
From Undecidability.PCP Require Import SR_MPCP.

Definition red := (fun '(R, x, y) => (d R x y, P R x y)).

Instance computable_Sigma : computable Sigma.
Proof.
  extract.
Defined.

Instance computable_dollar : computable dollar.
Proof.
  extract.
Defined.

Instance computable_hash : computable hash.
Proof.
  extract.
Defined.

Instance internalize_d : computable d.
Proof.
  extract.
Defined.

Instance internalize_e : computable e.
Proof.
  extract.
Defined.

Definition singcard := (fun a : symbol => [a] / [a]).

Instance internalize_singcard : computable singcard.
Proof.
  extract.
Defined.

Instance internalize_P : computable P.
Proof.
  change P with
      (fun (R : SRS) (x0 y0 : Definitions.string) =>
         [d R x0 y0; e R x0 y0] ++ R ++ [[hash R x0 y0] / [hash R x0 y0]] ++ map singcard (x0 ++ y0 ++ sym R)).
  extract.
Defined.

Instance internalize_red : computable red.
Proof.
  extract.
Defined.


Require Import AutoSep.
Require Import TimeAbstract.

(** * A trivial example to make sure the array proof automation isn't completely borked *)

Definition readS : spec := SPEC("x") reserving 0
  Al ls,
  PRE[V] [| $3 < natToW (length ls) |] * array ls (V "x")
  POST[R] [| R = selN ls 3 |] * array ls (V "x").

Definition writeS : spec := SPEC("x") reserving 0
  Al ls,
  PRE[V] [| $3 < natToW (length ls) |] * array ls (V "x")
  POST[_] array (updN ls 3 11) (V "x").

Definition bump := map (fun w : W => w ^+ $1).

Definition bumpS : spec := SPEC("arr", "len") reserving 3
  Al ls,
  PRE[V] [| V "len" = $(length ls) |] * array ls (V "arr")
  POST[_] array (bump ls) (V "arr").

Open Scope list_scope.

Definition arrays := bmodule "read" {{
  bfunction "read"("x") [readS]
    "x" <- "x" + 12;;
    "x" <-* "x";;
    Return "x"
  end with bfunction "write"("x") [writeS]
    "x" <- "x" + 12;;
    "x" *<- 11;;
    Return 0
  end with bfunction "bump"("arr", "len", "i", "tmp", "tmp2") [bumpS]
    "i" <- 0;;
    [Al ls, Al done, Al pending,
      PRE[V] [| V "len" = $(length ls) |] * [| V "i" = $(length done) |] * [| ls = done ++ pending |]
        * array ls (V "arr")
      POST[_] Ex ls', [| ls' = done ++ bump pending |] * array ls' (V "arr") ]
    While ("i" < "len") {
      "tmp" <- 4 * "i";;
      "tmp" <- "arr" + "tmp";;
      "tmp2" <-* "tmp";;
      "tmp" *<- "tmp2" + 1;;
      "i" <- "i" + 1
    };;
    Return 0
  end
}}.

Hint Rewrite app_length : sepFormula.

Lemma shift_pos : forall (ls1 ls2 : list W),
  (length ls1 < length (ls1 ++ ls2))%nat
  -> length ls1 + length ls2 = length (ls1 ++ hd (natToW 0) ls2 ^+ natToW 1 :: nil) + length (tl ls2).
  intros; autorewrite with sepFormula in *;
    destruct ls2; simpl in *; unfold W; omega.
Qed.

Ltac pure' := intros; repeat match goal with
                               | [ H : sel _ _ = _ |- _ ] => rewrite H in *
                             end;
  try match goal with
        | [ _ : context[length (?A ++ ?B)] |- _ ] =>
          assert (goodSize (length (A ++ B))) by (eapply containsArray_goodSize; eauto)
      end;
  autorewrite with sepFormula in *; simpl length in *; autorewrite with sepFormula.

Ltac pure := pure'; try (apply f_equal; apply shift_pos; pure'); eauto 7.

Lemma nil_front : forall A n,
  n = @length A nil + n.
  reflexivity.
Qed.

Hint Immediate nil_front.

Lemma shift_updN : forall v pending done,
  (length pending > 0)%nat
  -> updN (done ++ pending) (length done) v = done ++ v :: tl pending.
  induction done; simpl; intuition;
    destruct pending; simpl in *; auto; omega.
Qed.

Theorem selN_hd : forall pending done,
  selN (done ++ pending) (length done) = hd $0 pending.
  induction done; simpl; intuition;
    destruct pending; reflexivity.
Qed.

Hint Rewrite shift_updN selN_hd using solve [ eauto ] : sepFormula.

Hint Rewrite DepList.pf_list_simpl : sepFormula.

Hint Rewrite sel_selN upd_updN using solve [ eauto 6 ] : sepFormula.

Hint Resolve shift_pos.

Lemma not_done_yet : forall A (done pending : list A),
  natToW (length done) < $ (length done + length pending)
  -> (length pending > 0)%nat.
  destruct pending; simpl; intuition;
    rewrite <- plus_n_O in *; unfold natToW in *; nomega.
Qed.

Hint Immediate not_done_yet.

Lemma shift_reorg : forall pending,
  (length pending > 0)%nat
  -> hd $0 pending ^+ $1 :: bump (tl pending)
  = bump pending.
  intros; autorewrite with sepFormula in *; destruct pending; simpl in *; auto; omega.
Qed.

Hint Rewrite shift_reorg using solve [ eauto ] : sepFormula.

Hint Rewrite Npow2_nat wordToN_nat wordToNat_natToWord_idempotent
  using nomega : N.

Lemma now_done : forall A (done pending : list A),
  natToW (length done + length pending) <= $ (length done)
  -> goodSize (length done + length pending)
  -> pending = nil.
  destruct pending; simpl; intuition; elimtype False; eauto.
Qed.

Hint Resolve now_done.

Lemma unbump : forall done pending,
  pending = nil
  -> done ++ pending = done ++ bump pending.
  intros; subst; reflexivity.
Qed.

Hint Resolve unbump.

Hint Rewrite wordToNat_natToW_goodSize using solve [ eauto ] : N.

Lemma bound_nat : forall (done pending : list W),
  natToW (length done) < natToW (length done + length pending)
  -> goodSize (length (done ++ hd $0 pending ^+ $1 :: tl pending))
  -> (length done < length done + length pending)%nat.
  intros; autorewrite with sepFormula N in *; simpl in *;
    apply lt_goodSize'; eauto; destruct pending; simpl in *; eauto using goodSize_weaken.
Qed.

Hint Resolve bound_nat.

Hint Extern 1 (himp _ _) => reflexivity.

Lemma goodSize_prefix : forall a b : list W,
  goodSize (length (a ++ b))
  -> goodSize (length a).
  intros; autorewrite with sepFormula in *; eapply goodSize_weaken; eauto.
Qed.

Lemma goodSize_full : forall a b : list W,
  goodSize (length (a ++ b))
  -> goodSize (length a + length b).
  intros; autorewrite with sepFormula in *; eapply goodSize_weaken; eauto.
Qed.

Hint Extern 1 (goodSize (length _)) => eapply goodSize_prefix; eapply containsArray_goodSize.
Hint Extern 1 (goodSize (length _ + length _)) => eapply goodSize_full; eapply containsArray_goodSize.

Hint Extern 1 (_ < _)%nat => apply lt_goodSize'; [ assumption | | ].

Theorem arraysOk : moduleOk arrays.
(*TIME  Clear Timing Profile. *)
  vcgen; time_abstract ltac:(sep_auto; pure).
(*TIME  Print Timing Profile. *)
Qed.


(** Beginning of the file for CP mechanisation as described in

    Philip Wadler. 2012. Propositions as sessions. In Proceedings of the 17th
    ACM SIGPLAN international conference on Functional programming (ICFP '12).
    ACM, New York, NY, USA, 273-286. DOI=10.1145/2364527.2364568
    http://doi.acm.org/10.1145/2364527.2364568

*)
Require Import Metatheory.Metatheory CP_Definitions.
Require Import Coq.Sorting.Permutation.

Set Implicit Arguments.

Hint Resolve eq_nat_dec.

Section CPPropProperties.

  Lemma eq_pvar_dec : forall (x y : pvar), sumbool (x = y) (x <> y).
  Proof. decide equality. Qed.

  Lemma eq_prop_dec: forall (x y : prop), sumbool (x = y) (x <> y).
  Proof. decide equality; auto using eq_pvar_dec. Qed.

  Global Instance EqDec_prop : @EqDec_eq prop.
  Proof. exact eq_prop_dec. Defined.

  Lemma prop_dual_involutive:
    forall A, A = ¬(¬A).
  Proof.
    induction A; simpl; f_equal; auto.
  Qed.

  Lemma prop_eq_dual:
    forall A (EQ: A = ¬A),
      False.
  Proof. ii; induction A; ss; tryfalse. Qed.

  Lemma prop_dual_self:
    forall A, dual_props A (¬A).
  Proof. induction A; ss; eauto. Qed.

  Lemma prop_dual_equiv_dual_props:
    forall A dA (DUA: dual_props A dA), dA = ¬A.
  Proof. ii; induction DUA; subst; auto using prop_dual_involutive. Qed.

  Lemma dual_props_equiv_prop_dual:
    forall A dA (DUA: dA = ¬A), dual_props A dA.
  Proof. ii. induction A; ss; rewrite DUA; eauto using prop_dual_self. Qed.

  Lemma prop_dual_iff:
    forall A dA, dA = ¬A <-> dual_props A dA.
  Proof.
    ii; split; auto using prop_dual_equiv_dual_props,
               dual_props_equiv_prop_dual.
  Qed.

  Lemma prop_dual_eq:
    forall A B (EQ: ¬A = ¬B), A = B.
  Proof.
    ii; induction A; by rewrite ->prop_dual_iff in EQ; apply dual_sym in EQ
    ; rewrite <-prop_dual_iff in EQ; rewrite <-!prop_dual_involutive in EQ
    ; subst; reflexivity.
  Qed.

  Lemma prop_dual_preserves_subst:
    forall A B X, ¬({{A // X}}B) = {{A // X}}(¬B).
  Proof.
    intros; induction B; simpl; f_equal; auto; destruct p; auto
    ; match goal with
        | |- context[?X == ?Y] => destruct (X == Y)
      end; auto using prop_dual_involutive.
  Qed.

  Lemma prop_dual_preserves_open:
    forall k x A, ¬prop_open_rec k x A = prop_open_rec k x (¬A).
  Proof.
    ii; gen k; induction A; ii; f_equal; auto; destruct p; des; auto.
  Qed.

  Lemma prop_dual_open_prop:
    forall x A, ¬open_prop A x = open_prop (¬A) x.
  Proof.
    ii; rewrite /open_prop prop_dual_preserves_open; auto.
  Qed.

End CPPropProperties.

Section CPBasicSubstOpenProperties.

  Lemma open_rec_same :
    forall t j v i u
           (NEQ: i <> j)
           (EQ: {i ~> u}({j ~> v} t) = {j ~> v} t),
      {i ~> u} t = t.
  Proof.
    induction t; ii; des; substs; tryfalse; f_equal; inv EQ; firstorder.
  Qed.

  Lemma open_rec_comm:
    forall t j v i u
           (NEQ: i <> j),
      {i ~> u}({j ~> v} t) = {j ~> v} ({i ~> u}t).
  Proof.
    induction t; ii; destruct_all pname; des; subst
    ; solve [exfalso; auto
            |f_equal; firstorder].
  Qed.

  Lemma lc_no_bvar:
    forall t u k
           (LC: lc_proc t),
      {k ~> u}t = t.
  Proof.
    ii; generalize dependent k; induction LC; s; ii; f_equal; auto
    ; try (by unfold open_proc in *; pick fresh z for L
           ; apply open_rec_same with (j := 0)(v := z); auto).
  Qed.

  Lemma lc_open_subst:
    forall t u (x y: atom) k
           (NEQ: x <> y),
      {k ~> y} ([x ~> u]t) = [x ~> u]({k ~> y} t).
  Proof.
    ii; unfold open_proc; generalize dependent k.
    induction t; by ii; destruct_all pname; des; subst; f_equal; auto.
  Qed.

  Lemma subst_fresh:
    forall (x:atom) u t
           (NIN: x `notin` fv_proc t),
      [x ~> u]t = t.
  Proof.
    induction t; ii; try (destruct_all pname; des; subst; f_equal
                          ; solve [auto | fsetdec]).
  Qed.

  Lemma subst_open_rec:
    forall P x y k,
      [y ~> x] ({k ~> y} P) = {k ~> x} ([y ~> x] P).
  Proof.
    ii; gen k; induction P; ii; destruct_all pname; des; tryfalse
    ; f_equal; auto.
  Qed.

  Lemma subst_open_var :
    forall (x y : atom) u t
           (NEQ: y <> x),
      open_proc ([x ~> u] t) y = [x ~> u] (open_proc t y).
  Proof.
    ii; unfold open_proc; auto using lc_open_subst.
  Qed.

  Lemma subst_intro_open_rec:
    forall x u t k
           (NIN: x `notin` (fv_proc t)),
      {k ~> u} t = [x ~> u]({k ~> x} t).
  Proof.
    ii; gen k; induction t; ii; destruct_all pname; des; substs; f_equal
    ; solve [auto|fsetdec].
  Qed.

  Lemma subst_intro :
    forall (x : atom) u t
           (NIN: x `notin` (fv_proc t)),
      open_proc t u = [x ~> u](open_proc t x).
  Proof.
    ii; unfold open_proc; rewrite~ <-subst_intro_open_rec.
  Qed.

  Lemma subst_id:
    forall (x:atom) t,
      [x ~> x]t = t.
  Proof.
    induction t; ss; try (destruct_all pname; des; substs; f_equal
                          ; solve [auto | fsetdec]).
  Qed.

  Ltac subst_lc_tac Constructor :=
    pick fresh y and apply Constructor; auto
    ; by unfold open_proc in *; rewrite lc_open_subst; auto.

  Lemma subst_lc :
    forall t u x
           (LCT: lc_proc t),
      lc_proc ([ x ~> u ] t).
  Proof.
    ii; induction LCT; s; des; subst; auto
    ; solve [subst_lc_tac lc_p_cut
            |subst_lc_tac lc_p_output
            |subst_lc_tac lc_p_input
            |subst_lc_tac lc_p_accept
            |subst_lc_tac lc_p_request].
  Qed.

End CPBasicSubstOpenProperties.

Section CPSwapBinders.

  Lemma swap_binders_id:
    forall P i,
      {i <~> i} P = P.
  Proof.
    intro; induction P; i; ss; destruct_all pname; des; substs; f_equal; auto.
  Qed.

  Lemma swap_binders_comm:
    forall P i j,
      {i <~> j}P = {j <~> i}P.
  Proof.
    induction P; ii; destruct_all pname; des; substs; tryfalse; f_equal; auto.
  Qed.

  Lemma swap_binders_fv:
    forall P i j,
      fv_proc ({i <~> j}P) = fv_proc P.
  Proof.
    ii; destruct (i == j); substs; [rewrite~ swap_binders_id|]; gen i j.
    induction P; ii; destruct_all pname; des; substs; tryfalse
    ; repeat (f_equal; auto).
  Qed.

  Lemma swap_binders_open_id:
    forall P x i j,
      {i ~> x}({j ~> x}({i <~> j}P)) = {i ~> x}({j ~> x}P).
  Proof.
    ii; destruct (i == j); substs; [rewrite~ swap_binders_id|].
    gen i j; induction P; ii; destruct_all pname; des; substs; tryfalse
    ; f_equal; auto.
  Qed.

  Lemma swap_binders_open:
    forall P x y i j,
      {i ~> x}({j ~> y}({i <~> j}P)) = {j ~> x}({i ~> y}P).
  Proof.
    ii; destruct (i == j); substs; [rewrite~ swap_binders_id|].
    destruct (x == y); substs
    ; [rewrite swap_binders_open_id; rewrite~ open_rec_comm|].
    gen i j; induction P; ii; destruct_all pname; des; substs; tryfalse
    ; f_equal; auto.
  Qed.

End CPSwapBinders.

Section CPAllRequestsProperties.

  Lemma requests_one:
    forall x A, all_requests (x ~ ? A).
  Proof. ii; apply* all_reqs_cons. Qed.

  Lemma requests_app:
    forall xs ys
           (REQXS: all_requests xs)
           (REQYS: all_requests ys),
      all_requests (xs ++ ys).
  Proof with auto.
    induction xs as [|x xs']...
    introv REQXS REQYS; inverts REQXS; simpl_env...
  Qed.

  Lemma requests_inv_app:
    forall xs ys
           (REQS: all_requests (xs++ys)),
      all_requests xs /\ all_requests ys.
  Proof with auto.
    induction xs as [|x xs']...
    ii; inverts REQS; specializes IHxs' REQS0; des; splits; simpl_env...
  Qed.

  Lemma requests_perm:
    forall xs ys
           (PER: Permutation xs ys)
           (REQS: all_requests xs),
      all_requests ys.
  Proof.
    i; induction PER; auto.
    - destruct x; rewrite !cons_app_one; inverts REQS; auto.
    - destruct x; destruct y; rewrite !cons_app_one; inverts REQS
      ; inverts REQS0; auto.
  Qed.

  Lemma requests_binds_cod:
    forall (x:atom) A Ω
           (REQS: all_requests Ω)
           (BNDS: binds x A Ω),
    exists B, A = ? B.
  Proof.
    ii; induction REQS; analyze_binds BNDS; eauto.
  Qed.

End CPAllRequestsProperties.

(** Tactic for destructing all_requests hypotheses. *)
Ltac des_reqs :=
  repeat match goal with
           | [H: all_requests (_ ++ _) |- _] =>
             apply requests_inv_app in H; des
         end.

(** Helpful tactics for solving simple permutations. *)
Ltac bring_to_start X :=
  try (eapply Permutation_trans
       ; [|by repeat first [apply (Permutation_app_comm X _)
                           |apply Permutation_app_head]])
  ; first [apply Permutation_app_head
          |eapply Permutation_trans
           ; [| by repeat first [apply (three_way_perm X)
                                |apply Permutation_app_head]]
           ; bring_to_start X].

Ltac solve_perm :=
  by repeat first [rewrite !app_assoc
                  |rewrite !cons_app_one
                  |match goal with
                       |- Permutation (?x ++ _) _ => bring_to_start x
                   end].

(* Extract a binding from a permutation. *)

Ltac extract_bnd x A :=
  match goal with
    | [H: Permutation (_++x~A) ?F |- _] =>
      let BNDS := fresh "BNDS" in
      forwards~ BNDS: Perm_binds x A H; analyze_binds_uniq BNDS
      ; try (by applys~ uniq_perm H)
      ; try (match goal with
               | [H: binds x A ?E |- _] =>
                 let E1 := fresh "E1" in
                 let E2 := fresh "E2" in
                 let EQ := fresh "EQ" in
                 apply binds_env_split in H
                 ; inversion_clear H as (E1 & E2 & EQ)
                 ; substs~; des_reqs
             end)
  end.

Section CPPermProperties.

  Lemma perm_dom_uniq:
    forall Γ Δ1 Δ2 x (A B:prop)
           (UN: uniq (Γ++x~A))
           (PER: Permutation (Γ++x~A) (Δ1++x~B++Δ2)),
      Permutation Γ (Δ1++Δ2).
  Proof.
    intros; forwards UN1: uniq_perm PER; [solve_uniq|].
    eapply uniq_perm in UN; [|apply Permutation_app_comm].
    inv UN1; inv UN; destruct (B == A); substs~.
    - rewrite <-H0 in *; apply Permutation_sym,Permutation_nil in PER.
      apply app_eq_nil in PER; des; substs~. eauto.
      rewrite !cons_app_one in *; apply nil_eq_app in H0; des.
      apply app_eq_nil in H3; des; substs~; auto.
    - rewrite <-H0 in *; apply Permutation_sym,Permutation_nil in PER.
      apply app_eq_nil in PER; des; substs~. eauto.
      rewrite !cons_app_one in *; apply nil_eq_app in H0; des.
      apply app_eq_nil in H3; des; substs~.
    - eapply Permutation_trans in PER; [|apply Permutation_app_comm].
      applys~ Permutation_cons_app_inv PER.
    - extract_bnd x A.
  Qed.

  Lemma perm_cod_uniq:
    forall Γ Δ1 Δ2 x (A B:prop)
           (UN: uniq (Γ++x~A))
           (PER: Permutation (Γ++x~A) (Δ1++x~B++Δ2)),
      A = B.
  Proof.
    intros; forwards UN1: uniq_perm PER; [solve_uniq|].
    eapply uniq_perm in UN; [|apply Permutation_app_comm].
    inv UN1; inv UN; destruct (B == A); substs~.
    - rewrite <-H0 in *; apply Permutation_sym,Permutation_nil in PER.
      apply app_eq_nil in PER; des; tryfalse.
    - extract_bnd x A.
  Qed.

End CPPermProperties.

Section CPFVProperties.

  Lemma open_fv_proc_1:
    forall x y k P
           (NEQ: x <> y)
           (FV: x `in` fv_proc ({k ~> y}P)),
      x `in` fv_proc P.
  Proof.
    i; gen k; induction P; ii; destruct_all pname; des; destruct_in; tryfalse
    ; eauto.
  Qed.

  Lemma open_fv_proc_2:
    forall x y k P
           (FV: x `in` fv_proc P),
      x `in` fv_proc ({k ~> y}P).
  Proof.
    i; gen k; induction P; ii; destruct_all pname; des; destruct_in; eauto.
  Qed.

  Lemma open_nfv_proc_1:
    forall x y k P
           (NEQ: x <> y)
           (NFV: x `notin` fv_proc P),
      x `notin` fv_proc ({k ~> y}P).
  Proof.
    i; gen k; induction P; ii; destruct_all pname; des; destruct_in; eauto.
  Qed.

  Lemma open_nfv_proc_2:
    forall x y k P
           (NFV: x `notin` fv_proc ({k ~> y}P)),
      x `notin` fv_proc P.
  Proof.
    i; gen k; induction P; ii; destruct_all pname; des; destruct_in; eauto.
  Qed.

  Lemma remove_nfv_proc_eq:
    forall P k (x y:atom)
           (NFX: x `notin` fv_proc P)
           (NFY: y `notin` fv_proc P),
      remove y (fv_proc ({k ~> y}P))[=]remove x (fv_proc ({k ~> x}P)).
  Proof.
    induction P; ii; destruct_notin
    ; try (by destruct_all pname; des; destruct_notin; fsetdec).
    - rewrite !remove_union; rewrite~ (IHP1 (S k) x y)
      ; rewrite~ (IHP2 (S k) y x); fsetdec.
    - destruct_all pname; des; destruct_notin; rewrite !remove_union
      ; rewrite~ (IHP1 (S k) x y); rewrite~ (IHP2 k y x); fsetdec.
    - destruct_all pname; des; destruct_notin; rewrite !remove_union
      ; rewrite~ (IHP (S k) x y); fsetdec.
    - destruct_all pname; des; destruct_notin; rewrite !remove_union
      ; rewrite~ (IHP k x y); fsetdec.
    - destruct_all pname; des; destruct_notin; rewrite !remove_union
      ; rewrite~ (IHP k x y); fsetdec.
    - destruct_all pname; des; destruct_notin; rewrite !remove_union
      ; rewrite~ (IHP1 k x y); rewrite~ (IHP2 k y x); fsetdec.
    - destruct_all pname; des; destruct_notin; rewrite !remove_union
      ; rewrite~ (IHP (S k) x y); fsetdec.
    - destruct_all pname; des; destruct_notin; rewrite !remove_union
      ; rewrite~ (IHP (S k) x y); fsetdec.
    - destruct_all pname; des; destruct_notin; rewrite !remove_union
      ; rewrite~ (IHP k x y); fsetdec.
    - destruct_all pname; des; destruct_notin; rewrite !remove_union
      ; rewrite~ (IHP k x y); fsetdec.
  Qed.

End CPFVProperties.

Lemma wt_nin_env:
  forall (Γ Δ:penv) (x:atom)
         (NIN: x `notin` dom Γ)
         (IN: x `in` dom Δ)
         (PER: Permutation Γ Δ),
    False.
Proof.
  ii; apply NIN; analyze_in x; apply Permutation_sym in PER
  ; forwards: Perm_in x PER; simpl_env; fsetdec.
Qed.

Hint Resolve eq_pvar_dec eq_prop_dec.

Hint Resolve requests_one requests_app.

Hint Resolve open_fv_proc_1 open_fv_proc_2 open_nfv_proc_1 open_nfv_proc_2.


(*===========================================================================
    Bit-reader monad

    This is a trivial free monad for sequences of bools, with no functionality
    beyond bind and retn.

    We also provide an implementation in terms of BYTE readers.
  ===========================================================================*)
Require Import ssreflect ssrfun ssrbool finfun fintype ssrnat eqtype seq tuple div.
Require Import bitsrep bitsprops bitsops bitsopsprops cursor monad reader.
Require Import FunctionalExtensionality.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* Term representation for a T-reader *)
Inductive BitReaderTm T :=
| bitReaderRetn (x: T)
| bitReaderNext (rd: bool -> BitReaderTm T).

Class BitReader T := getBitReaderTm : BitReaderTm T.
Definition readNext {T} {R: BitReader T}: BitReader T := R.

Fixpoint bitReaderBind X Y (r: BitReader X) (f: X -> BitReader Y) : BitReader Y :=
  match r with
  | bitReaderRetn r => f r
  | bitReaderNext rd => bitReaderNext (fun b => bitReaderBind (rd b) f)
  end.

Instance bitReaderMonadOps : MonadOps BitReader :=
{ retn := bitReaderRetn
; bind := bitReaderBind }.

Instance bitReaderMonad : Monad BitReader.
Proof. apply Build_Monad.
(* id_l *)
  done.
(* id_r *)
  move => X. elim => //.
  - move => rd IH/=.
    apply f_equal. apply functional_extensionality => b. apply IH.
(* assoc *)
  move => X Y Z. elim => //.
  - move => rd IH f g/=.
    apply f_equal. apply functional_extensionality => b. apply IH.
Qed.

(* We represent a "cursor" for reading and writing bits by a 35-bit value in which the
   most significant 32 bits are the address of a byte, and the least significant 3 bits
   are the index of the current bit that we are reading, with 0 representing the *most*
   significant bit and 7 the least significant (this is the opposite to our usual
   ordering) *)
Definition n35 := n32.+3.
Arguments n35 : simpl never.
Definition BitCursor := Cursor n35.

(* Functional interpretation of bitReader on sequences. Returns the
   final position, the tail of the given sequence and the value
   read. *)
Fixpoint runBitReader T (r:BitReader T) (c: BitCursor) xs: option (BitCursor * seq bool * T):=
  match r with
  | bitReaderRetn x => Some (c, xs, x)
  | bitReaderNext rd =>
    if c is mkCursor p
    then
      if xs is x::xs
      then runBitReader (rd x) (next p) xs
      else None
    else None
  end.

Instance readBit : BitReader bool :=
  bitReaderNext (fun b => bitReaderRetn b).

Lemma runBitReader_bind T U (r: BitReader T) (f: T -> BitReader U) :
  forall x xs ys cursor cursor',
  runBitReader r cursor xs = Some (cursor', ys, x) ->
  runBitReader (bitReaderBind r f) cursor xs = runBitReader (f x) cursor' ys.
Proof. induction r.
+ move => x' xs ys c c' H. simpl in H. by injection H => -> -> ->.
+ move => x xs ys c c' H'. simpl.
  destruct c => //.
  destruct xs => //. simpl in H'. by apply H.
Qed.

Lemma runBitReader_bindNone T U (r: BitReader T) (f: T -> BitReader U) :
  forall xs cursor,
  runBitReader r cursor xs = None ->
  runBitReader (bitReaderBind r f) cursor xs = None.
Proof. induction r.
+ move => xs H. by simpl in H.
+ move => xs cursor H'.
  destruct cursor => //.
  destruct xs => //. simpl in H'.
  by apply H.
Qed.

Definition fromByteCursor (c: DWORDCursor) : BitCursor := widenCursor 3 c.

(* We can use a byte-reader to implement a bit-reader by accumulating the bits of the
   next byte read in a list. Notice the use of reverse: we read bits from msb to lsb. *)
Fixpoint bitReaderToReader t (br: BitReader t) bits : Reader (seq bool * t) :=
match br with
| bitReaderRetn x => readerRetn (bits,x)
| bitReaderNext f =>
  if bits is bit::bits'
  then bitReaderToReader (f bit) bits'
  else
    let! byte = readBYTE;
    let (hi,lo) := splitmsb byte in
    bitReaderToReader (f hi) (rev lo)
end.

(* Convert a sequence of bytes into a sequence of bits, reversing the
   order of bits in each byte *)
Fixpoint toBin (s: seq BYTE) : seq bool :=
  if s is b::rest
  then rev (val b)++toBin rest
  else nil.

(* Convert a sequence of bits into a sequence of bytes and a residue
   of bits smaller than a byte *)
Fixpoint fromBin (s: seq bool) : seq bool * seq BYTE :=
  if s is b7::b6::b5::b4::b3::b2::b1::b0::rest
  then let (resbits, bytes) := fromBin rest
       in (resbits, [tuple b0;b1;b2;b3;b4;b5;b6;b7] :: bytes)
  else (s, nil).

(* Relate the sizes of bit and byte sequences across translation *)
Lemma size_toBin s : size (toBin s) = size s * 8.
Proof. induction s => //=. by rewrite size_cat IHs size_rev size_tuple mulSn. Qed.

Lemma size_fromBin bytes :
  forall bits resbits,
  fromBin bits = (resbits, bytes) ->
  size resbits = size bits %% 8 /\ size bytes = size bits %/ 8.
Proof.
induction bytes => bits resbits /= EQ.
+ do 8 (destruct bits; first by injection EQ => <-). simpl in EQ; by destruct (fromBin bits).
+ do 8 (destruct bits => //).
  simpl in EQ. case E: (fromBin bits) => [resbits' bytes']; rewrite E in EQ.
  injection EQ => [EQ1 EQ2 EQ3]. subst.
  destruct (IHbytes _ _ E) as [I1 I2]. split => /=.
  - by rewrite -2!addn4 -addnA modnDr I1.
  - rewrite -2!addn4 -addnA divnDr => //. by rewrite I2 divnn addn1.
Qed.

(* Roundtrip property *)
Lemma toBinFromBin bytes:
  forall bits resbits, fromBin bits = (resbits, bytes) -> toBin bytes ++ resbits = bits.
Proof. induction bytes => bits resbits EQ/=.
+ do 8 (destruct bits; first by injection EQ). simpl in EQ. by destruct (fromBin bits).
+ do 8 (destruct bits => //=).
case E: (fromBin bits) => [resbits' bytes']. rewrite /= E/= in EQ.
injection EQ => [EQ1 EQ2 EQ3]. subst. by rewrite -(IHbytes _ _ E).
Qed.

(* Invariant for proof of correctness of bitReaderToReader.
     BBInv bitc bits bytec accbits bytes
   holds if the bit reader state (bitc,bits) is equivalent
         to the byte reader state (bytec, accbits, bytes)
*)
Inductive BBInv : BitCursor -> seq bool -> DWORDCursor -> seq bool -> seq BYTE -> Prop :=
| BBInvAligned (p: DWORDCursor) bytes :
  BBInv (fromByteCursor p) (toBin bytes) p nil bytes

| BBInvCons (p: DWORD) accbit accbits bytes :
  size accbits < 7 ->
  BBInv (p ## fromNat (n:=3) (7 - size accbits)) (accbit::accbits++toBin bytes)
  (next p) (accbit::accbits) bytes.

Lemma BBInvProp1 (bytec: DWORD) (byte:BYTE) (bytes: seq BYTE) accbit accbits (p:BITS n35) :
  fromByteCursor bytec = mkCursor p  ->
  rev byte = accbit :: accbits ->
  BBInv p (accbit :: accbits ++ toBin bytes) bytec [::] (byte :: bytes) ->
  BBInv (next p) (accbits ++ toBin bytes) (next bytec) accbits bytes.
Proof. move => E1 E2 INV.
rewrite /fromByteCursor in E1.
have SIZELO: size accbits = 7.
have: size (rev byte) = 8 by rewrite size_rev size_tuple. rewrite E2/=; congruence.
destruct accbits => //.
injection E1 => <-. simpl.
replace (zero 3) with (fromNat (n:=3) 0).
have NC := @nextCat n32 3 bytec 0. rewrite NC => //.
simpl in SIZELO. injection SIZELO => SIZEACCBITS.
replace (fromNat (n:=3) 1) with (fromNat (n:=3) (7 - size accbits)).
apply BBInvCons. by rewrite SIZEACCBITS. by rewrite SIZEACCBITS.
by rewrite fromNat0.
Qed.

Lemma BBInvProp2 (p: DWORD) bytes accbit accbits :
  size accbits < 7 ->
  BBInv (p ## fromNat (n:=3) (7 - size accbits)) (accbit :: accbits ++ toBin bytes)
          (next p) (accbit :: accbits) bytes ->
  BBInv (next (p ## fromNat (n:=3) (7 - size accbits))) (accbits ++ toBin bytes)
     (next p) accbits bytes.
Proof. move => LT INV.
destruct accbits. rewrite /= subn0.
replace (fromNat (n:=3) 7) with (ones 3). rewrite nextCatNext. apply BBInvAligned.
apply toNat_inj. by rewrite toNat_ones toNat_fromNat.
have: next (p ## fromNat (n:=3) (6 - size accbits)) = p ## fromNat (n:=3) (7 - size accbits).
apply cursorToNat_inj. rewrite cursorToNat_next /=.
rewrite 2!toNatCat 2!toNat_fromNat.
rewrite modn_small. rewrite modn_small. rewrite -addn1 -addnA addn1. rewrite -subSn.
done. simpl in LT. rewrite ltnS in LT. by apply ltnW.
by rewrite ltnS/= leq_subr.
apply ltnW.
rewrite ltnS/= ltnS/=. apply leq_subr. move => ->. apply BBInvCons. by apply ltnW.
Qed.

Lemma bitReaderToReader_correctAux t (br: BitReader t) :
  forall bitc bits bytec accbits bytes bitc' bits' v,
  runBitReader br bitc bits = Some (bitc', bits', v) ->
  BBInv bitc bits bytec accbits bytes ->
  exists bytec' accbits' bytes',
  runReader (bitReaderToReader br accbits) bytec bytes =
    Some(bytec',bytes',(accbits',v)) /\ BBInv bitc' bits' bytec' accbits' bytes'.
Proof. induction br => bitc bits bytec accbits bytes bitc' bits' v RBR INV.
+ exists bytec, accbits, bytes. injection RBR => <- <- <-. intuition.
+ inversion INV; subst.
  (* No accumulated bits *)
  - case Ebytes: bytes => [| byte bytes']; subst.
    (* No bytes, so we should fail *)
    * by destruct bytec => //.
    (* At least one byte *)
    * rewrite /= in RBR.
      case E: (splitmsb byte) => [hi lo].
      have EE := splitmsb_rev E.
      rewrite EE/= in RBR.
      case E': (fromByteCursor bytec) => [p |]; rewrite E' in RBR, INV => //.
      rewrite /bitReaderToReader-/bitReaderToReader.
      have SZ: size (rev lo) < 8 by rewrite size_tuple.
      destruct bytec => //.
      specialize (H hi _ _ (next p0) (rev lo) bytes' _ _ _ RBR).
      rewrite /=EE/= in INV.
      have INV' := BBInvProp1 E' EE INV.
      specialize (H INV').
      destruct H as [bytec' [accbits' [bytes'' [H2 H3]]]].
      exists bytec', accbits', bytes''.
      split => //. erewrite runReader_bind. rewrite E. apply H2.
      rewrite runReader_readBYTE. reflexivity.

  (* At least one accumulated bit *)
  - have LT': size accbits0 < 8. apply ltnW. by apply: H0.
    rewrite /fromByteCursor in RBR.
    apply: (H accbit _ _ (next p) accbits0 bytes _ _ _ RBR).
    apply: BBInvProp2 INV => //.
Qed.

(* Note that if bits is non-null then the byte cursor is already advanced to the next
   location *)
Definition bitCursorAndBitsToByteCursor (c:BitCursor) (bits:seq bool) : DWORDCursor :=
  if c is mkCursor p then if bits is nil then mkCursor (@high n32 3 p)
                          else next (@high n32 3 p) else top _.

Corollary bitReaderToReader_correct t (br: BitReader t) :
  forall bytes resbits (cursor: DWORDCursor) (cursor':BitCursor) v,
  runBitReader br (fromByteCursor cursor) (toBin bytes) = Some (cursor', resbits, v) ->
  exists resbytes, exists resbits',
  runReader (bitReaderToReader br nil) cursor bytes =
    Some(bitCursorAndBitsToByteCursor cursor' resbits',resbytes,(resbits',v))
  /\ resbits = resbits' ++ toBin resbytes.
Proof. move => bytes resbits cursor cursor' v RBR.
have BRR:= bitReaderToReader_correctAux RBR (BBInvAligned _ _).
destruct BRR as [bytec' [accbits' [bytes' [H1 H2]]]].
exists bytes', accbits'. rewrite H1. inversion H2; subst.
+ split => //. rewrite /bitCursorAndBitsToByteCursor/fromByteCursor.
  destruct bytec' => //. rewrite /widenCursor. by rewrite high_catB.
+ split => //. by rewrite /bitCursorAndBitsToByteCursor high_catB.
Qed.


Require Import Unicode.Utf8 Program.Equality Logic.FunctionalExtensionality Classes.Morphisms Coq.omega.Omega.
From ctt Require Import Notation OrderTheory Axioms Var Program OpSem TypeSystem.
From ctt Require Tactic.
Module T := Tactic.

Require Import ssreflect.
Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

Module Connective.
  Inductive ctor := void | unit | bool | prod | arr | later | isect | karr.

  Inductive void_el : rel :=.

  Inductive unit_val : rel :=
  | ax : unit_val (Prog.ax, Prog.ax).

  Inductive bool_val : rel :=
  | tt : bool_val (Prog.tt, Prog.tt)
  | ff : bool_val (Prog.ff, Prog.ff).

  Inductive prod_el (R0 : rel) (R1 : Prog.t 0 → rel) : rel :=
  | proj :
      ∀ M0 M1,
        R0 (Prog.fst M0, Prog.fst M1)
        → R1 (Prog.fst M0) (Prog.snd M0, Prog.snd M1)
        → prod_el R0 R1 (M0, M1).

  (* negative definition of pi type *)
  Inductive fun_el (R0 : rel) (R1 : Prog.t 0 → rel) : rel :=
  | app :
      ∀ f0 f1,
        (∀ M0 M1,
            R0 (M0, M1)
            → R1 M0 ((f0 ⋅ M0)%prog, (f1 ⋅ M1)%prog))
        → fun_el R0 R1 (f0, f1).

  Inductive kfun_el (R : 𝕂 → rel) : rel :=
  | kapp :
      ∀ f0 f1,
        (∀ κ, R κ (Prog.kapp f0 κ, Prog.kapp f1 κ))
        → kfun_el R (f0, f1).

  Inductive cext (R : rel) : rel :=
  | mk_cext :
      ∀ M0 M1 v0 v1,
        M0 ⇓ v0
        → M1 ⇓ v1
        → R (v0, v1)
        → cext R (M0, M1).

  Module CExtNotation.
    Notation "[ R ]⇓" := (cext R).
  End CExtNotation.

  Import CExtNotation.

  Inductive has (τ : cts) : ctor → Prog.t 0 × rel → Ω :=
  | has_void : has τ void (Prog.void, void_el)
  | has_unit : has τ unit (Prog.unit, [unit_val]⇓)
  | has_bool : has τ bool (Prog.bool, [bool_val]⇓)
  | has_prod :
      ∀ A0 A1 R0 R1,
        τ (A0, R0)
        → (∀ M0 M1,
              R0 (M0, M1)
              → τ ((A1 ⫽ Sub.inst0 M0)%prog, R1 M0)
                ∧ τ ((A1 ⫽ Sub.inst0 M0)%prog, R1 M1)
                ∧ τ ((A1 ⫽ Sub.inst0 M1)%prog, R1 M1)
                ∧ τ ((A1 ⫽ Sub.inst0 M1)%prog, R1 M0))
        → has τ prod (Prog.prod A0 A1, prod_el R0 R1)
  | has_arr :
      ∀ A0 A1 R0 R1,
        τ (A0, R0)
        → (∀ M0 M1,
              R0 (M0, M1)
              → τ ((A1 ⫽ Sub.inst0 M0)%prog, R1 M0)
                ∧ τ ((A1 ⫽ Sub.inst0 M0)%prog, R1 M1)
                ∧ τ ((A1 ⫽ Sub.inst0 M1)%prog, R1 M1)
                ∧ τ ((A1 ⫽ Sub.inst0 M1)%prog, R1 M0))
        → has τ arr (Prog.arr A0 A1, fun_el R0 R1)

  | has_later :
      ∀ κ B R,
        ▷[κ] (τ (B, R))
        → has τ later (Prog.ltr κ B, fun M0M1 => ▷[κ] (R M0M1))
  | has_isect :
      ∀ B S,
        (∀ κ, τ (B κ, S κ))
        → has τ isect (Prog.isect B, fun M0M1 => ∀ κ, S κ M0M1)
  | has_karr :
      ∀ B S,
        (∀ κ, τ (B κ, S κ))
        → has τ karr (Prog.karr B, kfun_el S).

  Hint Constructors has cext prod_el bool_val unit_val.

  Local Hint Resolve Later.map.
  Theorem monotone : ∀ ι, Proper (Poset.order ==> Poset.order) (fun τ => has τ ι).
  Proof.
    move=> ι τ0 τ1 τ01 [A R] H.
    dependent destruction H;
    try by [eauto].

    constructor.
    + auto.
    + move=> M0 M1 M0M1.
      edestruct H0; eauto.
      T.destruct_conjs.
      repeat split; eauto.
    + constructor; eauto.
      move=> M0 M1 M0M1.
      edestruct H0; eauto;
      T.destruct_conjs;
      repeat split; eauto.
  Qed.

  Hint Resolve monotone.

  Ltac destruct_cext :=
    match goal with
    | H : [_]⇓ _ |- _ => dependent destruction H
    end.
End Connective.

Export Connective.CExtNotation.

Module Sig.
  (* For each refinement cts σ, we define a monotone map on
       refinement matrices which adds the appropriate
       types/rels. *)
  Inductive t (σ τ : cts) : (Prog.t 0 × rel) → Ω :=
  | init :
      ∀ X,
        σ X
        → t σ τ X

  | conn :
      ∀ ι A A0 R,
        A ⇓ A0
        → Connective.has τ ι (A0, R)
        → t σ τ (A, R).

  Instance monotonicity {σ : cts} : Monotone (t σ).
  Proof.
    constructor => τ1 τ2 p [A R].
    case => *.
    + by econstructor.
    + econstructor; try by [eauto];
      apply: Connective.monotone;
      eauto.
  Qed.
End Sig.

Module Clo.
  Program Definition t (σ : cts) := LFP.t (Sig.t σ).

  Theorem roll : ∀ σ, Sig.t σ (t σ) = t σ.
  Proof.
    move=> σ.
    apply: binrel_extensionality => [A R].
    T.split => [X | X]; [rewrite /t|].
    - rewrite -LFP.roll; eauto.
    - rewrite LFP.roll; eauto.
  Qed.

  Lemma map_has {σ ρ ι A R} :
    ρ ⊑ σ
    → Connective.has ρ ι (A, R)
    → Connective.has σ ι (A, R).
  Proof.
    move=> sub has.
    dependent destruction has; eauto.
    - constructor; eauto.
      move=> M0 M1 M01.
      edestruct H0; T.destruct_conjs; repeat split; eauto.
    - constructor; eauto.
      move=> M0 M1 M01.
      edestruct H0; T.destruct_conjs; repeat split; eauto.
    - constructor.
      Later.gather; eauto.
  Qed.

  Theorem ind :
    ∀ Y (σ ρ : cts),
      t σ Y
      → (∀ X, σ X → ρ X)
      → (∀ ι A A0 R, A ⇓ A0 → Connective.has ρ ι (A0, R) → ρ (A, R))
      → ρ Y.
  Proof.
    move=> [A R] σ ρ AcloR init conn.
    rewrite /t /LFP.t in AcloR.
    simpl in AcloR.
    rewrite -/cts in AcloR.

    destruct AcloR.
    destruct H.
    apply: H; auto.
    move=> [A' R']; elim; eauto.
  Qed.

  Local Hint Constructors Sig.t.

  Ltac elim_clo :=
    let x := fresh in
    move=> x;
    apply: (ind x).

  Instance monotonicity : Monotone t.
  Proof.
    split; move=> ? ? ? ?.
    elim_clo => *; rewrite -roll; eauto.
  Qed.

  Ltac use_universe_system :=
    match goal with
    | H : TS.universe_system ?σ, H' : ?σ ?X |- _ =>
      destruct H as [H]; destruct (H X H')
    end.

  Local Ltac rewrite_functionality_ih :=
    repeat match goal with
    | ih : TS.extensional_at _ _ |- _ =>
      rewrite /TS.extensional_at in ih;
      simpl in ih;
      erewrite ih
    end.

  Local Ltac moves :=
    move=> *.

  Ltac destruct_sig :=
    match goal with
    | H : Sig.t _ _ _ |- _ => dependent destruction H
    end.

  Ltac ind_sig :=
    match goal with
    | H : Sig.t _ _ _ |- _ => dependent induction H
    end.

  Ltac destruct_has :=
    match goal with
    | H : Connective.has _ _ _ |- _ => dependent destruction H
    end.

  Ltac destruct_clo :=
    match goal with
    | H : t _ _ |- _ => rewrite -roll in H; dependent destruction H
    end.

  Theorem connective_not_universe {τ i ι A' A R} {P : Ω} :
    Connective.has τ ι (A', R)
    → A ⇓ A'
    → A ⇓ Prog.univ i
    → P.
  Proof.
    move=> has eval1 eval2.
    dependent destruction has;
    by OpSem.evals_to_eq.
  Qed.

  Local Ltac cleanup :=
    simpl in *;
    try use_universe_system;
    OpSem.evals_to_eq;
    T.destruct_eqs;
    auto.

  Instance extensionality {σ} :
    TS.universe_system σ
    → TS.extensional σ
    → TS.extensional (t σ).
  Proof.
    move=> ? [ext]; constructor => ? ?; elim_clo; clear H.

    - move=> [? ?] ? ? ?.
      destruct_clo.
      + by apply: ext.
      + use_universe_system.
        destruct_has; by OpSem.evals_to_eq.

    - move=> ? ? ? ? ? ?; simpl in *.
      destruct_has => ? ?;
      destruct_clo; try by [cleanup];
      destruct_has; cleanup.

      + T.eqcd; case => M0 M1; apply: propositional_extensionality; split => M0M1.
        * dependent destruction M0M1.
          constructor.
          ** replace R2 with R0; eauto.
          ** replace (R3 (M0 .1)%prog) with (R1 (M0 .1)%prog); eauto.
             destruct (H0 (M0.1)%prog (M1.1)%prog) as [H01 [H02 [H03 H04]]]; auto.
             replace R2 with R0 in H3; eauto.
             destruct (H3 (M0.1)%prog (M1.1)%prog); eauto.
        * dependent destruction M0M1.
          constructor.
          ** replace R0 with R2; auto.
             symmetry; eauto.
          ** replace (R1 (M0.1)%prog) with (R3 (M0.1)%prog); eauto.
             destruct (H0 (M0.1)%prog (M1.1)%prog) as [H01 [H02 [H03 H04]]]; eauto.
             *** replace R0 with R2; eauto.
                 symmetry; eauto.
             *** symmetry.
                 apply: H01; eauto.
                 destruct (H3 (M0.1)%prog (M1.1)%prog); eauto.
      + T.eqcd; case => f0 f1; apply: propositional_extensionality; split => f0f1.
        * dependent destruction f0f1.
          constructor => M0 M1 M0M1.
          replace (R3 M0) with (R1 M0).
          ** apply: H1.
             replace R0 with R2; auto.
             symmetry.
             apply: H; auto.
          ** edestruct H0; eauto.
             *** replace R0 with R2; eauto.
                 symmetry; apply: H; eauto.
             *** edestruct H3; eauto.
        * dependent destruction f0f1.
          constructor => M0 M1 M0M1.
          replace (R1 M0) with (R3 M0).
          ** apply: H1.
             replace R2 with R0; auto.
          ** edestruct H0; eauto.
             *** edestruct H3; eauto.
                 **** replace R2 with R0; eauto.
                 **** T.destruct_conjs; symmetry; auto.

      + do ? (T.eqcd; moves).
        Later.gather => *; T.destruct_conjs.
        rewrite_functionality_ih; eauto.
      + do ? (T.eqcd; moves).
        T.specialize_hyps.
        rewrite_functionality_ih; eauto.
      + replace S0 with S; auto.
        T.eqcd => κ.
        T.specialize_hyps.
        apply: H; auto.
  Qed.

  Theorem cext_per {R} :
    is_per R
    → is_per [R]⇓.
  Proof.
    move=> [ihSm ihTr].
    constructor.
    - move=> M0 M1 H1.
      dependent destruction H1.
      econstructor; eauto.
    - move=> M0 M1 M2 H1 H2.
      dependent destruction H1.
      dependent destruction H2.
      OpSem.evals_to_eq.
      T.destruct_eqs.
      econstructor; eauto.
  Qed.

  Theorem unit_val_per : is_per Connective.unit_val.
  Proof.
    constructor.
    - move=> M0 M1 H1.
      by dependent destruction H1.
    - move=> ? ? ? H1 H2.
      by [dependent destruction H1;
          dependent destruction H2].
  Qed.

  Theorem bool_val_per : is_per Connective.bool_val.
  Proof.
    constructor.
    - move=> M0 M1 H1.
      by dependent destruction H1.
    - move=> ? ? ? H1 H2.
      by [dependent destruction H1;
          dependent destruction H2].
  Qed.

  Theorem cext_computational {R} :
    rel_computational [R]⇓.
  Proof.
    move=> M0 M1 M2 M01 cext.
    Connective.destruct_cext.
    econstructor; eauto.
  Qed.

  Hint Resolve cext_per cext_computational unit_val_per bool_val_per cext_per.
  Hint Constructors is_cper.

  (* HORRIFIC *)
  Instance cper_valued {σ} :
    TS.cper_valued σ
    → TS.extensional σ
    → TS.universe_system σ
    → TS.cper_valued (t σ).
  Proof.
    move=> [IH] ext uni; constructor => A R 𝒟.
    destruct (@ind (A, R) σ (fun X => t σ X ∧ is_cper (snd X))); auto; move {𝒟 A R}.
    - move=> [A R] 𝒟.
      split.
      + rewrite -roll.
        by apply: Sig.init.
      + eauto.

    - move=> ι A' A'0 R' 𝒟' ℰ //=; split.
      + rewrite -roll.
        apply: Sig.conn; eauto.
        apply: map_has; last by eauto.
        move=> ? [? ?] //=.

      + destruct_has; simpl in *; try by [constructor; eauto]; cleanup.
        * constructor.
          ** constructor.
             *** move=> M0 M1 M01.
                 dependent destruction M01.
                 constructor.
                 **** apply: symmetric; auto.
                      apply: per; by destruct H.
                 **** replace (R1 (M1.1)%prog) with (R1 (M0.1)%prog);
                      edestruct H0; T.destruct_conjs; eauto.
                      ***** apply: symmetric; auto.
                            by apply: per.
                      ***** apply: (TS.is_extensional (t σ)); eauto.

             *** move=> M0 M1 M2 M01 M12.
                 dependent destruction M01.
                 dependent destruction M12.
                 destruct H.
                 constructor.

                 **** apply: transitive; eauto.
                      edestruct H0; eauto.
                      T.destruct_conjs.
                      by apply: per.
                 **** replace (R1 (M1.1)%prog) with (R1 (M0.1)%prog) in H4.
                      ***** apply: transitive; eauto.
                            edestruct (H0 (M0.1)%prog); eauto.
                            T.destruct_conjs.
                            by apply: per.
                      ***** edestruct (H0 (M0.1)%prog); eauto.
                            T.destruct_conjs.
                            apply: (TS.is_extensional (t σ)); eauto.

          ** move=> M0 M1 M2 M0M1 el.
             dependent destruction el.
             destruct H.
             constructor.
             *** apply: crel; first by [auto]; last by eauto.
                 by apply: fst_cong_approx.
             *** replace (R1 (M1.1)%prog) with (R1 (M0.1)%prog).
                 **** apply: crel; last by eauto.
                      ***** edestruct H0; eauto; T.destruct_conjs; eauto.
                      ***** by apply: snd_cong_approx.
                 **** edestruct (H0 (M1.1)%prog (M0.1)%prog); eauto.
                      ***** suff H4: R0 ((M0.1)%prog, (M0.1)%prog).
                            ****** apply: crel; [auto|apply: fst_cong_approx M0M1|eauto].
                            ****** apply: transitive; first by [apply: per].
                            ******* eauto.
                            ******* apply: symmetric; first by [apply: per]; eauto.
                      ***** T.destruct_conjs.
                            apply: (TS.is_extensional (t σ)); eauto.

        * destruct H.
          constructor.
          ** constructor.
             *** move=> f0 f1 f01.
                 dependent destruction f01.
                 constructor=> M0 M1 M01.
                 destruct H.
                 apply: symmetric; auto.
                 **** edestruct H0; T.destruct_conjs; eauto.
                      by apply: per.
                 **** replace (R1 M0) with (R1 M1).
                      ***** apply: H2; auto.
                            apply: symmetric; auto.
                            apply: per; auto.
                      ***** edestruct H0; eauto.
                            T.destruct_conjs.
                            apply: (TS.is_extensional (t σ)); eauto.
             *** move=> f0 f1 f2 f01 f12.
                 dependent destruction f01.
                 dependent destruction f12.
                 constructor=> M0 M1 M01.
                 apply: transitive.
                 **** edestruct H0; eauto.
                      T.destruct_conjs.
                      by apply: per.
                 **** apply: H2.
                      eauto.
                 **** replace (R1 M0) with (R1 M1).
                      ***** apply: H3; eauto.
                            apply: transitive; first by [apply: per]; eauto.
                            apply: symmetric; first by [apply: per]; eauto.
                      ***** edestruct H0; eauto.
                            T.destruct_conjs.
                            apply: (TS.is_extensional (t σ)); eauto.
          ** move=> f0 f1 f2 f01 H2.
             dependent destruction H2.
             constructor.
             move=> M0 M1 M0M1.
             apply: crel.
             *** edestruct H0; eauto; T.destruct_conjs; eauto.
             *** apply: app_cong_approx; exact f01.
             *** apply: H2; auto.

        * constructor.
          ** constructor.
             *** move=> M0 M1 H1.
                 Later.gather.
                 move=> //= [[ihR0 ?] M0M1].
                 apply: symmetric; eauto; apply: per; eauto.

             *** move=> M0 M1 M2 H1 H2.
                 Later.gather.
                 move=> //= [[? ?] [M0M1 M1M2]].
                 apply: transitive; eauto.
                 by apply: per.
          ** move=> ? ? ? ? ?.
             Later.gather.
             move=> [[? ?] ?].
             apply: crel; eauto.

        * constructor.
          ** constructor.
             *** move=> ? ? ? ?.
                 T.specialize_hyps.
                 case: H => //= [? ?].
                 apply: symmetric; auto.
                 by apply: per.
             *** move=> ? ? ? ? ? ?.
                 T.specialize_hyps.
                 case: H => //= [? ?].
                 apply: transitive; eauto.
                 by apply: per.
          ** move=> ? ? ? ? ?  ?.
             T.specialize_hyps.
             T.destruct_conjs.
             apply: crel; eauto.

        * constructor.
          ** constructor.
             *** move=> M0 M1 H1.
                 dependent destruction H1.
                 constructor => κ.
                 T.specialize_hyps.
                 T.destruct_conjs.
                 apply: symmetric; eauto.
                 apply: per; eauto.
             *** move=> M0 M1 M2 H1 H2.
                 dependent destruction H1.
                 dependent destruction H2.
                 constructor => κ.
                 T.specialize_hyps.
                 T.destruct_conjs.
                 apply: transitive; first (apply: per); eauto.
          ** constructor => κ.
             dependent destruction H1.
             T.specialize_hyps.
             T.destruct_conjs.
             apply: crel.
             *** auto.
             *** apply: OpSem.kapp_cong_approx; eauto.
             *** auto.
  Qed.

  Instance type_computational {σ} :
    TS.type_computational σ
    → TS.type_computational (t σ).
  Proof.
    move=> [ih]; constructor => ? ?; elim_clo.
    - move=> [A0 R] 𝒟 A1 //= A01.
      rewrite -roll.
      apply: Sig.init.
      apply: ih; eauto.
    - move=> ι A0 A0v R 𝒟 ℰ.
      destruct_has => ? //= ?;
      rewrite -roll; apply: Sig.conn; eauto.
      + constructor; eauto.
        move=> M0 M1 M01; destruct (H1 M0 M1); eauto.
        T.destruct_conjs.
        repeat split; eauto.
      + constructor; eauto.
        move=> M0 M1 M01; destruct (H1 M0 M1);
        T.destruct_conjs;
        repeat split; eauto.
      + constructor.
        Later.gather.
        eauto.
      + constructor.
        move=> κ.
        T.specialize_hyps.
        eauto.
      + constructor.
        move=> κ.
        T.specialize_hyps.
        eauto.
  Qed.
End Clo.


Require Import AutoSep Malloc.
Require Import List.

Set Implicit Arguments.

(** The king of the abstract predicates *)

Module Type SINGLY_LINKED_LIST.
  Parameter sll : list W -> W -> HProp.

  Axiom sll_extensional : forall ls p, HProp_extensional (sll ls p).

  Axiom nil_fwd : forall ls (p : W), p = 0
    -> sll ls p ===> [| ls = nil |].

  Axiom nil_bwd : forall ls (p : W), p = 0
    -> [| ls = nil |] ===> sll ls p.

  Axiom cons_fwd : forall ls (p : W), p <> 0
    -> sll ls p ===> [| freeable p 2 |] * Ex x, Ex ls', [| ls = x :: ls' |] * Ex p', (p ==*> x, p') * sll ls' p'.

  Axiom cons_bwd : forall ls (p : W), p <> 0
    -> ([| freeable p 2 |] * Ex x, Ex ls', [| ls = x :: ls' |] * Ex p', (p ==*> x, p') * sll ls' p') ===> sll ls p.
End SINGLY_LINKED_LIST.

Module SinglyLinkedList : SINGLY_LINKED_LIST.
  Open Scope Sep_scope.

  Fixpoint sll (ls : list W) (p : W) : HProp :=
    match ls with
      | nil => [| p = 0 |]
      | x :: ls' => [| freeable p 2 |] * [| p <> 0 |] * Ex p', (p ==*> x, p') * sll ls' p'
    end.

  Theorem sll_extensional : forall ls (p : W), HProp_extensional (sll ls p).
    destruct ls; reflexivity.
  Qed.

  Theorem nil_fwd : forall ls (p : W), p = 0
    -> sll ls p ===> [| ls = nil |].
    destruct ls; sepLemma.
  Qed.

  Theorem nil_bwd : forall ls (p : W), p = 0
    -> [| ls = nil |] ===> sll ls p.
    destruct ls; sepLemma.
  Qed.

  Theorem cons_fwd : forall ls (p : W), p <> 0
    -> sll ls p ===> [| freeable p 2 |] * Ex x, Ex ls', [| ls = x :: ls' |] * Ex p', (p ==*> x, p') * sll ls' p'.
    destruct ls; sepLemma.
  Qed.

  Theorem cons_bwd : forall ls (p : W), p <> 0
    -> ([| freeable p 2 |] * Ex x, Ex ls', [| ls = x :: ls' |] * Ex p', (p ==*> x, p') * sll ls' p') ===> sll ls p.
    destruct ls; sepLemma;
      match goal with
        | [ H : _ :: _ = _ :: _ |- _ ] => injection H; sepLemma
      end.
  Qed.
End SinglyLinkedList.

Import SinglyLinkedList.
Export SinglyLinkedList.
Hint Immediate sll_extensional.

Definition hints : TacPackage.
  prepare (nil_fwd, cons_fwd) (nil_bwd, cons_bwd).
Defined.


From mathcomp Require Import all_ssreflect.

(* ---------------------------------------------------------------------- *)
(* ** Position markers *)
(** ** ポジションマーカ *)

(* [ltac_Mark] and [ltac_mark] are dummy definitions used as sentinel
    by tactics, to mark a certain position in the context or in the goal. *)
(** [ltac_Mark]と[ltac_mark]は、コンテキストまたはゴールにおいて、
    特定のポジションにマークをつけるために、
    タクティックが使う標識のダミーの定義です。*)

Inductive ltac_Mark : Type :=
  | ltac_mark : ltac_Mark.

(* [gen_until_mark] repeats [generalize] on hypotheses from the
    context, starting from the bottom and stopping as soon as reaching
    an hypothesis of type [Mark]. If fails if [Mark] does not
    appear in the context. *)
(** [gen_until_mark]はコンテキストの一番下の仮定から型[Mark]の仮定に逹するまで
    [generalize]を繰り返します。
    コンテキストに[Mark]が現れないときは失敗します。 *)

Ltac gen_until_mark :=
  match goal with H: ?T |- _ =>
  match T with
  | ltac_Mark => clear H
  | _ => generalize H; clear H; gen_until_mark
  end end.

(* [intro_until_mark] repeats [intro] until reaching an hypothesis of
    type [Mark]. It throws away the hypothesis [Mark].
    It fails if [Mark] does not appear as an hypothesis in the
    goal. *)
(** [intro_until_mark]は型[Mark]の仮定に逹するまで[intro]を繰り返します。
    そしてその仮定[Mark]を廃棄します。
    ゴールの仮定に[Mark]が現れないときには失敗します。 *)

Ltac intro_until_mark :=
  match goal with
  | |- (ltac_Mark -> _) => intros _
  | _ => intro; intro_until_mark
  end.

(* ********************************************************************** *)
(* * Inversion *)
(** * 反転(Inversion) *)

(** [invert keep H] は [inversion H] と同様ですが、
    得られた事実をすべてゴールに置く点が違います。キーワード[keep]
    は仮定[H]を除去しないでおくことを意味します。 *)

Tactic Notation "invert" "keep" hyp(H) :=
  pose ltac_mark; inversion H; gen_until_mark.

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

(* !! NEW !! *)

(* subst を行ってから、残った前提を generalize する。 *)
Tactic Notation "inv:" hyp(H) :=
  pose ltac_mark; inversion H; subst; gen_until_mark.

Tactic Notation "inv" :=
  let H := fresh in intro H; inv: H; clear H.

Tactic Notation "invs:" hyp(H) :=
  pose ltac_mark; inversion H; subst; try done; gen_until_mark.

Tactic Notation "invs" :=
  let H := fresh in intro H; invs: H; clear H.

(*
Tactic Notation "inv:" hyp(H) simple_intropattern(I1) :=
  generalize I1;
  inv: H.

Tactic Notation "inv:" hyp(H)
       simple_intropattern(I1) simple_intropattern(I2) :=
  generalize I2; generalize I1;
  inv: H.

Tactic Notation "inv:" hyp(H)
       simple_intropattern(I1) simple_intropattern(I2) simple_intropattern(I3) :=
  generalize I3; generalize I2; generalize I1;
  inv: H.
*)

(* END *)


From Undecidability.L Require Export Util.L_facts.
From Undecidability.L.Tactics Require Import Reflection ComputableTime mixedTactics.

(* ** Symbolic simplification for L*)

(* *** Lproc *)

(* This module provides tactics fLproc and Lproc that solve goals of the form [lambda s] or [proc s] or [closed s] for L-terms [s]. *)

#[export] Hint Resolve rho_lambda rho_cls : LProc.

Lemma proc_closed p : proc p -> closed p.
Proof.
  firstorder intuition.
Qed.

Lemma proc_lambda p : proc p -> lambda p.
Proof.
  firstorder intuition.
Qed.

Ltac fLproc :=intros;
              once lazymatch goal with
              | [ |- proc _ ] => split;fLproc
              | [ |- lambda ?s ] => eexists; reflexivity || fail "Prooving 'lambda " s " ' by computation failed. It is either not a fixed term, some used identifier is opaqie or the goal does not hold"
              | [ |- closed ?s ] => vm_compute; reflexivity || fail "Prooving 'closed " s " ' by computation failed. It is either not a fixed term, some used identifier is opaque or the goal does not hold"
              end.

Ltac Lproc' :=idtac;
  once lazymatch goal with
  | |- bound _ (L.app _ _) => refine (dclApp _ _)
  | |- bound _ (L.lam _) => refine (dcllam _)
  | |- bound ?y (L.var ?x) => exact (dclvar (proj1 (Nat.ltb_lt x y) eq_refl))
  | |- lambda (match ?c with _ => _ end) => destruct c
  | |- lambda (@enc ?t ?H ?x) => exact_no_check (proc_lambda (@proc_enc t H x))
  | |- lambda (@ext ?X ?tt ?x ?H) => exact_no_check (proc_lambda (@proc_ext X tt x H))
  | |- lambda (@extT ?X ?tt ?x ?f ?H) => exact_no_check (proc_lambda (@proc_extT X tt x f H))
  | |- lambda (app _ _) => fail
  (*| |- lambda (@ext_ext ?X ?x ?H) => exact (proc_lambda (@proc_extT X tt x _))*)
  | |- lambda _ => (simple apply proc_lambda;(trivial with nocore LProc || tauto)) || tauto || (eexists;reflexivity)
  | |- rClosed ?phi _ => solve [simple apply rClosed_decb_correct;[assumption|reflexivity]]
  | |- L_facts.closed ?s => refine (proj2 (closed_dcl s) _)
  | |- bound _  (match ?c with _ => _ end) => destruct c
  | |- bound _ (rho ?s) => simple apply rho_dcls
  | |- bound ?k (@ext ?X ?tt ?x ?H) =>
    exact_no_check (closed_dcl_x k (proc_closed (@proc_ext X tt x H)))
  | |- bound ?k (@extT ?X ?tt ?x ?f ?H) =>
    exact_no_check (closed_dcl_x k (proc_closed (@proc_extT X tt x f H)))
  (*| |- bound ?k (@extT ?X ?tt ?x ?H) =>
      exact (closed_dcl_x k (proc_closed (@extT_proc X tt x H)))*)
  | |- bound ?k (@enc ?t ?H ?x) =>
    exact_no_check (closed_dcl_x k (proc_closed (@proc_enc t H x)))
  | |- bound ?k ?s => (refine (@closed_dcl_x k s _); (trivial with LProc || (apply proc_closed;trivial with LProc || tauto) || tauto ))
  | |- ?s => idtac s;fail 1000
  end.

(* early abort for speed!*)

Ltac Lproc := (* match goal with |- ?G => idtac G end ;time "Lproc"( *)
  lazymatch goal with
  | |- proc (app _ _) => fail
  | |- proc (@enc ?t ?H ?x) => exact_no_check (@proc_enc t H x)
  | |- proc (@ext ?X ?tt ?x ?H) => exact_no_check (@proc_ext X tt x H)
  | |- proc (@extT ?X ?tt ?x ?f ?H) => exact_no_check (@proc_extT X tt x f H)

  | |- proc _ => refine (conj _ _);[|solve [Lproc]];Lproc

  | |- closed _ => solve [repeat' Lproc']

  | |- lambda (app _ _) => fail
  | |- lambda _ => repeat' Lproc'
  | s := ?t |- ?p ?s => change (p t);Lproc
         end.


(* monads implemented in terms of fmap & join & return instead of bind & return *)
Require Import Coq.Lists.List.

Class Monad(M: Type -> Type) := mkMonad {
  ret: forall {A}, A -> M A;
  mmap: forall {A B}, (A -> B) -> M A -> M B;
  join: forall {A}, M (M A) -> M A;
}.

Definition bind{M: Type -> Type}{MM: Monad M}{A B: Type}(m: M A)(f: A -> M B): M B :=
  join (mmap f m).

Declare Scope monad_scope.

Notation "x <- m1 ; m2" := (bind m1 (fun x => m2))
  (right associativity, at level 60) : monad_scope.
Notation "m1 ;; m2" := (bind m1 (fun _ => m2))
  (right associativity, at level 60) : monad_scope.

Open Scope monad_scope.

Definition Id: Type -> Type := id.

#[global] Instance Id_monad: Monad Id := {|
  ret := @id;
  mmap A B := @id (A -> B);
  join := @id;
|}.

Record optionT(M: Type -> Type)(A: Type): Type := mkOptionT {
  runOptionT: M (option A)
}.
Arguments mkOptionT {M} {A} (_).
Arguments runOptionT {M} {A} (_).

Definition retOption{A}: A -> option A := Some.

Definition mapOption{A B}(f: A -> B)(oa: option A): option B :=
  match oa with
  | Some a => Some (f a)
  | None => None
  end.

Definition flattenOption{A}(ooa: option (option A)): option A :=
  match ooa with
  | Some (Some a) => Some a
  | _ => None
  end.

#[global] Instance OptionT_Monad(M: Type -> Type){MM: Monad M}: Monad (optionT M) := {|
  ret A (a: A) := mkOptionT (ret (retOption a));
  mmap A B (f: A -> B)(oma: optionT M A) :=
    mkOptionT (mmap (mapOption f)
                    (runOptionT oma));
  join A (omoma: (optionT M) ((optionT M) A)) :=
    mkOptionT (join (mmap (fun (ooma: option (optionT M A)) =>
                             match ooma with
                             | Some oma => runOptionT oma
                             | None => ret None
                             end)
                          (runOptionT omoma)));
|}.

Definition retList{A}(a: A): list A := cons a nil.

Definition mapList: forall {A B: Type}, (A -> B) -> list A -> list B := @List.map.

Definition flattenList: forall {A}, list (list A) -> list A := @List.concat.

Record listT(M: Type -> Type)(A: Type): Type := mkListT {
  runListT: M (list A)
}.
Arguments mkListT {M} {A} (_).
Arguments runListT {M} {A} (_).

#[global] Instance listT_Monad(M: Type -> Type){MM: Monad M}: Monad (listT M) := {|
  ret A (a: A) := mkListT (ret (retList a));
  mmap A B (f: A -> B)(nma: listT M A) :=
    mkListT (mmap (mapList f)
                  (runListT nma));
  join A (nmnma: (listT M) ((listT M) A)) :=
    mkListT (join (mmap (fun nnma =>
                           fold_left
                             (fun (acc: M (list A)) (elem: listT M A) =>
                                l1 <- runListT elem; l2 <- acc; ret (l1 ++ l2))
                             nnma
                             (ret nil))
                        (runListT nmnma)));
|}.

Definition State(S A: Type) := S -> (A * S).

Record StateT(S: Type)(M: Type -> Type)(A: Type): Type := mkStateT {
  runStateT: S -> M (A * S)%type
}.
Arguments mkStateT {S} {M} {A} (_).
Arguments runStateT {S} {M} {A} (_).

#[global] Instance StateT_Monad(S: Type)(M: Type -> Type){MM: Monad M}: Monad (StateT S M) := {|
  ret A (a: A) := mkStateT (fun s => ret (a, s));
  mmap A B (f: A -> B)(sma: StateT S M A) :=
    mkStateT (fun s => mmap (fun '(a, s0) => (f a, s0)) (runStateT sma s));
  join A (smsma: (StateT S M) ((StateT S M) A)) :=
    mkStateT (fun s1 => p <- runStateT smsma s1; let '(ssma, s2) := p in runStateT ssma s2);
|}.

Definition get{S: Type}{M: Type -> Type}{MM: Monad M}: StateT S M S :=
  mkStateT (fun (s: S) => ret (s, s)).

Definition put{S: Type}{M: Type -> Type}{MM: Monad M}(s: S): StateT S M unit :=
  mkStateT (fun _ => ret (tt, s)).

(*
These are not very useful because often we'll have to write
"lift (t := optionT)" instead of just "lift" to prevent typeclass
search from looping infinitely, so we prefer to just define lift_xxxT
separately

Class MonadTrans(t: (Type -> Type) -> Type -> Type) := {
  lift: forall {M: Type -> Type} {MM: Monad M} {A: Type}, M A -> t M A;
}.

Instance optionT_MonadTrans: MonadTrans optionT := {
  lift{M}{MM}{A}(m: M A) := mkOptionT (mmap Some m);
}.

Instance stateT_MonadTrans(S: Type): MonadTrans (StateT S) := {
  lift{M}{MM}{A}(m: M A) := mkStateT (fun s => a <- m; ret (a, s));
}.

Instance listT_MonadTrans: MonadTrans listT := {
  lift{M}{MM}{A}(m: M A) := mkListT (mmap (fun a => cons a nil) m);
}.
*)

Definition liftOptionT{M: Type -> Type}{MM: Monad M}{A: Type}(m: M A): optionT M A :=
  mkOptionT (mmap Some m).

Definition liftStateT{S: Type}{M: Type -> Type}{MM: Monad M}{A: Type}(m: M A): StateT S M A :=
  mkStateT (fun s => a <- m; ret (a, s)).

Definition liftListT{M: Type -> Type}{MM: Monad M}{A: Type}(m: M A): listT M A :=
  mkListT (mmap (fun a => cons a nil) m).

(*
   Note: No way of composing
     NonDet A := list A
   and
     State S A := S -> (A * S)
   results in this signature!
*)
Definition NDS(S A: Type): Type := S -> list (A * S).

Record NDStateT(S: Type)(M: Type -> Type)(A: Type): Type := mkNDStateT {
  runNDStateT: S -> M (A * S)%type (* TODO where to put list ?? *)
}.
Arguments mkNDStateT {S} {M} {A} (_).
Arguments runNDStateT {S} {M} {A} (_).

(*
Instance NDStateT_Monad(S: Type)(M: Type -> Type){MM: Monad M}: Monad (NDStateT S M) := {|
  ret{A}(a: A) := mkStateT (fun s => ret (a, s));
  mmap{A B}(f: A -> B)(sma: StateT S M A) :=
    mkStateT (fun s => mmap (fun '(a, s0) => (f a, s0)) (runStateT sma s));
  join{A}(smsma: (StateT S M) ((StateT S M) A)) :=
    mkStateT (fun s1 => p <- runStateT smsma s1; let '(ssma, s2) := p in runStateT ssma s2);
|}.
*)

(* note: no "pick" is needed as argument here *)
#[global] Instance NDS_Monad(S: Type): Monad (NDS S) := {|
  ret A (a: A) :=
    fun s => cons (a, s) nil;
  mmap A B (f: A -> B)(m: NDS S A) :=
    fun s => List.map (fun '(a, s) => (f a, s)) (m s);
  join A (mm: NDS S (NDS S A)) :=
    fun s1 => List.concat (List.map (fun '(m, s2) => m s2) (mm s1));
|}.

(*
Definition NDS(S A: Type): Type := S -> (A * S) -> Prop.

Instance NDS_Monad(S: Type)(pick: forall (A: Type), NDS S A): Monad (NDS S) := {|
  ret{A}(a: A) := fun s1 '(v, s2) => s1 = s2 /\ a = v;
  mmap{A B}(f: A -> B)(m: NDS S A) := fun s1 '(b, s2) => _;
  join{A}(mm: NDS S (NDS S A)) := _;
|}.
*)

Module way1.

  Definition OState(S: Type): Type -> Type := StateT S (optionT Id).

  Definition runOState{S A: Type}(m: OState S A)(s: S): option (A * S) :=
    runOptionT (runStateT m s).

End way1.

Definition OState(S: Type): Type -> Type := optionT (StateT S Id).

Definition runOState{S A: Type}(m: OState S A)(s: S): option A * S :=
  runStateT (runOptionT m) s.

Definition OStateND(S: Type): Type -> Type := optionT (NDS S).

Definition runOStateND{S A: Type}(m: OStateND S A)(s: S): list (option A * S) :=
 runOptionT m s.

Section Test.

  Context {M: Type -> Type}.
  Axiom run1: M unit.
End Test.

(*
Axiom RiscvMachine: Type.
(*Check (@lift optionT _ _ _ _ get).*)
Check (@run1 (OStateND RiscvMachine);; liftListT (liftOptionT get)).
Check (runOStateND (@run1 (OStateND RiscvMachine);; liftListT (liftOptionT get))).

Definition comp1: OStateND (nat * nat) nat :=
  both <- liftListT (liftOptionT get); ret (fst both).

Definition comp20: OStateND (nat * nat) nat.
  refine (liftListT ( _)).
  unfold OState.
  refine (mkOptionT _).
  refine (ret None).
Defined.

Definition comp2: OStateND (nat * nat) nat :=
  liftListT (mkOptionT (ret None)).

Definition comp12: OStateND (nat * nat) nat :=
  c1 <- comp1;
  c2 <- comp2;
  ret (c1 + c2)%nat.

Compute (runOStateND comp12 (12, 23)).

Definition rvRunND(s: RiscvMachine): option (list RiscvMachine) :=
  fst (runOStateND (@run1 (OStateND RiscvMachine);; liftListT (liftOptionT get)) s).
*)

Section RunsTo.

  Variable State: Type.
  Variable step: State -> option (list State).

(* something is wrong: it should be "list (option State)":
  some nondet choices fail, others succeed.
  But maybe the way we compose, the monad already does the collecting for us,
  and only returns Some if all choices succeeded?
 *)

(*
  Inductive runsTo(initial: State)(P: State -> Prop): Prop :=
    | runsToDone:
        P initial ->
        runsTo initial P
    | runsToStep:
        (forall omid,
            step initial omid ->
            exists mids, omid = Some mids /\
                        List.Forall (fun mid => runsTo mid P) mids) ->
        runsTo initial P.
*)
End RunsTo.