Require Import CSPEC.
Require Import String.
Require Import Equalities.
Require Import Relations.Relation_Operators.
Require Import RelationClasses.
Require Import Morphisms.
Require Import Sumbool.
Require Import ProofIrrelevance.

Import ListNotations.
Open Scope string.

(** Data types *)

Inductive Node :=
| DirNode : forall (dirnum : nat), Node
| FileNode : forall (filenum : nat), Node.

Record Link := mkLink {
  LinkFrom : nat;   (* Always a DirNode *)
  LinkTo : Node;
  LinkName : string
}.

Instance Node_equal_dec : EqualDec Node.
Proof.
  unfold EqualDec.
  decide equality;
    match goal with
    | [ |- {?x = ?y} + {_} ] =>
      destruct (x == y); eauto
    end.
Defined.

Lemma Link_equal_dec : EqualDec Link.
  unfold EqualDec.
  decide equality;
    match goal with
    | [ |- {?x = ?y} + {_} ] =>
      destruct (x == y); eauto
    end.
Defined.

Instance Node_Ordering : Ordering Node.
Proof.
  eapply (injection_Ordering (nat + nat + list string)).
  typeclasses eauto.
  unshelve econstructor; intros.
  destruct H; [ left; left | left; right ]; eauto.
  destruct x, y; simpl in *; congruence.
Defined.

Instance Link_Ordering : Ordering Link.
Proof.
  eapply (injection_Ordering (nat * Node * string)%type).
  typeclasses eauto.

  unshelve econstructor; intros.
  exact (H.(LinkFrom), H.(LinkTo), H.(LinkName)).
  destruct x, y; simpl in *; congruence.
Defined.

Definition eq_string (s1 s2 : string) :=
  if string_dec s1 s2 then true else false.

Definition File := string.
Definition Files := list File.

Record FS := mkFS {
  FSRoot : nat;     (* root DirNode *)
  FSLinks : FSet.t Link;
  FSFiles : Files;  (* [filenum]s point into this list *)
}.

Definition Pathname := list string.

(** [path_evaluates] is used to specify lookup *)

Inductive valid_link : forall (fs : FS) (dir : nat) (name : string) (target : Node), Prop :=
| ValidLink : forall fs dir name target,
    FSet.In (mkLink dir target name) (FSLinks fs) ->
    valid_link fs dir name target.

Inductive path_evaluates : forall (fs : FS) (start : Node) (pn : Pathname) (target : Node), Prop :=
| PathEvalEmpty : forall fs start,
  path_evaluates fs start nil start
| PathEvalDirLink : forall fs startdir name x pn namenode,
  valid_link fs startdir name x ->
  path_evaluates fs x pn namenode ->
  path_evaluates fs (DirNode startdir) (name :: pn) namenode.

Definition path_eval_root (fs : FS) (pn : Pathname) (target : Node) : Prop :=
  path_evaluates fs (DirNode (FSRoot fs)) pn target.

Hint Constructors valid_link : model.
Hint Constructors path_evaluates : model.

(*
Lemma path_evaluates_cons': forall fs startdir name pn node,
    path_evaluates fs startdir (name::pn) node ->
    exists node',
      path_evaluates fs startdir [name] node' /\
      path_evaluates fs node' pn node.
Proof.
  intros.
  inversion H; subst.
  inversion H; subst; eexists; eauto with model.
Qed.

Lemma path_evaluates_cons: forall fs startdir name pn node node',
    path_evaluates fs (DirNode startdir) [name] node' ->
    path_evaluates fs node' pn node ->
    exists node'',
      path_evaluates fs (DirNode startdir) (name::pn) node''.
Proof.
  intros.
  inversion H; subst; clear H.
  - eexists.
    inversion H0; subst; clear H0.
    constructor; eauto.
  - eexists.
    eapply PathEvalDirLink; eauto.
    inversion H7; subst; clear H7.
    eauto.
  - eexists.
    inversion H8; subst; clear H8.
    eapply PathEvalSymlink; eauto.
Qed.
*)

Definition does_not_exist (fs : FS) dirnum name :=
  ~ exists n, FSet.In (mkLink dirnum n name) (FSLinks fs).

Definition file_handle_unused (fs : FS) h :=
  ~ exists d name, FSet.In (mkLink d (FileNode h) name) (FSLinks fs).

Definition file_handle_valid (fs : FS) h :=
  h < Datatypes.length (FSFiles fs).

Definition upd_file h data (fs : FS) :=
  mkFS (FSRoot fs) (FSLinks fs) (list_upd (FSFiles fs) h data).

Definition add_link dir node name (fs : FS) :=
  mkFS (FSRoot fs) (FSet.add (mkLink dir node name) (FSLinks fs)) (FSFiles fs).

Definition del_link dir node name (fs : FS) :=
  mkFS (FSRoot fs) (FSet.remove (mkLink dir node name) (FSLinks fs)) (FSFiles fs).

Definition create_file dir h name (fs : FS) :=
  add_link dir (FileNode h) name (upd_file h "" fs).

Definition create_file_write dir h name data (fs : FS) :=
  add_link dir (FileNode h) name (upd_file h data fs).

Definition valid_dir dir (fs : FS) :=
  exists pn, path_eval_root fs pn (DirNode dir).

Definition match_readdir from l :=
  beq_nat from (LinkFrom l).

Definition readdir fs dir :=
  FSet.filter (match_readdir dir) (FSLinks fs).

Definition readdir_names fs dir :=
  map LinkName (FSet.elements (readdir fs dir)).

(*
(* if pn exists, then it is unique *)
Definition maybe_unique_pathname (fs : FS) startdir pn :=
  forall node node',
    path_evaluates fs startdir pn node ->
    path_evaluates fs startdir pn node' ->
    node' = node.

Definition maybe_unique_pathname_root (fs : FS) pn :=
  forall node node',
    path_eval_root fs pn node ->
    path_eval_root fs pn node' ->
    node' = node.

(* pn exists and it is unique. *)
Definition unique_pathname (fs : FS) startdir pn :=
  exists node,
    path_evaluates fs startdir pn node /\
    forall node',
      path_evaluates fs startdir pn node' -> node' = node.

Definition unique_pathname_root (fs : FS) pn :=
  exists node,
    path_eval_root fs pn node /\
    forall node',
      path_eval_root fs pn node' -> node' = node.

Lemma unique_pathname_path_evaluates_eq: forall fs startdir pn node node',
    unique_pathname fs startdir pn ->
    path_evaluates fs startdir pn node ->
    path_evaluates fs startdir pn node' ->
    node = node'.
Proof.
  intros.
  unfold unique_pathname in *.
  deex.
  specialize (H2 node H0) as H2x; subst.
  specialize (H2 node' H1) as H2x; subst.
  reflexivity.
Qed.

Lemma unique_pathname_valid_link_eq: forall fs dirnum name inum inum',
    unique_pathname fs (DirNode dirnum) [name] ->
    valid_link fs dirnum name (DirNode inum) ->
    valid_link fs dirnum name (DirNode inum') ->
    DirNode inum = DirNode inum'.
Proof.
  intros.
  unfold unique_pathname in *.
  deex.
  specialize (H2 (DirNode inum)) as H2x; subst.
  specialize (H2 (DirNode inum')) as H2y; subst.
  destruct H2x.
  econstructor.
  eapply H0.
  constructor.
  destruct H2y.
  econstructor.
  eapply H1.
  constructor.
  reflexivity.
Qed.

Lemma unique_pathname_path_evaluates_cons_eq: forall fs startdir name pn' node node' node'',
    path_evaluates fs (DirNode startdir) [name] node' ->
    path_evaluates fs node' pn' node ->
    unique_pathname fs (DirNode startdir) [name] ->
    unique_pathname fs node' pn' ->
    path_evaluates fs (DirNode startdir) (name :: pn') node'' ->
    node = node''.
Proof.
  intros.
  eapply path_evaluates_cons' in H3 as Hcons.
  deex.
  assert (node'0 = node').
  eapply unique_pathname_path_evaluates_eq in H; eauto.
  subst.
  assert (node = node'').
  eapply unique_pathname_path_evaluates_eq in H2; eauto.
  subst.
  reflexivity.
Qed.

(* A stronger version of unique_pathname, requiring all intermediate nodes match *)
Inductive stable_pathname : forall (fs: FS) (startdir: Node) (pn: Pathname), Prop :=
| StablePathNil: forall fs startdir, stable_pathname fs (DirNode startdir) []
| StablePathCons: forall fs startdir name pn' node node',
    path_evaluates fs (DirNode startdir) [name] node' ->
    path_evaluates fs node' pn' node ->
    unique_pathname fs (DirNode startdir) [name] ->
    unique_pathname fs node' pn' ->
    stable_pathname fs (DirNode startdir) (name::pn').

(* sanity check *)
Lemma stable_pathname_unique_pathname: forall fs startdir pn,
    stable_pathname fs startdir pn ->
    unique_pathname fs startdir pn.
Proof.
  intros.
  inversion H; subst; clear H.
  - eexists.
    split.
    constructor.
    intros.
    inversion H; auto.
  - unfold unique_pathname.
    eapply path_evaluates_cons in H1 as Hcons; eauto.
    deex.
    eapply unique_pathname_path_evaluates_cons_eq in H as Hx; eauto.
    subst.
    exists node''.
    split; eauto.
    intros.
    eapply unique_pathname_path_evaluates_cons_eq in H4 as Hx; eauto.
Qed.

Definition unique_dirent (fs : FS) dir name :=
  forall target target0,
    valid_link fs dir name target ->
    valid_link fs dir name target0 ->
    target0 = target.

Definition unique_dirents (fs : FS) :=
  forall dir name target target0,
    valid_link fs dir name target ->
    valid_link fs dir name target0 ->
    target0 = target.

Lemma unique_dirent_link_eq: forall fs startdir name node node',
    unique_dirent fs startdir name ->
    valid_link fs startdir name node ->
    valid_link fs startdir name node' ->
    node = node'.
Proof.
  intros.
  edestruct H; eauto.
Qed.
*)

Hint Resolve FSet.add_incr.

(*
Lemma path_evaluates_add_link : forall fs startdir dirnum name dirpn n node,
  path_evaluates fs startdir dirpn node ->
  path_evaluates (add_link dirnum n name fs) startdir dirpn node.
Proof.
  unfold add_link in *.
  simpl in *.
  intros.
  induction H.
  + constructor.
  + eapply PathEvalFileLink; eauto.
    edestruct H; eauto with model.
    - constructor; simpl; auto.
    - eapply ValidDotDot.
      eapply FSet.add_incr; eauto.
  + eapply PathEvalDirLink; eauto.
    edestruct H; eauto with model.
    - constructor; simpl; eauto.
    - eapply ValidDotDot.
      apply FSet.add_incr; eauto.
  + inversion H; subst.
    eapply PathEvalSymlink; simpl; eauto.
    constructor.
    apply FSet.add_incr; eauto.
Qed.

Lemma valid_link_does_not_exist: forall fs dirnum name node,
    proper_name name ->
    valid_link fs dirnum name node ->
    does_not_exist fs dirnum name ->
    False.
Proof.
  intros.
  inversion H0; subst; clear H0.
  - destruct H1; eexists; eauto.
  - destruct H; congruence.
  - destruct H; congruence.
  - destruct H; congruence.
Qed.

Lemma path_evaluates_does_not_exist: forall fs dirnum name,
    proper_name name ->
    path_evaluates fs (DirNode dirnum) [name] (DirNode dirnum) ->
    does_not_exist fs dirnum name ->
    False.
Proof.
  intros.
  inversion H0; subst; clear H0.
  inversion H8; subst; clear H8.
  eapply valid_link_does_not_exist; eauto.
  inversion H9; subst; clear H9.
  eapply valid_link_does_not_exist; eauto.
Qed.

Lemma valid_link_add_file_link': forall fs startdir name name0 dirnum node node' inum,
    valid_link fs startdir name0 node ->
    proper_name name  ->
    does_not_exist fs dirnum name ->
    valid_link (add_link dirnum (FileNode inum) name fs) startdir name0 node' ->
    valid_link fs startdir name0 node'.
Proof.
  intros.
  inversion H2; subst; clear H2; eauto with model.
  - apply FSet.add_in' in H3; intuition eauto with model.
    inversion H2; subst; clear H2.
    exfalso; eapply valid_link_does_not_exist; eauto.
  - eapply ValidDotDot.
    apply FSet.add_in' in H3; auto.
    intuition idtac; eauto.
    inversion H2.
Qed.

Lemma path_evaluates_add_link' : forall fs startdir dirnum name dirpn finum node,
  fs_invariant fs ->
  stable_pathname fs startdir dirpn ->
  path_evaluates fs startdir dirpn (DirNode dirnum) ->
  does_not_exist fs dirnum name  ->
  proper_name name ->
  path_evaluates (add_link dirnum (FileNode finum) name fs) startdir dirpn node ->
  path_evaluates fs startdir dirpn node.
Proof.
  intros.
  remember (add_link dirnum (FileNode finum) name fs).
  generalize dependent fs; intros.
  induction H4; subst.
  - constructor.
  - eapply PathEvalFileLink; subst; eauto.
    inversion H4; subst.
    eapply fs_proper_name in H5 as H5x.
    eapply FSet.add_in' in H5.
    intuition idtac.
    + inversion H6; subst; clear H6.
      exfalso; eauto using path_evaluates_does_not_exist.
    + constructor; eauto.
    + apply fs_invariant_add_link; eauto.
  - inversion H1; subst; clear H1.
    {
      eapply PathEvalDirLink; eauto.
      eapply valid_link_add_file_link' in H4; auto.
      assert (DirNode inum0 = DirNode inum).
      {
        inversion H0; subst.
        eauto using unique_pathname_valid_link_eq.
      }
      inversion H1; subst; clear H1.
      eapply IHpath_evaluates; eauto.
      admit.
      eauto.
    }
    {
      inversion H10; subst.
      eapply fs_proper_name in H1 as Hx; eauto.
      (* stronger property on dirpn  *)
      (* xxx eapply valid_link_add_link'' in H4; eauto. *)
      exfalso. admit. (* H2 + H8 + H *)
    }
  - eapply PathEvalSymlink; eauto; subst.
    inversion H0; subst.
    (*
    - constructor.
      apply FSet.add_spec.
      eauto.
    - apply IHpath_evaluates1; eauto.
    - apply IHpath_evaluates2; eauto.
*)
Admitted.

Lemma path_eval_root_add_link : forall fs dirnum name dirpn n,
  path_eval_root fs dirpn (DirNode dirnum) ->
  path_eval_root (add_link dirnum n name fs) dirpn (DirNode dirnum).
Proof.
  intros.
  unfold path_eval_root.
  eapply path_evaluates_add_link in H; eauto.
Qed.

Hint Constructors path_evaluates.

Lemma path_evaluates_upd_file : forall fs startdir dirnum h data dirpn,
  path_evaluates fs startdir dirpn (DirNode dirnum) ->
  path_evaluates (upd_file h data fs) startdir dirpn (DirNode dirnum).
Proof.
  intros.
  unfold upd_file; simpl.
  induction H; eauto with model.
  + eapply PathEvalFileLink.
    edestruct H; eauto with model.
  + eapply PathEvalDirLink; eauto.
    destruct H; eauto with model.
  + eapply PathEvalSymlink; simpl; eauto.
    destruct H; eauto with model.
Qed.

Lemma path_eval_root_upd_file : forall fs dirnum h data dirpn,
  path_eval_root fs dirpn (DirNode dirnum) ->
  path_eval_root (upd_file h data fs) dirpn (DirNode dirnum).
Proof.
  intros.
  unfold path_eval_root in *.
  eapply path_evaluates_upd_file in H; eauto.
Qed.

Lemma path_evaluates_upd_file' : forall fs node h data dirpn startdir,
  path_evaluates (upd_file h data fs) startdir dirpn node ->
  path_evaluates fs startdir dirpn node.
Proof.
  intros.
  match goal with
  | H : path_evaluates ?fs0 ?dir0 ?pn0 ?node0 |- _ =>
    remember fs0;
    induction H; intros; subst; simpl
  end.
  + constructor.
  + eapply PathEvalFileLink; eauto.
    inversion H; clear H; subst.
    constructor. eauto.
  + eapply PathEvalDirLink; eauto.
    inversion H; clear H; subst.
    - constructor. eauto.
    - apply ValidDot.
    - eapply ValidDotDot; simpl; eauto.
    - apply ValidDotDotRoot; auto.
  + eapply PathEvalSymlink; simpl.
    inversion H; clear H; subst.
    constructor; eauto.
    eapply IHpath_evaluates1; eauto.
    apply IHpath_evaluates2; eauto.
Qed.

Lemma path_eval_root_upd_file' : forall fs node h data dirpn,
  path_eval_root (upd_file h data fs) dirpn node ->
  path_eval_root fs dirpn node.
Proof.
  intros.
  eapply path_evaluates_upd_file'; eauto.
Qed.

Lemma does_not_exist_add_link : forall fs dirnum name dirnum0 n0 name0,
  does_not_exist (add_link dirnum0 n0 name0 fs) dirnum name ->
  does_not_exist fs dirnum name.
Proof.
  intros.
  unfold does_not_exist, add_link in *.
  simpl in *.
  intro.
  destruct H.
  deex.
  eexists.
  apply FSet.add_incr; eauto.
Qed.

Lemma does_not_exist_add_link_same_dirnum : forall fs dirnum name n0 name0,
  does_not_exist fs dirnum name ->
  name <> name0 ->
  does_not_exist (add_link dirnum n0 name0 fs) dirnum name.
Proof.
  intros.
  unfold does_not_exist, add_link in *.
  simpl in *.
  intro.
  deex.
  apply FSet.add_in' in H1.
  intuition idtac.
  inversion H2; congruence.
  destruct H.
  eexists.
  apply H2.
Qed.

Lemma does_not_exist_upd_file : forall fs h data dirnum name,
  does_not_exist (upd_file h data fs) dirnum name ->
  does_not_exist fs dirnum name.
Proof.
  intros.
  unfold does_not_exist, upd_file in *.
  simpl in *; auto.
Qed.

Lemma does_not_exist_upd_file' : forall fs h data dirnum name,
  does_not_exist fs dirnum name ->
  does_not_exist (upd_file h data fs) dirnum name.
Proof.
  intros.
  unfold does_not_exist, upd_file in *.
  simpl in *; auto.
Qed.

Hint Resolve does_not_exist_add_link.
Hint Resolve does_not_exist_add_link_same_dirnum.
Hint Resolve does_not_exist_upd_file.
Hint Resolve does_not_exist_upd_file'.

Lemma file_handle_unused_upd_file : forall fs h0 data0 h,
  file_handle_unused (upd_file h0 data0 fs) h ->
  file_handle_unused fs h.
Proof.
  intros.
  unfold file_handle_unused, upd_file in *.
  simpl in *; auto.
Qed.

Lemma file_handle_unused_add_link : forall fs dirnum n name h,
  file_handle_unused (add_link dirnum n name fs) h ->
  file_handle_unused fs h.
Proof.
  intros.
  unfold file_handle_unused, add_link in *.
  simpl in *.
  intro.
  repeat deex.
  destruct H.
  repeat eexists.
  apply FSet.add_incr; eauto.
Qed.

Lemma file_handle_unused_upd_file' : forall fs h0 data0 h,
  file_handle_unused fs h ->
  file_handle_unused (upd_file h0 data0 fs) h.
Proof.
  intros.
  unfold file_handle_unused, upd_file in *.
  simpl in *; auto.
Qed.

Lemma file_handle_unused_add_link' : forall fs dirnum n name h,
  file_handle_unused fs h ->
  n <> FileNode h ->
  file_handle_unused (add_link dirnum n name fs) h.
Proof.
  intros.
  unfold file_handle_unused, add_link in *.
  simpl in *.
  intro.
  repeat deex.
  apply FSet.add_in' in H1.
  intuition idtac.
  inversion H2; congruence.
  destruct H.
  repeat eexists.
  apply H2.
Qed.

Lemma file_handle_unused_ne : forall fs dirnum v0 v1 name,
  file_handle_unused (add_link dirnum (FileNode v0) name fs) v1 ->
  FileNode v1 <> FileNode v0.
Proof.
  intros.
  unfold file_handle_unused, add_link in *.
  simpl in *.
  intro.
  destruct H.
  repeat eexists.
  rewrite H0 in *.
  apply FSet.add_in.
Qed.

Hint Resolve file_handle_unused_upd_file.
Hint Resolve file_handle_unused_add_link.
Hint Resolve file_handle_unused_add_link'.
Hint Resolve file_handle_unused_ne.

Lemma file_handle_valid_upd_file : forall fs h0 data0 h,
  file_handle_valid (upd_file h0 data0 fs) h ->
  file_handle_valid fs h.
Proof.
  intros.
  unfold file_handle_valid, file_handle_valid, upd_file in *.
  simpl in *.
  rewrite length_list_upd in H; auto.
Qed.

Lemma file_handle_valid_add_link : forall fs dirnum n name h,
  file_handle_valid (add_link dirnum n name fs) h ->
  file_handle_valid fs h.
Proof.
  intros.
  unfold file_handle_valid, file_handle_valid, add_link in *.
  simpl in *; auto.
Qed.

Lemma file_handle_valid_upd_file' : forall fs h0 data0 h,
  file_handle_valid fs h ->
  file_handle_valid (upd_file h0 data0 fs) h.
Proof.
  intros.
  unfold file_handle_valid, file_handle_valid, upd_file in *.
  simpl in *.
  rewrite length_list_upd; auto.
Qed.

Lemma file_handle_valid_add_link' : forall fs dirnum n name h,
  file_handle_valid fs h ->
  file_handle_valid (add_link dirnum n name fs) h.
Proof.
  intros.
  unfold file_handle_valid, file_handle_valid, add_link in *.
  simpl in *; auto.
Qed.

Hint Resolve file_handle_valid_upd_file.
Hint Resolve file_handle_valid_add_link.
Hint Resolve file_handle_valid_upd_file'.
Hint Resolve file_handle_valid_add_link'.

Lemma valid_link_upd_file' : forall fs h data dir name target,
  valid_link (upd_file h data fs) dir name target ->
  valid_link fs dir name target.
Proof.
  intros.
  remember (upd_file h data fs); generalize dependent fs.
  induction H; intros; subst.
  - constructor. eauto.
  - eapply ValidDot.
  - eapply ValidDotDot. eauto.
  - eapply ValidDotDotRoot. eauto.
Qed.
*)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D G : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ B D /\ (wd_ B D /\ (wd_ D G /\ (wd_ B G /\ (wd_ A D /\ (wd_ C D /\ (col_ A B C /\ (col_ B D G /\ col_ B G A))))))))))) -> col_ A C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export parser.
Require Export refine.

Definition adapter: IA := parse
"IA [s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11] (s1)
[login,req,connected,arg,service]
[usr,pass,ok,ack,value,query] []
[s1->(login)s2, s2->(usr)s3, s3->(pass)s4,
s4->(connected)s5, s5->(ok)s6, s6->(req)s7,
s7->(arg)s8, s8->(value)s9, s9->(query)s10,
s10->(service)s11, s11->(ack)s1]".

Definition server: IA := parse
"IA [s1,s2,s3,s4,s5,s6,s7,s8] (s1)
[admin_md,usr,pass,value,query] [connected,error,service] []
[s1->(usr)s2, s2->(pass)s3, s3->(connected)s4, s4->(value)s5,
s5->(query)s6, s6->(service)s1, s1->(admin_md)s7,
s7->(usr)s8, s8->(error)s1]".

Eval compute in IAutomaton.b_compatible adapter server. (*true*)

Definition adapter_server: IA := IAutomaton.composition adapter server.
(*Eval compute in IAutomaton.display adapter_server.
"IA [s11_s7, s11_s1, s10_s6, s9_s5, s8_s4, s7_s4, s6_s4, s5_s4, s4_s3,
s3_s2, s1_s7, s1_s1, s2_s1] (s1_s1)
[admin_md, arg, req, login] [error, ack, ok]
[query, value, pass, usr, service, connected]
[s1_s1->(login)s2_s1, s1_s1->(admin_md)s1_s7, s2_s1->(usr)s3_s2,
s3_s2->(pass)s4_s3, s4_s3->(connected)s5_s4, s5_s4->(ok)s6_s4,
s6_s4->(req)s7_s4, s7_s4->(arg)s8_s4, s8_s4->(value)s9_s5,
s9_s5->(query)s10_s6, s10_s6->(service)s11_s1, s11_s1->(ack)s1_s1,
s11_s1->(admin_md)s11_s7, s11_s7->(ack)s1_s7]"*)

Definition adapter_server_rep: IA :=
 IAutomaton.hiding
 ( IAutomaton.replacement adapter_server (&"tau") (ASet.GenActs [&"arg",&"req"]) )
 (ASet.GenActs [&"ack"]).

Definition adapter_server_hid: IA :=
 IAutomaton.hiding adapter_server (ASet.GenActs [&"arg",&"req",&"ack"]).

Eval compute in SMENI_refinement adapter_server_rep adapter_server_hid. (*false*)


(** Experiments on a memory with automatic and compositional signatures.
      We want the allocating scheme to be determined statically. We need to
    compute at typing time the types of values in the memory and the addresses
    of the pointers. It enforces a finite number of references in the program,
    but each reference can point to an extensible datastructure such as a list.
      Our approach works well but breaks the type inference and requires a lot
    of annotations. This is due to the limited unification algorithm which
    cannot use the associativity of list concatenation. Thus the user has to
    solve many equations by hand.
    TODO: try type classes *)
Require Import List.

Set Implicit Arguments.

(** A signature is a list of types to type the values in a memory *)
Module Sig.
  Definition t: Type := list Type.
End Sig.

(** A memory is a list of one value for each type of the signature *)
Module Mem.
  Inductive t: Sig.t -> Type :=
  | Nil: t nil
  | Cons: forall (T: Type), T -> forall (sig: Sig.t), t sig ->
    t (T :: sig).

  Definition Destruct (T: Type) (sig: Sig.t) (mem: t (T :: sig))
    : T * t sig.
    inversion_clear mem as [|T' x sig' mem'].
    exact (x, mem').
  Defined.

  Fixpoint Split (sig1 sig2: Sig.t) (mem: t (sig1 ++ sig2))
    : t sig1 * t sig2.
    destruct sig1 as [|T sig1].
      exact (Nil, mem).

      simpl in mem.
      refine (let (x, mem') := Destruct mem in _).
      destruct (Split _ _ mem') as [mem1 mem2].
      exact (Cons x mem1, mem2).
  Defined.

  Fixpoint Append (sig1 sig2: Sig.t) (mem1: t sig1) (mem2: t sig2)
    : t (sig1 ++ sig2).
    destruct sig1 as [|T sig1].
      exact mem2.

      refine (let (x, mem1') := Destruct mem1 in _).
      exact (Cons x (Append _ _ mem1' mem2)).
  Defined.
End Mem.

(** A reference is a statically computed pointer ; it contains no data,
    only type informations *)
Module Ref.
  (** Points to an element of type [T] located after a list of elements
      of types [sig] *)
  Inductive t (sig: Sig.t) (T: Type): Type :=
  | Make: t sig T.

  (** Dereference a pointer *)
  Definition Read (sig1 sig2: Sig.t) (T: Type) (ref: t sig1 T)
    (mem: Mem.t (sig2 ++ T :: sig1)): T :=
    fst (Mem.Destruct (snd (Mem.Split sig2 _ mem))).

  (** Write at a pointer address *)
  Definition Write (sig1 sig2: Sig.t) (T: Type) (ref: t sig1 T)
    (mem: Mem.t (sig2 ++ T :: sig1)) (x: T)
    : Mem.t (sig2 ++ T :: sig1) :=
    let (mem1, mem2) := Mem.Split sig2 _ mem in
    let (_, mem2') := Mem.Destruct mem2 in
    Mem.Append mem1 (Mem.Cons x mem2').
End Ref.

(** The state monad *)
Module Monad.
  (** [sig_in] is the type of the input memory,
      [sig_out] the type of the allocated elements *)
  Definition t (sig_in sig_out: Sig.t) (T: Type): Type :=
    Mem.t sig_in ->
    T * Mem.t (sig_out ++ sig_in).

  (** The return combinator *)
  Definition Return (sig_in: Sig.t) (A: Type) (x: A): t sig_in nil A :=
    fun s =>
      (x, s).

  (** Same as [app_assoc] but with non-opaque proof *)
  Fixpoint appAssoc (A: Type) (l1 l2 l3: list A)
    : l1 ++ l2 ++ l3 = (l1 ++ l2) ++ l3.
    destruct l1 as [|x l1].
      reflexivity.

      simpl.
      now rewrite appAssoc.
  Defined.

  (** The bind combinator *)
  Definition Bind (A B: Type)
    (sig_in_x sig_out_x sig_out_f: Sig.t)
    (x: t sig_in_x sig_out_x A)
    (f: A -> t (sig_out_x ++ sig_in_x) sig_out_f B)
    : t sig_in_x (sig_out_f ++ sig_out_x) B.
    intros s.
    destruct (x s) as [x' s'].
    rewrite <- appAssoc.
    exact (f x' s').
  Defined.

  (** A pointer to a new memory cell *)
  Definition Alloc (sig: Sig.t) (A: Type) (x: A)
    : t sig (A :: nil) (Ref.t sig A) :=
    fun s =>
      (Ref.Make sig A, Mem.Cons x s).

  (** Read at a pointer address *)
  Definition Read (sig1 sig2: Sig.t) (A: Type) (ref: Ref.t sig1 A)
    : t (sig2 ++ A :: sig1) nil A :=
    fun s =>
      (Ref.Read sig2 ref s, s).

  (** Write at a pointer address *)
  Definition Write (sig1 sig2: Sig.t) (A: Type) (ref: Ref.t sig1 A)
    (x: A): t (sig2 ++ A :: sig1) nil unit :=
      fun s =>
        (tt, Ref.Write sig2 ref s x).

  (** To type the examples we enforce the input signature to be [nil]
      and add annotations when the type inference fails. *)
  Module Examples.
    Definition Five: t nil _ nat := Return 5.
    Compute Five Mem.Nil.

    Definition RefReadTwo: t nil _ nat :=
      Bind (Alloc 2) (fun ref2 =>
      Read nil ref2).
    Compute RefReadTwo Mem.Nil.

    Definition RefReadReturnTwo: t nil _ nat :=
      Bind (Alloc 5) (fun ref5 =>
      Bind (Alloc 2) (fun ref2 =>
      Bind (Read nil ref2) (fun v2 =>
      Return v2))).
    Compute RefReadReturnTwo Mem.Nil.

    Definition RefSeven: t nil _ nat :=
      Bind (Alloc 2) (fun ref2 =>
      Bind (Alloc 5) (fun ref5 =>
      Bind (Read nil ref5) (fun v5 =>
      Bind (Read ((nat: Type) :: nil) ref2) (fun v2 =>
      Return (v2 + v5))))).
    Compute RefSeven Mem.Nil.

    Definition RefWriteReadNine: t nil _ nat :=
      Bind (Alloc 2) (fun ref2 =>
      Bind (Write _ ref2 9) (fun _ =>
      Read nil ref2)).
    Compute RefWriteReadNine Mem.Nil.
  End Examples.
End Monad.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Inductive datatype  :=
  | Tint : datatype
  | Tbool : datatype .

Inductive operator  :=
  | Oplus : operator
  | Ominus : operator
  | Omult : operator
  | Ole : operator .

Definition ident  := Z.

Inductive term  :=
  | Tconst : Z -> term
  | Tvar : Z -> term
  | Tderef : Z -> term
  | Tbin : term -> operator -> term -> term .

Inductive fmla  :=
  | Fterm : term -> fmla
  | Fand : fmla -> fmla -> fmla
  | Fnot : fmla -> fmla
  | Fimplies : fmla -> fmla -> fmla
  | Flet : Z -> term -> fmla -> fmla
  | Fforall : Z -> datatype -> fmla -> fmla .

Definition implb(x:bool) (y:bool): bool := match (x,
  y) with
  | (true, false) => false
  | (_, _) => true
  end.

Inductive value  :=
  | Vint : Z -> value
  | Vbool : bool -> value .

Parameter map : forall (a:Type) (b:Type), Type.

Parameter get: forall (a:Type) (b:Type), (map a b) -> a -> b.

Implicit Arguments get.

Parameter set: forall (a:Type) (b:Type), (map a b) -> a -> b -> (map a b).

Implicit Arguments set.

Axiom Select_eq : forall (a:Type) (b:Type), forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (a1 = a2) -> ((get (set m a1 b1)
  a2) = b1).

Axiom Select_neq : forall (a:Type) (b:Type), forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (~ (a1 = a2)) -> ((get (set m a1 b1)
  a2) = (get m a2)).

Parameter const: forall (b:Type) (a:Type), b -> (map a b).

Set Contextual Implicit.
Implicit Arguments const.
Unset Contextual Implicit.

Axiom Const : forall (b:Type) (a:Type), forall (b1:b) (a1:a), ((get (const(
  b1):(map a b)) a1) = b1).

Definition env  := (map Z value).

Definition var_env  := (map Z value).

Definition ref_env  := (map Z value).

Inductive state  :=
  | mk_state : (map Z value) -> (map Z value) -> state .

Definition ref_env1(u:state): (map Z value) :=
  match u with
  | (mk_state _ ref_env2) => ref_env2
  end.

Definition var_env1(u:state): (map Z value) :=
  match u with
  | (mk_state var_env2 _) => var_env2
  end.

Parameter eval_bin: value -> operator -> value -> value.

Axiom eval_bin_def : forall (x:value) (op:operator) (y:value), match (x,
  y) with
  | ((Vint x1), (Vint y1)) =>
      match op with
      | Oplus => ((eval_bin x op y) = (Vint (x1 + y1)%Z))
      | Ominus => ((eval_bin x op y) = (Vint (x1 - y1)%Z))
      | Omult => ((eval_bin x op y) = (Vint (x1 * y1)%Z))
      | Ole => ((x1 <= y1)%Z -> ((eval_bin x op y) = (Vbool true))) /\
          ((~ (x1 <= y1)%Z) -> ((eval_bin x op y) = (Vbool false)))
      end
  | (_, _) => ((eval_bin x op y) = (Vbool false))
  end.

Set Implicit Arguments.
Fixpoint eval_term(s:state) (t:term) {struct t}: value :=
  match t with
  | (Tconst n) => (Vint n)
  | (Tvar id) => (get (var_env1 s) id)
  | (Tderef id) => (get (ref_env1 s) id)
  | (Tbin t1 op t2) => (eval_bin (eval_term s t1) op (eval_term s t2))
  end.
Unset Implicit Arguments.

Set Implicit Arguments.
Fixpoint eval_fmla(s:state) (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm t) => ((eval_term s t) = (Vbool true))
  | (Fand f1 f2) => (eval_fmla s f1) /\ (eval_fmla s f2)
  | (Fnot f1) => ~ (eval_fmla s f1)
  | (Fimplies f1 f2) => (~ (eval_fmla s f1)) \/ (eval_fmla s f2)
  | (Flet x t f1) => (eval_fmla (mk_state (set (var_env1 s) x (eval_term s
      t)) (ref_env1 s)) f1)
  | (Fforall x Tint f1) => forall (n:Z),
      (eval_fmla (mk_state (set (var_env1 s) x (Vint n)) (ref_env1 s)) f1)
  | (Fforall x Tbool f1) => forall (b:bool),
      (eval_fmla (mk_state (set (var_env1 s) x (Vbool b)) (ref_env1 s)) f1)
  end.
Unset Implicit Arguments.

Parameter subst_term: term -> Z -> term -> term.

Axiom subst_term_def : forall (e:term) (x:Z) (t:term),
  match e with
  | (Tconst _) => ((subst_term e x t) = e)
  | (Tvar _) => ((subst_term e x t) = e)
  | (Tderef y) => ((x = y) -> ((subst_term e x t) = t)) /\ ((~ (x = y)) ->
      ((subst_term e x t) = e))
  | (Tbin e1 op e2) => ((subst_term e x t) = (Tbin (subst_term e1 x t) op
      (subst_term e2 x t)))
  end.

Axiom eval_subst_term : forall (s:state) (e:term) (x:Z) (t:term),
  ((eval_term s (subst_term e x t)) = (eval_term (mk_state (var_env1 s)
  (set (ref_env1 s) x (eval_term s t))) e)).

Set Implicit Arguments.
Fixpoint subst(f:fmla) (x:Z) (t:term) {struct f}: fmla :=
  match f with
  | (Fterm e) => (Fterm (subst_term e x t))
  | (Fand f1 f2) => (Fand (subst f1 x t) (subst f2 x t))
  | (Fnot f1) => (Fnot (subst f1 x t))
  | (Fimplies f1 f2) => (Fimplies (subst f1 x t) (subst f2 x t))
  | (Flet y tqt f1) => (Flet y tqt (subst f1 x t))
  | (Fforall y ty f1) => (Fforall y ty (subst f1 x t))
  end.
Unset Implicit Arguments.

Axiom eval_subst : forall (s:state) (f:fmla) (x:Z) (t:term), (eval_fmla s
  (subst f x t)) <-> (eval_fmla (mk_state (var_env1 s) (set (ref_env1 s) x
  (eval_term s t))) f).

Inductive stmt  :=
  | Sskip : stmt
  | Sassign : Z -> term -> stmt
  | Sseq : stmt -> stmt -> stmt
  | Sif : term -> stmt -> stmt -> stmt
  | Swhile : term -> fmla -> stmt -> stmt .

Axiom check_skip : forall (s:stmt), (s = Sskip) \/ ~ (s = Sskip).

Inductive one_step : state -> stmt -> state -> stmt -> Prop :=
  | one_step_assign : forall (s:state) (x:Z) (e:term), (one_step s (Sassign x
      e) (mk_state (var_env1 s) (set (ref_env1 s) x (eval_term s e))) Sskip)
  | one_step_seq : forall (s:state) (sqt:state) (i1:stmt) (i1qt:stmt)
      (i2:stmt), (one_step s i1 sqt i1qt) -> (one_step s (Sseq i1 i2) sqt
      (Sseq i1qt i2))
  | one_step_seq_skip : forall (s:state) (i:stmt), (one_step s (Sseq Sskip i)
      s i)
  | one_step_if_true : forall (s:state) (e:term) (i1:stmt) (i2:stmt),
      ((eval_term s e) = (Vbool true)) -> (one_step s (Sif e i1 i2) s i1)
  | one_step_if_false : forall (s:state) (e:term) (i1:stmt) (i2:stmt),
      ((eval_term s e) = (Vbool false)) -> (one_step s (Sif e i1 i2) s i2)
  | one_step_while_true : forall (s:state) (e:term) (inv:fmla) (i:stmt),
      (eval_fmla s inv) -> (((eval_term s e) = (Vbool true)) -> (one_step s
      (Swhile e inv i) s (Sseq i (Swhile e inv i))))
  | one_step_while_false : forall (s:state) (e:term) (inv:fmla) (i:stmt),
      (eval_fmla s inv) -> (((eval_term s e) = (Vbool false)) -> (one_step s
      (Swhile e inv i) s Sskip)).

Inductive many_steps : state -> stmt -> state -> stmt -> Z -> Prop :=
  | many_steps_refl : forall (s:state) (i:stmt), (many_steps s i s i 0%Z)
  | many_steps_trans : forall (s1:state) (s2:state) (s3:state) (i1:stmt)
      (i2:stmt) (i3:stmt) (n:Z), (one_step s1 i1 s2 i2) -> ((many_steps s2 i2
      s3 i3 n) -> (many_steps s1 i1 s3 i3 (n + 1%Z)%Z)).

Axiom steps_non_neg : forall (s1:state) (s2:state) (i1:stmt) (i2:stmt) (n:Z),
  (many_steps s1 i1 s2 i2 n) -> (0%Z <= n)%Z.

Axiom many_steps_seq : forall (s1:state) (s3:state) (i1:stmt) (i2:stmt)
  (n:Z), (many_steps s1 (Sseq i1 i2) s3 Sskip n) -> exists s2:state,
  exists n1:Z, exists n2:Z, (many_steps s1 i1 s2 Sskip n1) /\ ((many_steps s2
  i2 s3 Sskip n2) /\ (n = ((1%Z + n1)%Z + n2)%Z)).

Definition valid_fmla(p:fmla): Prop := forall (s:state), (eval_fmla s p).

Definition valid_triple(p:fmla) (i:stmt) (q:fmla): Prop := forall (s:state),
  (eval_fmla s p) -> forall (sqt:state) (n:Z), (many_steps s i sqt Sskip
  n) -> (eval_fmla sqt q).

Axiom skip_rule : forall (q:fmla), (valid_triple q Sskip q).

Axiom assign_rule : forall (q:fmla) (x:Z) (e:term), (valid_triple (subst q x
  e) (Sassign x e) q).

Axiom seq_rule : forall (p:fmla) (q:fmla) (r:fmla) (i1:stmt) (i2:stmt),
  ((valid_triple p i1 r) /\ (valid_triple r i2 q)) -> (valid_triple p
  (Sseq i1 i2) q).

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Theorem if_rule : forall (e:term) (p:fmla) (q:fmla) (i1:stmt) (i2:stmt),
  ((valid_triple (Fand p (Fterm e)) i1 q) /\ (valid_triple (Fand p
  (Fnot (Fterm e))) i2 q)) -> (valid_triple p (Sif e i1 i2) q).
(* YOU MAY EDIT THE PROOF BELOW *)
unfold valid_triple.
intros e p q i1 i2 (H1,H2).
intros s H s' n H'.
inversion H'; subst; auto.
inversion H0; subst; auto.
eapply H1; eauto.
simpl; auto.
eapply H2; eauto.
simpl; rewrite H10; intuition.
discriminate.
Qed.
(* DO NOT EDIT BELOW *)


(* Termination for D<> with intersection type and recursive type *)

(*
 DSub (D<:) + Bot + /\ + { z => ... }
 T ::= Top | Bot | x.Type | { Type: S..U } | (z: T) -> T^z | T1 /\ T2 | { z => T^z }
 t ::= x | { Type = T } | lambda x:T.t | t t
 *)

(* NEGATIVE result:
    show that indexed vset types with precise indexes
    alone do not support t_var_unpack.

   NEW IDEA (to be tried):
    different approximation scheme
    t_var_unpack now works, is there anything else that breaks??
    (see total9 for more experiments based on total5)
*)

Require Export SfLib.

Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Coq.Program.Equality.

(* ### Syntax ### *)

Definition id := nat.

(* term variables occurring in types *)
Inductive var : Type :=
| varF : id -> var (* free, in concrete environment *)
| varH : id -> var (* free, in abstract environment  *)
| varB : id -> var (* locally-bound variable *)
.

Inductive ty : Type :=
| TTop : ty
| TBot : ty
(* (z: T) -> T^z *)
| TAll : ty -> ty -> ty
(* x.Type *)
| TSel : var -> ty
(* { Type: S..U } *)
| TMem : ty(*S*) -> ty(*U*) -> ty
| TBind  : ty -> ty (* Recursive binder: { z => T^z },
                         where z is locally bound in T *)
| TAnd : ty -> ty -> ty (* Intersection Type: T1 /\ T2 *)
.

Inductive tm : Type :=
(* x -- free variable, matching concrete environment *)
| tvar : id -> tm
(* { Type = T } *)
| ttyp : ty -> tm
(* lambda x:T.t *)
| tabs : ty -> tm -> tm
(* t t *)
| tapp : tm -> tm -> tm
(* unpack(e) { x => ... } *)
| tunpack : tm -> tm -> tm
.

Inductive vl : Type :=
(* a closure for a lambda abstraction *)
| vabs : list vl (*H*) -> ty -> tm -> vl
(* a closure for a first-class type *)
| vty : list vl (*H*) -> ty -> vl
.

Definition tenv := list ty. (* Gamma environment: static *)
Definition venv := list vl. (* H environment: run-time *)

(* ### Representation of Bindings ### *)

(* An environment is a list of values, indexed by decrementing ids. *)

Fixpoint indexr {X : Type} (n : id) (l : list X) : option X :=
  match l with
    | [] => None
    | a :: l' =>
      if (beq_nat n (length l')) then Some a else indexr n l'
  end.

Inductive closed: nat(*B*) -> nat(*H*) -> nat(*F*) -> ty -> Prop :=
| cl_top: forall i j k,
    closed i j k TTop
| cl_bot: forall i j k,
    closed i j k TBot
| cl_all: forall i j k T1 T2,
    closed i j k T1 ->
    closed (S i) j k T2 ->
    closed i j k (TAll T1 T2)
| cl_sel: forall i j k x,
    k > x ->
    closed i j k (TSel (varF x))
| cl_selh: forall i j k x,
    j > x ->
    closed i j k (TSel (varH x))
| cl_selb: forall i j k x,
    i > x ->
    closed i j k (TSel (varB x))
| cl_mem: forall i j k T1 T2,
    closed i j k T1 ->
    closed i j k T2 ->
    closed i j k (TMem T1 T2)
| cl_bind: forall i j k T,
    closed (S i) j k T ->
    closed i j k (TBind T)
| cl_and: forall i j k T1 T2,
    closed i j k T1 ->
    closed i j k T2 ->
    closed i j k (TAnd T1 T2)
.

(* open define a locally-nameless encoding wrt to TVarB type variables. *)
(* substitute var u for all occurrences of (varB k) *)
Fixpoint open_rec (k: nat) (u: var) (T: ty) { struct T }: ty :=
  match T with
    | TTop        => TTop
    | TBot        => TBot
    | TAll T1 T2  => TAll (open_rec k u T1) (open_rec (S k) u T2)
    | TSel (varF x) => TSel (varF x)
    | TSel (varH i) => TSel (varH i)
    | TSel (varB i) => if beq_nat k i then TSel u else TSel (varB i)
    | TMem T1 T2  => TMem (open_rec k u T1) (open_rec k u T2)
    | TBind T => TBind (open_rec (S k) u T)
    | TAnd T1 T2 => TAnd (open_rec k u T1) (open_rec k u T2)
  end.

Definition open u T := open_rec 0 u T.

(* Locally-nameless encoding with respect to varH variables. *)
Fixpoint subst (U : var) (T : ty) {struct T} : ty :=
  match T with
    | TTop         => TTop
    | TBot         => TBot
    | TAll T1 T2   => TAll (subst U T1) (subst U T2)
    | TSel (varB i) => TSel (varB i)
    | TSel (varF i) => TSel (varF i)
    | TSel (varH i) => if beq_nat i 0 then TSel U else TSel (varH (i-1))
    | TMem T1 T2     => TMem (subst U T1) (subst U T2)
    | TBind T       => TBind (subst U T)
    | TAnd T1 T2    => TAnd (subst U T1)(subst U T2)
  end.

Fixpoint nosubst (T : ty) {struct T} : Prop :=
  match T with
    | TTop         => True
    | TBot         => True
    | TAll T1 T2   => nosubst T1 /\ nosubst T2
    | TSel (varB i) => True
    | TSel (varF i) => True
    | TSel (varH i) => i <> 0
    | TMem T1 T2    => nosubst T1 /\ nosubst T2
    | TBind T       => nosubst T
    | TAnd T1 T2    => nosubst T1 /\ nosubst T2
  end.

(* ### Static Subtyping ### *)
(*
The first env is for looking up varF variables.
The first env matches the concrete runtime environment, and is
extended during type assignment.
The second env is for looking up varH variables.
The second env matches the abstract runtime environment, and is
extended during subtyping.
*)
Inductive stp: tenv -> tenv -> ty -> ty -> Prop :=
| stp_top: forall G1 GH T1,
    closed 0 (length GH) (length G1) T1 ->
    stp G1 GH T1 TTop
| stp_bot: forall G1 GH T2,
    closed 0 (length GH) (length G1) T2 ->
    stp G1 GH TBot T2
| stp_mem: forall G1 GH S1 U1 S2 U2,
    stp G1 GH U1 U2 ->
    stp G1 GH S2 S1 ->
    stp G1 GH (TMem S1 U1) (TMem S2 U2)
| stp_sel1: forall G1 GH TX T2 x,
    indexr x G1 = Some TX ->
    closed 0 0 (length G1) TX ->
    stp G1 GH TX (TMem TBot T2) ->
    stp G1 GH (TSel (varF x)) T2
| stp_sel2: forall G1 GH TX T1 x,
    indexr x G1 = Some TX ->
    closed 0 0 (length G1) TX ->
    stp G1 GH TX (TMem T1 TTop) ->
    stp G1 GH T1 (TSel (varF x))
| stp_selx: forall G1 GH v x,
    indexr x G1 = Some v ->
    stp G1 GH (TSel (varF x)) (TSel (varF x))
| stp_sela1: forall G1 GH TX T2 x,
    indexr x GH = Some TX ->
    closed 0 x (length G1) TX ->
    stp G1 GH TX (TMem TBot T2) ->
    stp G1 GH (TSel (varH x)) T2
| stp_sela2: forall G1 GH TX T1 x,
    indexr x GH = Some TX ->
    closed 0 x (length G1) TX ->
    stp G1 GH TX (TMem T1 TTop) ->
    stp G1 GH T1 (TSel (varH x))
| stp_selax: forall G1 GH v x,
    indexr x GH = Some v  ->
    stp G1 GH (TSel (varH x)) (TSel (varH x))

(* stp for recursive type and inersection type *)
(*
| stp_bind1: forall GH G1 T1 T1' T2,
    stp G1 (T1'::GH) T1' T2 ->
    T1' = (open (varH (length GH)) T1) ->
    closed 1 (length GH) (length G1) T1 ->
    closed 0 (length GH) (length G1) T2 ->
    stp G1 GH (TBind T1) T2

| stp_bind2: forall GH G1 T1 T1' T2,
    stp G1 (T1'::GH) T2 T1' ->
    T1' = (open (varH (length GH)) T1) ->
    closed 1 (length GH) (length G1) T1 ->
    closed 0 (length GH) (length G1) T2 ->
    stp G1 GH T2 (TBind T1)
*)
| stp_bindx: forall GH G1 T1 T1' T2 T2',
    stp G1 (T1'::GH) T1' T2' ->
    T1' = (open (varH (length GH)) T1) ->
    T2' = (open (varH (length GH)) T2) ->
    closed 1 (length GH) (length G1) T1 ->
    closed 1 (length GH) (length G1) T2 ->
    stp G1 GH (TBind T1) (TBind T2)

| stp_and11: forall GH G1 T1 T2 T,
    stp G1 GH T1 T ->
    closed 0 (length GH) (length G1) T2 ->
    stp G1 GH (TAnd T1 T2) T

| stp_and12: forall GH G1 T1 T2 T,
    stp G1 GH T2 T ->
    closed 0 (length GH) (length G1) T1 ->
    stp G1 GH (TAnd T1 T2) T

| stp_and2: forall GH G1 T1 T2 T,
    stp G1 GH T T1 ->
    stp G1 GH T T2 ->
    stp G1 GH T (TAnd T1 T2)

| stp_all: forall G1 GH T1 T2 T3 T4 x,
    stp G1 GH T3 T1 ->
    x = length GH ->
    closed 1 (length GH) (length G1) T2 ->
    closed 1 (length GH) (length G1) T4 ->
    stp G1 (T3::GH) (open (varH x) T2) (open (varH x) T4) ->
    stp G1 GH (TAll T1 T2) (TAll T3 T4)
| stp_trans: forall G1 GH T1 T2 T3,
    stp G1 GH T1 T2 ->
    stp G1 GH T2 T3 ->
    stp G1 GH T1 T3
.

(* ### Type Assignment ### *)
Inductive has_type : tenv -> tm -> ty -> Prop :=
| t_var: forall x env T1,
           indexr x env = Some T1 ->
           stp env [] T1 T1 ->
           has_type env (tvar x) T1
(* recursive typing  *)
| t_var_pack : forall G1 x T1 T1',
           (* has_type G1 (tvar x) T1' -> *)
      indexr x G1 = Some (open (varF x) T1) ->
      T1' = (open (varF x) T1) ->
      closed 1 0 (length G1) T1 ->
      has_type G1 (tvar x) (TBind T1)
| t_var_unpack : forall G1 x T1 T1',
      (* has_type G1 (tvar x) (TBind T1) -> *)
      indexr x G1 = Some (TBind T1) ->
      T1' = (open (varF x) T1) ->
      closed 0 0 (length G1) T1' ->
      has_type G1 (tvar x) T1'

(* unpack a recursive type: unpack(x:{z=>T^z}) { x:T^x => ... }  *)
| t_unpack: forall env x y T1 T1' T2,
           has_type env x (TBind T1) ->
           T1' = (open (varF (length env)) T1) ->
           has_type (T1'::env) y T2 ->
           closed 0 0 (length env) T2 ->
           has_type env (tunpack x y) T2

(* intersection typing *)
| t_and : forall env x T1 T2,
           has_type env (tvar x) T1 ->
           has_type env (tvar x) T2 ->
           has_type env (tvar x) (TAnd T1 T2)

| t_typ: forall env T1,
           closed 0 0 (length env) T1 ->
           has_type env (ttyp T1) (TMem T1 T1)

| t_app: forall env f x T1 T2,
           has_type env f (TAll T1 T2) ->
           has_type env x T1 ->
           closed 0 0 (length env) T2 ->
           has_type env (tapp f x) T2
| t_dapp:forall env f x T1 T2 T,
           has_type env f (TAll T1 T2) ->
           has_type env (tvar x) T1 ->
           T = open (varF x) T2 ->
           closed 0 0 (length env) T ->
           has_type env (tapp f (tvar x)) T
| t_abs: forall env y T1 T2,
           has_type (T1::env) y (open (varF (length env)) T2) ->
           closed 0 0 (length env) (TAll T1 T2) ->
           has_type env (tabs T1 y) (TAll T1 T2)
| t_sub: forall env e T1 T2,
           has_type env e T1 ->
           stp env [] T1 T2 ->
           has_type env e T2
.

(* ### Evaluation (Big-Step Semantics) ### *)

(*
None             means timeout
Some None        means stuck
Some (Some v))   means result v
Could use do-notation to clean up syntax.
*)

Fixpoint teval(n: nat)(env: venv)(t: tm){struct n}: option (option vl) :=
  match n with
    | 0 => None
    | S n =>
      match t with
        | tvar x       => Some (indexr x env)
        | ttyp T       => Some (Some (vty env T))
        | tabs T y     => Some (Some (vabs env T y))
        | tapp ef ex   =>
          match teval n env ex with
            | None => None
            | Some None => Some None
            | Some (Some vx) =>
              match teval n env ef with
                | None => None
                | Some None => Some None
                | Some (Some (vty _ _)) => Some None
                | Some (Some (vabs env2 _ ey)) =>
                  teval n (vx::env2) ey
              end
          end
        | tunpack ex ey =>
          match teval n env ex with
            | None => None
            | Some None => Some None
            | Some (Some vx) =>
              teval n (vx::env) ey
          end
      end
  end.

Definition tevaln env e v := exists nm, forall n, n > nm -> teval n env e = Some (Some v).

(* ------------------------- NOTES -------------------------
Define value typing (val_type)
val_type0 cannot straightforwardly be defined as inductive
family, because the (forall vx, val_type0 env vx T1 -> ... )
occurrence violates the positivity restriction.
--------------------------------------------------------- *)

Fixpoint tsize_flat(T: ty) :=
  match T with
    | TTop => 1
    | TBot => 1
    | TAll T1 T2 => S (tsize_flat T1 + tsize_flat T2)
    | TSel _ => 1
    | TMem T1 T2 => S (tsize_flat T1 + tsize_flat T2)
    | TBind T => S (tsize_flat T)
    | TAnd T1 T2 => S (tsize_flat T1 + tsize_flat T2)
  end.

Lemma open_preserves_size: forall T x j,
  tsize_flat T = tsize_flat (open_rec j (varH x) T).
Proof.
  intros T. induction T; intros; simpl; eauto.
  - destruct v; simpl; destruct (beq_nat j i); eauto.
Qed.

(* NEW DESIGN IDEA:

   The required invariants about runtime evaluation rely in crucial
   ways on transporting properties from the creation site of
   type objects to their use sites -- in particular the fact
   that only type aliased can be created (TMem T T), and that these
   cannot be recursive.

   This suggests that in the proof, we should pair each (vty T) value
   with the semantic interpretation of the type member [[ T ]].

   So [[ T ]] in general is no longer a set of values, but a set of
   (vl, vset) pairs. This leads to some complication as the type vset
   is now recursive:

      Definition vset := vset -> vl -> Prop.

   which Coq wouldn't let us do (for good reasons).

   It seems like the best we can do is an indexed variant such that

    vset (S n) := vset n -> vl -> Prop

   and quantify over n to denote all finite ones.

   As it turns out, we no longer need the previuos l/u bound selectors,
   and the TMem case can ensure that the *actual* type member of an
   object is inbetween the given bounds. This enables the case for
   intersection types.

   For TBind, there is still some uncertainty.

*)

Fixpoint vset n := match n with
                     | 0 => vl -> Prop
                     | S n => vset n -> vl -> Prop
                   end.

Definition vseta := forall n, vset n.

(* this is just a helper for pattern matching *)
Inductive vset_match : nat -> Type :=
| vsmatch: forall n, vset (S n) -> list (vset (S n)) -> list (vset (S n)) -> vset_match n
.

Require Coq.Program.Wf.

Lemma minus1 {k} : k < (S k). omega. Qed.

Lemma approx {j k} (a: j < k): vset k -> vset j.
Proof. admit. Qed.

Lemma approx_env { j k } (a: j < k) :  list (vset k) ->  list (vset j).
Proof. admit. Qed.

Program Fixpoint val_type n (env: list (vset (S n))) (GH:list (vset (S n))) (T:ty) (dd: vset (S n)) (v:vl) {measure (tsize_flat T)}: Prop :=
  match v,T with
    | vabs env1 T0 y, TAll T1 T2 =>
      closed 0 (length GH) (length env) T1 /\ closed 1 (length GH) (length env) T2 /\
      forall jj vx,
        (forall kx (a: (S kx < S n)),
           val_type kx (approx_env a env) (approx_env a GH) T1 (jj kx) vx) ->
        exists (jj2:vseta) v, tevaln (vx::env1) y v /\
          (forall k (a: (S k < S n)),
             val_type k (approx_env a env) (jj (k)::(approx_env a GH)) (open (varH (length GH)) T2) (jj2 (S k)) v)

    | vty env1 TX, TMem T1 T2 =>
      closed 0 (length GH) (length env) T1 /\ closed 0 (length GH) (length env) T2 /\
      forall dy vy, val_type n env GH T1 dy vy -> dd (approx minus1 dy) vy /\
      match (vsmatch n dd env GH) with
        | vsmatch 0 _ _ _ => True
        | vsmatch (S n0) dd env GH  => forall dy vy,
                      (val_type n0 (approx_env minus1 env) (approx_env minus1 GH) T1 dy vy -> dd dy vy) /\
                      (dd dy vy -> val_type n0 (approx_env minus1 env) (approx_env minus1 GH) T2 dy vy)
      end

    | _, TSel (varF x) =>
      match indexr x env with
        | Some jj => jj (approx minus1 dd) v
        | _ => False
      end
    | _, TSel (varH x) =>
      match indexr x GH with
        | Some jj => jj (approx minus1 dd) v
        | _ => False
      end

    | _, TAnd T1 T2 =>
      val_type n env GH T1 dd v /\ val_type n env GH T2 dd v

    | _, TBind T1 =>
       closed 1 (length GH) (length env) T1 /\
      (* NOTE: need to investigate this more. Ideally we would like to express:

          val_type env (dd::GH) (open (varH (length GH)) T1) n (dd n) v

         But this would require dd to be of type vseta instead of vset n.
         If we change the signature to dd:vseta, however, then we run into
         trouble with lemma valtp_to_vseta.

      *)

      val_type n env (dd::GH) (open (varH (length GH)) T1) dd v
    | _, TTop =>
      True
    | _,_ =>
      False
  end.

Next Obligation. simpl. omega. Qed.
Next Obligation. simpl. unfold open. rewrite <-open_preserves_size. omega. Qed. (* TApp case: open *)
Next Obligation. simpl. omega. Qed.
Next Obligation. simpl. omega. Qed.
Next Obligation. simpl. omega. Qed.
Next Obligation. simpl. omega. Qed.
Next Obligation. simpl. omega. Qed.

Next Obligation. simpl. unfold open. rewrite <-open_preserves_size. omega. Qed. (* TBind case: open *)

Next Obligation. compute. repeat split; intros; destruct H; inversion H; inversion H0; inversion H1. Qed.
Next Obligation. compute. repeat split; intros; destruct H; inversion H; inversion H0; inversion H1. Qed.
Next Obligation. compute. repeat split; intros; destruct H; inversion H; inversion H0; inversion H1. Qed.
Next Obligation. compute. repeat split; intros; destruct H; inversion H; inversion H0; inversion H1. Qed.
Next Obligation. compute. repeat split; intros; destruct H; inversion H; inversion H0; inversion H1. Qed.
Next Obligation. compute. repeat split; intros; destruct H; inversion H; inversion H0; inversion H1. Qed.

(*
   The expansion of val_type, val_type_func is incomprehensible.
   We cannot (easily) unfold and reason about it. Therefore, we prove unfolding of
   val_type to its body as a lemma.
   (Note that the unfold_sub tactic relies on
   functional extensionality)
*)

Import Coq.Program.Wf.
Import WfExtensionality.

Lemma val_type_unfold: forall n env GH T dd v, val_type n env GH T dd v =
  match v,T with
    | vabs env1 T0 y, TAll T1 T2 =>
      closed 0 (length GH) (length env) T1 /\ closed 1 (length GH) (length env) T2 /\
      forall jj vx,
        (forall kx (a: (S kx < S n)),
           val_type kx (approx_env a env) (approx_env a GH) T1 (jj kx) vx) ->
        exists (jj2:vseta) v, tevaln (vx::env1) y v /\
          (forall k (a: (S k < S n)),
             val_type k (approx_env a env) (jj (k)::(approx_env a GH)) (open (varH (length GH)) T2) (jj2 (S k)) v)

    | vty env1 TX, TMem T1 T2 =>
      closed 0 (length GH) (length env) T1 /\ closed 0 (length GH) (length env) T2 /\
      match (vsmatch n dd env GH) with
        | vsmatch 0 _ _ _ => True
        | vsmatch (S n0) dd env GH  => forall dy vy,
                      (val_type n0 (approx_env minus1 env) (approx_env minus1 GH) T1 dy vy -> dd dy vy) /\
                      (dd dy vy -> val_type n0 (approx_env minus1 env) (approx_env minus1 GH) T2 dy vy)
      end

    | _, TSel (varF x) =>
      match indexr x env with
        | Some jj => jj (approx minus1 dd) v
        | _ => False
      end
    | _, TSel (varH x) =>
      match indexr x GH with
        | Some jj => jj (approx minus1 dd) v
        | _ => False
      end

    | _, TAnd T1 T2 =>
      val_type n env GH T1 dd v /\ val_type n env GH T2 dd v

    | _, TBind T1 =>
       closed 1 (length GH) (length env) T1 /\
      (* NOTE: need to investigate this more. Ideally we would like to express:

          val_type env (dd::GH) (open (varH (length GH)) T1) n (dd n) v

         But this would require dd to be of type vseta instead of vset n.
         If we change the signature to dd:vseta, however, then we run into
         trouble with lemma valtp_to_vseta.

      *)

      val_type n env (dd::GH) (open (varH (length GH)) T1) dd v
    | _, TTop =>
      True
    | _,_ =>
      False
  end.

Proof. admit.
Qed.

(* this is just to accelerate Coq -- val_type in the goal is slooow *)
Inductive vtp: forall n, list (vset (S n)) -> list (vset (S n)) -> ty -> vset (S n) -> vl -> Prop :=
| vv: forall n G H T dd v, val_type n G H T dd v -> vtp n G H T dd v.

Lemma unvv: forall n G H T dd v,
  vtp G H T n dd v -> val_type G H T n dd v.
Proof. admit. (*PERF

Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Arith.Peano_dec.

intros. inversion H0. apply inj_pair2_eq_dec in H2. subst. assumption.
apply eq_nat_dec. *)
Qed.

(* consistent environment *)
Definition R_env n venv genv tenv :=
  length venv = length tenv /\
  length genv = length tenv /\
  forall x TX, indexr x tenv = Some TX ->
    (exists jj vx,
       indexr x venv = Some vx /\
       indexr x genv = Some jj /\
       vtp n genv [] TX jj vx).

(* automation *)
Hint Unfold venv.
Hint Unfold tenv.

Hint Unfold open.
Hint Unfold indexr.
Hint Unfold length.

(* Hint Unfold R. *)
Hint Unfold R_env.

Hint Constructors ty.
Hint Constructors tm.
Hint Constructors vl.

Hint Constructors closed.
Hint Constructors has_type.
Hint Constructors stp.

Hint Constructors option.
Hint Constructors list.

Hint Resolve ex_intro.

(* ############################################################ *)
(* Proofs *)
(* ############################################################ *)

Lemma invert_var : forall x tenv T,
  has_type tenv (tvar x) T -> forall n venv renv, R_env n venv renv tenv ->
  exists d v, tevaln venv (tvar x) v /\ indexr x venv = Some v /\ indexr x renv = Some d/\ val_type n renv [] T d v.
Proof.
  intros ? ? ? W. remember (tvar x) as e.
  induction W; intros ? ? ? WFE; inversion Heqe; try subst x0.

  - Case "Var".
    unfold R_env in WFE. destruct WFE as [? [? F]].
    destruct (F _ _ H) as [d [v [I [D V]]]].

    exists d. exists v. split. exists 0. intros. destruct n0. omega. simpl. rewrite I. eauto. split. apply I. split. apply D. eapply unvv. eapply V.

  - Case "VarPack".
    unfold R_env in WFE. destruct WFE as [? [? F]].
    destruct (F _ _ H) as [d [v [I [D V]]]].
    exists d. exists v. split. exists 0. intros. destruct n0. omega. simpl. rewrite I. reflexivity.
    split. assumption. split. assumption.
    rewrite val_type_unfold.
    destruct v. split. rewrite H3. assumption.
    eapply unvv in V. admit. (* subst *)
    admit. (* vty like vabs *)

  - Case "VarUnpack".
    unfold R_env in WFE. destruct WFE as [? [? F]].
    destruct (F _ _ H) as [d [v [I [D V]]]].
    exists d. exists v. split. exists 0. intros. destruct n0. omega. simpl. rewrite I. reflexivity.
    split. assumption. split. assumption.
    eapply unvv in V. rewrite val_type_unfold in V. eapply unvv.
    destruct v. destruct V as [? V].

    (* HAVE *)
    assert (val_type n renv [d] (open (varH 0) T1) d (vabs l t t0)). apply V. clear H5.
    (* NEED *)
    assert (val_type n renv [d] (open (varH 0) T1) d (vabs l t t0)). apply V. clear H5.

    (* GOT IT !!! *)

    assert (val_type n renv [] (open (varF x) T1) d (vabs l t t0)). admit. (* subst *)

    subst T1'. eapply vv. eapply H5.

    admit. (* vty like vabs *)

  - Case "And".
    admit.

  - Case "Sub".
    admit.
Qed.


Require Import
        Coq.ZArith.ZArith
        Coq.Strings.String
        Coq.Vectors.Vector.

Require Import
        Fiat.Common.DecideableEnsembles
        Fiat.Computation
        Fiat.Narcissus.Common.Specs.

Section ComposeFormat.

  Context {S : Type}. (* Source Type *)
  Context {T : Type}. (* Target Type *)
  Context {cache : Cache}. (* State Type *)
  Context {S' : Type}. (* Transformed Type *)

  Definition Compose_Format
    (format : FormatM S' T)
      (f : S -> S' -> Prop) (* Transformation Relation *)
    : FormatM S T :=
    fun s env benv' =>
      exists s', format s' env ∋ benv' /\ f s s'.

  Definition Compose_Decode {S' : Type}
             (decode : DecodeM S' T)
             (g : S' -> S) (* Transformation Function *)
    : DecodeM S T  :=
    fun b env => `(s, env') <- decode b env; Some (g s, env').

  Definition Compose_Decode' {S' : Type}
             (decode : DecodeM S' T)
             (g : S' -> option S) (* Transformation Function *)
    : DecodeM S T  :=
    fun b env => `(s', env') <- decode b env; match g s' with Some s => Some (s, env') | None => None end.

  Definition Compose_Encode
             {S' : Type}
             (encode : EncodeM S' T)
             (f' : S -> option S')
    : EncodeM S T :=
    fun s => Ifopt f' s as s' Then encode s' Else fun _ => None.

  Lemma CorrectEncoder_Compose
        (format : FormatM S' T)
        (encode : EncodeM S' T)
        (f : S -> S' -> Prop)
        (f' : S -> option S')
        (f'_refines_f_1 :
           forall s s',
             f' s = Some s' ->
             f s s')
        (f'_refines_f_2 :
           forall s,
             f' s = None ->
             forall s', ~ f s s')
        (f'_sound_choice :
           forall s s',
             f' s = Some s' ->
             forall x env benv,
               format x env ∋ benv
               -> f s x
               -> format s' env ∋ benv)
    : CorrectEncoder format encode
      -> CorrectEncoder (Compose_Format format f) (Compose_Encode encode f').
  Proof.
    unfold CorrectEncoder, Compose_Encode, Compose_Format in *; split; intros.
    - apply unfold_computes.
      destruct (f' a) eqn: ?; simpl in *; try discriminate.
      eapply H in H0; eexists; intuition eauto.
    - rewrite unfold_computes; intro;  destruct_ex; split_and.
      destruct (f' a) eqn: ?; simpl in *; try discriminate.
      eapply H4; eauto.
      eapply f'_refines_f_2; eauto.
  Qed.

End ComposeFormat.

Section ComposeSpecializations.

  Context {S : Type}. (* Source Type *)
  Context {T : Type}. (* Target Type *)
  Context {cache : Cache}. (* State Type *)
  Context {S' : Type}. (* Transformed Type *)

  Definition Restrict_Format
             (P : S -> Prop)
             (format : FormatM S T)
    : FormatM S T
    := Compose_Format format (fun s s' => s = s' /\ P s').

  Corollary CorrectEncoder_Restrict_Format
            (format : FormatM S T)
            (encode : EncodeM S T)
            (P : S -> Prop)
            (decideable_P : DecideableEnsemble P)
    : CorrectEncoder format encode
      -> CorrectEncoder (Restrict_Format P format) (fun s => if (DecideableEnsembles.dec s) then encode s else fun _ => None).
  Proof.
    intros; replace
              (fun s : S => if DecideableEnsembles.dec s then encode s else fun _ : CacheFormat => None)
              with (Compose_Encode encode (fun s => if DecideableEnsembles.dec s then Some s else None)).
    eapply CorrectEncoder_Compose; intros;
      try (destruct (DecideableEnsembles.dec s) eqn: ?; first [discriminate | injections]);
      intuition eauto.
    - eapply dec_decides_P; eauto.
    - eapply Decides_false; subst; eauto.
    - subst; eauto.
    - apply functional_extensionality; intros; unfold Compose_Encode;
        find_if_inside; reflexivity.
  Qed.

  Definition Projection_Format
             (format : FormatM S' T)
             (f : S -> S')
    : FormatM S T :=
    Compose_Format format (fun s s' => f s = s').

  Lemma EquivFormat_Projection_Format
        (format : FormatM S' T)
        (f : S -> S')
    : EquivFormat (Projection_Format format f)
                  (fun s => format (f s)).
  Proof.
    unfold EquivFormat, Projection_Format, Compose_Format; split; intros ? ?.
    apply unfold_computes.
    eexists; eauto.
    rewrite unfold_computes in H; destruct_ex; intuition; subst; eauto.
  Qed.

  Corollary CorrectEncoder_Projection_Format
            (format : FormatM S' T)
            (encode : EncodeM S' T)
            (g : S -> S')
    : CorrectEncoder format encode
      -> CorrectEncoder (Projection_Format format g) (compose encode g).
  Proof.
    intros; replace
              (compose encode g)
              with (Compose_Encode encode (fun s => Some (g s))).
    eapply CorrectEncoder_Compose; intros;
      try (destruct (DecideableEnsembles.dec s') eqn: ?; first [discriminate | injections]);
      intuition eauto.
    apply functional_extensionality; intros; reflexivity.
  Qed.

End ComposeSpecializations.

Lemma Projection_format_compose
      {S S' S'' T}
      {monoid : Monoid T}
      {cache : Cache}
  : forall (f : S -> S')
           (f' : S' -> S'')
           (formatS'' : FormatM S'' T)
           (formatS : FormatM S T),
    EquivFormat (Projection_Format (Projection_Format formatS'' f') f)
                (Projection_Format formatS'' (f' ∘ f)).
Proof.
  unfold EquivFormat, refineEquiv; intros.
  unfold Projection_Format, Compose_Format; split;
    intros ? ?.
  - apply unfold_computes.
    apply (proj1 (unfold_computes _ _)) in H; simpl in *.
    destruct_ex; eexists; intuition eauto.
    apply unfold_computes.
    eexists; intuition eauto.
  -  apply (proj2 (unfold_computes _ _)); simpl in *.
     apply (proj1 (unfold_computes _ _)) in H; simpl in *.
     destruct_ex; intuition.
     apply (proj1 (unfold_computes _ _)) in H0; simpl in *.
     destruct_ex; intuition eauto.
     eexists.
     split; eauto.
     unfold Basics.compose; congruence.
Qed.

Lemma Compose_decode_correct {S V T}
      {cache : Cache}
      {P : CacheDecode -> Prop}
      {monoid : Monoid T}
      (view : S -> V -> Prop)
      (Source_Predicate : S -> Prop)
      (View_Predicate : V -> Prop)
      (format : FormatM V T)
      (view_format : FormatM V T)
      (decode_V : DecodeM (V * T) T)
      (decode_V_OK : CorrectDecoder monoid View_Predicate View_Predicate eq format decode_V P
                                    view_format)
      (View_Predicate_OK : forall s v, view s v -> Source_Predicate s -> View_Predicate v)
  : CorrectDecoder monoid Source_Predicate View_Predicate view
                   (Compose_Format format view) decode_V P view_format.
Proof.
  unfold CorrectDecoder, Projection_Format, Compose_Format; split; intros.
  { rewrite @unfold_computes in H1; destruct_ex; intuition.
    apply proj1 in decode_V_OK; eapply decode_V_OK with (ext := ext) in H2; eauto.
    destruct_ex; intuition; subst; eauto.
    eexists _, _; intuition eauto. }
  { apply proj2 in decode_V_OK; eapply decode_V_OK in H1;
      clear decode_V_OK; eauto. }
Qed.

Lemma projection_decode_correct {S V T}
      {cache : Cache}
      {P : CacheDecode -> Prop}
      {monoid : Monoid T}
      (project : S -> V)
      (Source_Predicate : S -> Prop)
      (View_Predicate : V -> Prop)
      (format : FormatM V T)
      (view_format : FormatM V T)
      (decode_V : DecodeM (V * T) T)
      (decode_V_OK : CorrectDecoder monoid View_Predicate View_Predicate eq format decode_V P view_format)
      (View_Predicate_OK : forall (s : S), Source_Predicate s -> View_Predicate (project s))
  : CorrectDecoder monoid Source_Predicate View_Predicate (fun s v => project s = v)
                   (Projection_Format format project) decode_V P view_format.
Proof.
  eapply Compose_decode_correct; intros; eauto.
  subst; eauto.
Qed.

Lemma constant_decode_correct {S V T}
      {cache : Cache}
      {P : CacheDecode -> Prop}
      {monoid : Monoid T}
      (view : S -> V -> Prop)
      (Source_Predicate : S -> Prop)
      (View_Predicate : V -> Prop)
      (format : FormatM V T)
      (view_format : FormatM V T)
      (decode_V : DecodeM (V * T) T)
      (const_v : V)
      (decode_V_OK : CorrectDecoder monoid View_Predicate View_Predicate eq format decode_V P
                                    view_format)
      (const_v_OK : View_Predicate const_v)
  : CorrectDecoder monoid Source_Predicate View_Predicate (fun _ v' => const_v = v')
                   (Projection_Format format (constant const_v)) decode_V P view_format.
Proof.
  eapply projection_decode_correct; eauto.
Qed.

Lemma refine_Projection_Format
      {cache : Cache}
      {S S' T : Type}
      (f : S -> S')
      (format : FormatM S' T)
  : forall s env,
    refineEquiv (Projection_Format format f s env)
                (format (f s) env).
Proof.
  unfold Projection_Format, Compose_Format; intros; split.
  - intros v Comp_v.
    apply unfold_computes; eexists; intuition eauto.
  - intros v Comp_v.
    rewrite unfold_computes in Comp_v; destruct_ex; intuition eauto.
    subst; eauto.
Qed.

Lemma injection_decode_correct' {S V V' T}
      {cache : Cache}
      {P : CacheDecode -> Prop}
      {monoid : Monoid T}
      (inj : V -> option V')
      (Source_Predicate : S -> Prop)
      (View_Predicate : V -> Prop)
      (View'_Predicate : V' -> Prop)
      (format : FormatM S T)
      (view : S -> V -> Prop)
      (view' : S -> V' -> Prop)
      (view_format : FormatM V T)
      (view'_format : FormatM V' T)
      (decode_V : DecodeM (V * T) T)
      (decode_V_OK : CorrectDecoder monoid Source_Predicate View_Predicate
                                    view format decode_V P view_format)
      (view'_OK : forall s v, Source_Predicate s -> view s v -> exists v', inj v = Some v' /\ view' s v')
      (View'_Predicate_OK : forall v, View_Predicate v
                                 -> forall v', inj v = Some v' -> View'_Predicate v')
      (view'_format_OK : forall v env t,
          computes_to (view_format v env) t
          -> forall v', inj v = Some v' -> computes_to (view'_format v' env) t)
  : CorrectDecoder monoid Source_Predicate View'_Predicate
                   view'
                   format (Compose_Decode' decode_V (fun s => match inj (fst s) with
                                                           | Some s' => Some (s', snd s)
                                                           | None => None
                                                           end))
                   P view'_format.
Proof.
  unfold CorrectDecoder, Projection_Format, Compose_Decode'; split; intros.
  { apply proj1 in decode_V_OK; eapply decode_V_OK with (ext := ext) in H1; eauto.
    destruct_ex; intuition; subst; eauto.
    destruct (view'_OK s x); eauto. intuition.
    eexists _, _; intuition eauto; rewrite H2; simpl; eauto.
    rewrite H7; auto.
  }
  { destruct (decode_V t env') as [ [ [? ?] ?] |] eqn: ? ;
      simpl in *; try discriminate; destruct inj eqn:?; try discriminate; injections.
    apply proj2 in decode_V_OK;
      eapply decode_V_OK in Heqo; eauto.
    intuition; destruct_ex; split_and; eexists _, _; intuition eauto.
  }
Qed.

Lemma injection_decode_correct {S V V' T}
      {cache : Cache}
      {P : CacheDecode -> Prop}
      {monoid : Monoid T}
      (inj : V -> V')
      (Source_Predicate : S -> Prop)
      (View_Predicate : V -> Prop)
      (View'_Predicate : V' -> Prop)
      (format : FormatM S T)
      (view : S -> V -> Prop)
      (view' : S -> V' -> Prop)
      (view_format : FormatM V T)
      (view'_format : FormatM V' T)
      (decode_V : DecodeM (V * T) T)
      (decode_V_OK : CorrectDecoder monoid Source_Predicate View_Predicate
                                    view format decode_V P view_format)
      (view'_OK : forall s v, Source_Predicate s -> view s v -> view' s (inj v))
      (View'_Predicate_OK : forall v, View_Predicate v
                                      -> View'_Predicate (inj v))
      (view'_format_OK : forall v env t,
          computes_to (view_format v env) t
          -> computes_to (view'_format (inj v) env) t)
  : CorrectDecoder monoid Source_Predicate View'_Predicate
                   view'
                   format (Compose_Decode decode_V (fun s => (inj (fst s), snd s)))
                   P view'_format.
Proof.
  eapply (injection_decode_correct' (fun v => Some (inj v)));
    intuition eauto; injections; intuition eauto.
Qed.

Lemma bijection_decode_correct' {S V T}
      {cache : Cache}
      {P : CacheDecode -> Prop}
      {monoid : Monoid T}
      (proj : S -> V)
      (inj : V -> option S)
      (Source_Predicate : S -> Prop)
      (View_Predicate : V -> Prop)
      (view_format : FormatM V T)
      (decode_V : DecodeM (V * T) T)
      (decode_V_OK : CorrectDecoder monoid View_Predicate View_Predicate
                                    eq view_format decode_V P view_format)
      (view_OK : forall s, Source_Predicate s -> inj (proj s) = Some s)
      (view_OK' : forall v s, inj v = Some s -> proj s = v)
      (View_Predicate_OK : forall s, Source_Predicate s -> View_Predicate (proj s))
      (View_Predicate_OK' : forall v s, View_Predicate v -> inj v = Some s -> Source_Predicate s)
  : CorrectDecoder monoid Source_Predicate Source_Predicate
                   eq
                   (Projection_Format view_format proj)
                   (Compose_Decode' decode_V (fun s => match inj (fst s) with
                                                    | Some s' => Some (s', snd s)
                                                    | None => None
                                                    end))
                   P
                   (Projection_Format view_format proj).
Proof.
  eapply injection_decode_correct'.
  - apply projection_decode_correct; eauto.
  - simpl; intros. subst. eexists. intuition eauto.
  - eauto.
  - intros. apply (EquivFormat_sym (EquivFormat_Projection_Format _ _)).
    erewrite view_OK'; eauto.
Qed.

Lemma bijection_decode_correct {S V T}
      {cache : Cache}
      {P : CacheDecode -> Prop}
      {monoid : Monoid T}
      (proj : S -> V)
      (inj : V -> S)
      (Source_Predicate : S -> Prop)
      (View_Predicate : V -> Prop)
      (view_format : FormatM V T)
      (decode_V : DecodeM (V * T) T)
      (decode_V_OK : CorrectDecoder monoid View_Predicate View_Predicate
                                    eq view_format decode_V P view_format)
      (view_OK : forall s, Source_Predicate s -> inj (proj s) = s)
      (view_OK' : forall v, proj (inj v) = v)
      (View_Predicate_OK : forall s, Source_Predicate s -> View_Predicate (proj s))
      (View_Predicate_OK' : forall v, View_Predicate v -> Source_Predicate (inj v))
  : CorrectDecoder monoid Source_Predicate Source_Predicate
                   eq
                   (Projection_Format view_format proj)
                   (Compose_Decode decode_V (fun s => (inj (fst s), snd s)))
                   P
                   (Projection_Format view_format proj).
Proof.
  eapply (bijection_decode_correct' _ (fun v => Some (inj v)));
    intuition eauto; injections; f_equal; intuition eauto.
Qed.

(* Do we have something similar already? *)
Ltac derive_decoder_equiv :=
  unfold flip, pointwise_relation,
  Compose_Decode, Compose_Decode', DecodeBindOpt2, DecodeBindOpt, BindOpt;
  intros; try reflexivity;
  let tac x := (destruct x eqn:?; cbn; destruct_pairs; intuition eauto) in
  repeat match goal with
         | |- context[If_Opt_Then_Else ?x _ _] => tac x
         | |- context[If_Then_Else ?x _ _] => tac x
         | |- context[if ?x then _ else _] => tac x
         end.

Ltac _apply_bijection_rule tac :=
    match goal with
    | |- CorrectDecoder _ _ _ _ ?f ?d _ ?f =>
      try unfold f; try unfold d
    end;
    match goal with
    | |- CorrectDecoder _ _ _ _ ?f _ _ ?f =>
      match f with
      | Projection_Format _ _ => idtac
      | _ => eapply format_decode_correct_EquivFormatAndView;
            [solve [apply EquivFormat_sym; apply EquivFormat_Projection_Format] |]
      end;
        tac ||
            (eapply format_decode_correct_EquivDecoder;
             [| tac]; cycle 1)
    end.

Ltac apply_bijection_rule :=
  _apply_bijection_rule ltac:(eapply bijection_decode_correct).

Tactic Notation "apply_bijection_rule" "with" uconstr(t) :=
  _apply_bijection_rule ltac:(eapply bijection_decode_correct with (inj:=t)).

Ltac apply_bijection_rule' :=
  _apply_bijection_rule ltac:(eapply bijection_decode_correct').

Tactic Notation "apply_bijection_rule'" "with" uconstr(t) :=
  _apply_bijection_rule ltac:(eapply bijection_decode_correct' with (inj:=t)).

Notation "format ◦ f" := (Projection_Format format f) (at level 55) : format_scope.
Notation "P ∩ format" := (Restrict_Format P format) (at level 55) : format_scope.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Groupoids.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Examples.BicatOfCats.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Transformations.Examples.Whiskering.
Require Import UniMath.Bicategories.Transformations.Examples.Unitality.
Require Import UniMath.Bicategories.Transformations.Examples.Associativity.
Require Import UniMath.Bicategories.Modifications.Modification.

Require Import prelude.cubical_methods.
Require Import prelude.grpd_bicat.
Require Import groupoid_quotient.gquot.
Require Import groupoid_quotient.gquot_principles.
Require Import gquot_biadjunction.gquot_functor.
Require Import gquot_biadjunction.path_groupoid.

Local Open Scope cat.

Section GQuotUnit.
  Variable (G : groupoid).

  Definition gquot_unit_functor_data
    : functor_data G (one_type_to_groupoid_precategory_data (gquot_functor_obj G)).
  Proof.
    use make_functor_data.
    - exact (gcl G).
    - exact (@gcleq G).
  Defined.

  Definition gquot_unit_functor_is_functor
    : is_functor gquot_unit_functor_data.
  Proof.
    split.
    - intros x ; cbn.
      apply ge.
    - intros x y z f g ; cbn.
      apply gconcat.
  Qed.

  Definition gquot_unit_functor
    : G ⟶ one_type_to_groupoid_precategory_data (gquot_functor_obj G).
  Proof.
    use make_functor.
    - exact gquot_unit_functor_data.
    - exact gquot_unit_functor_is_functor.
  Defined.
End GQuotUnit.

Definition gquot_unit_nat_trans_data
           (G₁ G₂ : groupoid)
           (F : G₁ ⟶ G₂)
  : nat_trans_data
      (gquot_unit_functor G₁ ∙ function_to_functor (gquot_functor_map F))
      (F ∙ gquot_unit_functor G₂)
  := λ _, idpath _.

Definition gquot_unit_nat_trans_is_nat_trans
           (G₁ G₂ : groupoid)
           (F : G₁ ⟶ G₂)
  : is_nat_trans _ _ (gquot_unit_nat_trans_data G₁ G₂ F).
Proof.
  intros x y f ; cbn.
  unfold gquot_unit_nat_trans_data ; cbn.
  refine (pathscomp0rid _ @ _).
  exact (gquot_rec_beta_gcleq _ _ _ _ _ _ _ _ _ _).
Qed.

Definition gquot_unit_nat_trans
           (G₁ G₂ : groupoid)
           (F : G₁ ⟶ G₂)
  : (gquot_unit_functor G₁ ∙ function_to_functor (gquot_functor_map F))
      ⟹
      F ∙ gquot_unit_functor G₂.
Proof.
  use make_nat_trans.
  - exact (gquot_unit_nat_trans_data G₁ G₂ F).
  - exact (gquot_unit_nat_trans_is_nat_trans G₁ G₂ F).
Defined.

Definition gquot_unit_data
  : pstrans_data
      (id_psfunctor grpd_bicat)
      (comp_psfunctor path_groupoid gquot_psfunctor).
Proof.
  use make_pstrans_data.
  - exact gquot_unit_functor.
  - intros G₁ G₂ F ; cbn.
    use make_invertible_2cell.
    + exact (gquot_unit_nat_trans G₁ G₂ F).
    + apply grpd_bicat_is_invertible_2cell.
Defined.

Definition gquot_unit_is_pstrans
  : is_pstrans gquot_unit_data.
Proof.
  repeat split.
  - intros G₁ G₂ F₁ F₂ α.
    use nat_trans_eq.
    { apply homset_property. }
    intros x ; cbn.
    unfold gquot_unit_nat_trans_data ; cbn.
    apply pathscomp0rid.
  - intros G.
    use nat_trans_eq.
    { apply homset_property. }
    intros x ; cbn.
    unfold gquot_unit_nat_trans_data ; cbn.
    exact (!(ge G x)).
  - intros G₁ G₂ G₃ F₁ F₂.
    use nat_trans_eq.
    { apply homset_property. }
    intros x ; cbn.
    unfold gquot_unit_nat_trans_data ; cbn.
    exact (!(ge G₃ _)).
Qed.

Definition gquot_unit
  : pstrans
      (id_psfunctor grpd_bicat)
      (comp_psfunctor path_groupoid gquot_psfunctor).
Proof.
  use make_pstrans.
  - exact gquot_unit_data.
  - exact gquot_unit_is_pstrans.
Defined.

Definition gquot_counit_map
           (X : one_type)
  : one_types ⟦ gquot_functor_obj (one_type_to_groupoid X) , X ⟧.
Proof.
  use gquot_rec.
  - exact (λ x, x).
  - exact (λ _ _ p, p).
  - exact (λ _, idpath _).
  - exact (λ _ _ _ _ _, idpath _).
  - apply X.
Defined.

Definition gquot_counit_data_po
           (X Y : one_types)
           (f : X --> Y)
           (x₁ x₂ : (X : one_type))
           (p : x₁ = x₂)
  : @PathOver
      _
      (gcl (path_groupoid X) x₁) (gcl (path_groupoid X) x₂)
      (gcleq (one_type_to_groupoid X) p)
      (λ z : gquot (path_groupoid X),
             (gquot_counit_map X · # (id_psfunctor one_types) f) z
             =
             (# (comp_psfunctor gquot_psfunctor path_groupoid) f · gquot_counit_map Y) z)
      (idpath _)
      (idpath _).
Proof.
  use map_PathOver.
  unfold square ; cbn.
  rewrite pathscomp0rid.
  induction p.
  rewrite ge.
  cbn.
  apply idpath.
Qed.

Definition gquot_counit_naturality
           {X Y : one_type}
           (f : X → Y)
  : (f ∘ gquot_counit_map X)%functions
    ~
    (gquot_counit_map Y ∘ gquot_functor_map (function_to_functor f))%functions.
Proof.
  use gquot_ind_set.
  - exact (λ _, idpath _).
  - exact (gquot_counit_data_po X Y f).
  - intros x.
    exact (one_type_isofhlevel Y _ _).
Defined.

Definition gquot_counit_data
  : pstrans_data
      (comp_psfunctor gquot_psfunctor path_groupoid)
      (id_psfunctor one_types).
Proof.
  use make_pstrans_data.
  - exact gquot_counit_map.
  - intros X Y f.
    use make_invertible_2cell.
    + exact (gquot_counit_naturality f).
    + apply one_type_2cell_iso.
Defined.

Definition gquot_counit_is_pstrans
  : is_pstrans gquot_counit_data.
Proof.
  repeat split.
  - intros X Y f g p ; cbn.
    use funextsec.
    unfold homotsec.
    use gquot_ind_prop.
    + intro x ; cbn.
      unfold homotcomp, funhomotsec, homotfun, gquot_counit_map ; cbn.
      rewrite pathscomp0rid.
      rewrite gquot_rec_beta_gcleq.
      apply idpath.
    + intro.
      exact (one_type_isofhlevel Y _ _ _ _).
  - intros X.
    use funextsec.
    unfold homotsec.
    use gquot_ind_prop.
    + intro x ; cbn.
      unfold homotcomp, funhomotsec, homotfun, gquot_counit_map ; cbn.
      rewrite gquot_rec_beta_gcleq.
      apply idpath.
    + intro.
      exact (one_type_isofhlevel X _ _ _ _).
  - intros X Y Z f g.
    use funextsec.
    unfold homotsec.
    use gquot_ind_prop.
    + intro x ; cbn.
      unfold homotcomp, funhomotsec, homotfun, gquot_counit_map ; cbn.
      rewrite gquot_rec_beta_gcleq.
      apply idpath.
    + intro.
      exact (one_type_isofhlevel Z _ _ _ _).
Qed.

Definition gquot_counit
  : pstrans
      (comp_psfunctor gquot_psfunctor path_groupoid)
      (id_psfunctor one_types).
Proof.
  use make_pstrans.
  - exact gquot_counit_data.
  - exact gquot_counit_is_pstrans.
Defined.

Definition gquot_biadj_unit_counit
  : left_biadj_unit_counit gquot_psfunctor.
Proof.
  use make_biadj_unit_counit.
  - exact path_groupoid.
  - exact gquot_unit.
  - exact gquot_counit.
Defined.

Definition gquot_biadj_triangle_l_data_po
           (G : groupoid)
           (x₁ x₂ : G)
           (f : x₁ --> x₂)
  : @PathOver
      _
      (gcl G x₁) (gcl G x₂)
      (gcleq G f)
      (λ z,
       biadj_triangle_l_lhs gquot_biadj_unit_counit G z
       =
       id_pstrans gquot_psfunctor G z)
      (idpath ((biadj_triangle_l_lhs gquot_biadj_unit_counit) G (gcl G x₁)))
      (idpath ((biadj_triangle_l_lhs gquot_biadj_unit_counit) G (gcl G x₂))).
Proof.
  apply map_PathOver.
  unfold square.
  refine (pathscomp0rid _ @ _).
  refine (_ @ !(maponpathsidfun _)).
  cbn.
  refine (!(maponpathscomp (gquot_functor_map _) _ (gcleq G f)) @ _).
  etrans.
  {
    apply maponpaths.
    exact (gquot_rec_beta_gcleq _ _ _ _ _ _ _ _ _ _).
  }
  exact (gquot_rec_beta_gcleq _ _ _ _ _ _ _ _ _ _).
Qed.

Definition gquot_biadj_triangle_l_data_cell
           (G : groupoid)
  : biadj_triangle_l_lhs gquot_biadj_unit_counit G ==> id_pstrans gquot_psfunctor G.
Proof.
  use gquot_ind_set.
  - exact (λ _, idpath _).
  - exact (gquot_biadj_triangle_l_data_po G).
  - intro.
    exact (gtrunc G _ _).
Defined.

Definition gquot_biadj_triangle_l_data
  : invertible_modification_data
      (biadj_triangle_l_lhs gquot_biadj_unit_counit)
      (id_pstrans gquot_psfunctor).
Proof.
  intros G.
  use make_invertible_2cell.
  - exact (gquot_biadj_triangle_l_data_cell G).
  - apply one_type_2cell_iso.
Defined.

Definition gquot_biadj_triangle_l_is_modification
  : is_modification gquot_biadj_triangle_l_data.
Proof.
  intros G₁ G₂ F.
  use funextsec.
  use gquot_ind_prop.
  - intro a.
    cbn.
    unfold homotcomp, funhomotsec, homotfun, gquot_counit_map ; cbn.
    rewrite !pathscomp0rid.
    unfold gquot_unit_nat_trans_data ; cbn.
    rewrite gquot_rec_beta_gcleq.
    apply idpath.
  - intro.
    exact (gtrunc G₂ _ _ _ _).
Qed.

Definition gquot_biadj_triangle_l
  : biadj_triangle_l_law gquot_biadj_unit_counit.
Proof.
  use make_invertible_modification.
  - exact gquot_biadj_triangle_l_data.
  - exact gquot_biadj_triangle_l_is_modification.
Defined.

Definition gquot_biadj_triangle_r_data
  : invertible_modification_data
      (biadj_triangle_r_lhs gquot_biadj_unit_counit)
      (id_pstrans gquot_biadj_unit_counit).
Proof.
  intros X.
  use make_invertible_2cell.
  - use make_nat_trans.
    + exact idpath.
    + abstract
        (intros x y p ;
         cbn in * ;
         rewrite pathscomp0rid ;
         exact (gquot_rec_beta_gcleq _ _ _ _ _ _ _ _ _ _)).
  - apply grpd_bicat_is_invertible_2cell.
Defined.

Definition gquot_biadj_triangle_r_is_modification
  : is_modification gquot_biadj_triangle_r_data.
Proof.
  intros X Y f.
  use nat_trans_eq.
  { apply homset_property. }
  intros x ; cbn.
  rewrite !pathscomp0rid.
  exact (gquot_rec_beta_gcleq _ _ _ _ _ _ _ _ _ _).
Qed.

Definition gquot_biadj_triangle_r
  : biadj_triangle_r_law gquot_biadj_unit_counit.
Proof.
  use make_invertible_modification.
  - exact gquot_biadj_triangle_r_data.
  - exact gquot_biadj_triangle_r_is_modification.
Defined.

Definition gquot_biadj_data
  : left_biadj_data gquot_psfunctor.
Proof.
  use make_biadj_data.
  - exact gquot_biadj_unit_counit.
  - exact gquot_biadj_triangle_l.
  - exact gquot_biadj_triangle_r.
Defined.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B Aprime Bprime : Universe, ((wd_ A B /\ (wd_ Aprime Bprime /\ (wd_ A Aprime /\ (wd_ B Bprime /\ (wd_ A Bprime /\ (wd_ Aprime B /\ (col_ A Aprime Bprime /\ (col_ B Aprime Bprime /\ col_ A B Aprime)))))))) -> col_ A B Bprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e384m2e128m2e96p2e32m1_18limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.