(*
08:45:57 < Gurkenglas> Can Coq talk about provability in Coq?
09:48:06 < aweinstock> Gurkenglas: I'd assume you can encode CIC derivation trees as an Inductive, and I'd also assume (via Godel's theorems) that there's a limit to what can be proved using that approach, but I don't know a
                       concrete example
09:54:23 < Gurkenglas> Hmm, there'd be forall a, Provable a -> a which evals the proof, for each a there'd be Provable a, there'd be Provable a -> Provable (Provable a) and (a -> b) -> Provable a -> Provable b
09:54:35 < Gurkenglas> Did I miss anything that can't be derived from these?
09:55:01 < Gurkenglas> forall a and forall a b respectively on the last two
09:58:52 < aweinstock> which modal logic do those 4 correspond to?
09:59:24 < aweinstock> (m a -> a, a -> m a, m a -> m (m a), (a -> b) -> (m a -> m b))
09:59:38 < Gurkenglas> I don't know, I pulled these out of my hat, using Haskell's Functor-Monad hierarchy for inspiration
09:59:59 < Gurkenglas> And I don't think there'd be forall a, a -> m a, just for each a there'd be m a
10:00:04 < aweinstock> isn't (Provable a -> Provable (Provable a)) redundant given (a -> Provable a)?
10:00:05 < aweinstock> ah
10:04:13 < aweinstock> Gurkenglas: if you can find a copy of "The logic of provability" by George Boolos, it's a decent read on a modal logic treatment of provability
10:07:39 < aweinstock> just found a relevant passage: "either GL is inconsistent or some sentence (m a -> a) is not a theorem of GL or some sentence (m (m a -> a)) is not a theorem of GL" (I'm transcribing the box symbols as
                       m)
10:11:35 < Gurkenglas> That seems surprising. Is this constructive? What would it construct for the obvious implementation for Coq?
10:14:06 < aweinstock> I'm not entirely sure, I read the first few chapters months ago, and just got it out now to try to use it as a reference; I'd like to do the exercises from it in Coq at some point, but haven't yet found
                       the time
10:14:22 < benzrf> Provable a -> a implies that we know that our ambient logic is a model of CIC, but im not convinced that we do know that
10:15:43 < Gurkenglas> I'm not sure about the things you said after Provable a -> a, but why couldn't you just translate each constructor of Provable a into the corresponding tactic?
10:15:45 < aweinstock> yeah, that one seemed the sketchiest of the four to me (on more heuristic grounds, e.g. looking like the type of unsafePerformIO)
10:16:20 < benzrf> Gurkenglas: that only makes sense from an external standpoint
10:17:29 < benzrf> if you try to write a function that recurses over the tree and implements it, i wouldn't be surprised if that's impossible within the type system
10:17:48 < benzrf> eval in general tends to be unsound
10:17:55 < Gurkenglas> I mean... if you ignore any standpoints but the external, whatever that means, and just implement Provable a -> a that way, and apply that "either GL is inconsistent or...", what pathological
                       construction do you get?
10:18:07 < benzrf> you might get infinite looping
10:18:27 < benzrf> actually now i'm not sure
10:18:40 < benzrf> but i wouldn't be surprised if some sort of universe-related nonsense crops up
10:20:02 < Gurkenglas> Is infinite looping possible within Coq? Is the Universe checking just a safeguard or does something rely on it? What pathology would pop up if you override the safeguard?
10:20:25 < modulus> iirc isn't infinite looping equiva to proof of alse?
10:20:32 < benzrf> https://en.wikipedia.org/wiki/System_U#Girard's_paradox
10:21:04 < benzrf> modulus: i dunno, i can imagine some sort of thing where you can get an infinite loop but not one whose type is False
10:22:04 < benzrf> Gurkenglas: sorry that link might be unhelpful, i've never actually read the proof myself
10:22:20 < aweinstock> Gurkenglas: the statement I quoted has a proof sketch right afterwards, I'll try to photograph the page
10:22:22 < benzrf> but a simple type theory where Type : Type is known to be inconsistent
10:22:53 < benzrf> that's why you need a cumulative hierarchy, or alternatively some sort of restriction on quantification i guess
10:23:38 < benzrf> it's analogous to russell's paradox apparently
10:23:54 < Gurkenglas> aweinstock, just found one, which page?
10:25:25 < aweinstock> Gurkenglas: page 1 (the intro page right before it is xxxvi)
10:55:55 < Gurkenglas> "either GL is inconsistent or some sentence (m a -> a) is not a theorem of GL or some sentence (m (m a -> a)) is not a theorem of GL" requires m (m a -> a) -> m a, how does this apply to Coq?
10:56:55 < Gurkenglas> -requires+assumes in that book
10:57:12 < Gurkenglas> Better question: What system of propositional modal logic, if any, corresponds to Coq?
*)
Goal ~(forall (m : Prop -> Prop) (a : Prop), (m a -> a) /\ m (m a -> a)).
    intro H.
    Check H (fun x => x).
    Check H (fun _ => False).
    exact (proj2 (H (fun _ => False) True)).
    Qed.

Definition foo : ~(forall (m : Prop -> Prop) (a : Prop), (m a -> a) /\ m (m a -> a)) := fun H => proj2 (H (fun _ => False) True).

(*Goal forall (m : Type -> Type), (forall (a : Type), prod (m a -> a) (m (m a -> a))) -> False.*)
(*
11:05:46 < aweinstock> Gurkenglas: "~(forall (m : Prop -> Prop) (a : Prop), (m a -> a) /\ m (m a -> a))" is inhabited by "fun H => proj2 (H (fun _ => False) True)", but that might be too weak a placement of the quantifiers
11:16:39 < aweinstock> Gurkenglas: I'm trying to work with the stronger `Goal forall (m : Prop -> Prop), ~(forall (a : Prop), (m a -> a) /\ m (m a -> a)).` now, not sure whether or not to expect it to be provable yet
11:24:10 < aweinstock> Gurkenglas: page xvii asserts that "The sentence (m p -> p) is not a theorem of GL" (with the same transcription thing about m representing box)
*)

Axiom GL_distribution : forall (m : Prop -> Prop) (a b : Prop), m (a -> b) -> (m a -> m b). (* corresponds to Applicative's <*> *)

Definition tmp := forall (m : Prop -> Prop), ~(forall (a : Prop), (m a -> a) /\ m (m a -> a)).
Goal tmp.
    intros m H.
    (*Check H False.  Check H (m False). *)
    set (H' := fun a => H (m a)).
    set (join := fun a => GL_distribution _ _ _ (proj2 (H a))).
    set (runM := fun a => proj1 (H a)).
    (destruct (H False) as [f g]).
    (destruct (H (m False)) as [x y]).
    Abort.
(*
11:41:48 < Gurkenglas> aweinstock, Goal ~(forall (m : Prop -> Prop), ~(forall (a : Prop), (m a -> a) /\ m (m a -> a))). intuition. refine (H _ _). intuition. exact H0. simpl. intuition. Qed.
*)

Goal ~tmp.
    intuition. refine (H _ _). intuition. exact H0. simpl. intuition.
    Qed.
(*
11:46:18 < Gurkenglas> But obviously you're not going to get something useful out of this without assuming more about m. What's Coqs propositional modal logic?
11:48:31 < Gurkenglas> Though the absence of a -> Provable a does not feel necessary for Coq, it just happens to be true right now
11:48:53 < Gurkenglas> We could carry a proof around with each value and make it accessible to the user
11:51:53 < aweinstock> I'm not sure that GL's metatheory is applicable to CIC, but if it is, then we have additional evidence that (Provable a -> a) isn't Coq-provable
11:55:45 < Gurkenglas> Which means that I have evidence that GL's metatheory is not applicable to CIC :D
11:58:04 < aweinstock> so, you're going to try inhabiting (Provable a -> a), where Provable is some datatype that encodes CIC-derivation-trees?
12:00:12 < Gurkenglas> I don't think I'm qualified for that, as I don't even know exactly what CIC-derivation-trees are - but how could it possibly be hard to - oh, actually I guess some of the typechecking might be hard.
12:01:31 < Gurkenglas> I missed that the inductive Provable datatype I had in mind wouldn't just contain well-formed proofs, just Coq files.
12:04:34 < aweinstock> page 115 of https://web.archive.org/web/20151210043636/https://coq.inria.fr/distrib/current/files/Reference-Manual.pdf
12:05:16 < aweinstock> (the thing in my local copy is page 124, so grab an updated copy once the inria site comes back up)
12:05:47 < aweinstock> it's the typing rules for CIC, presented in a logical deduction style
12:05:56 < aweinstock> s/logical/natural/
*)


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal35.

From lfind Require Import LFind.
Lemma lfind_state  (x:natural) (y:natural) (IHy:@eq natural (exp x y) (qexp x y (Succ Zero))):@eq natural (mult (qexp x y (Succ Zero)) x) (qexp x y x).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal35_exp_eq_qexp_119_mult_qexp/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x:natural) (y:natural) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v  y.
QuickChick collect_data.
Success.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj5eqsynthconj3 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (mult lv1 (plus lv0 Zero))).
Admitted.
QuickChick conj5eqsynthconj3.


Require Import liblayers.lib.Decision.
Require Export liblayers.logic.LayerData.
Require Export liblayers.logic.Modules.
Require Export liblayers.logic.Primitives.
Require Export liblayers.compcertx.ErrorMonad.
Require Import liblayers.logic.GlobalVars.

Section WITH_LAYER_DATA.
Context {layerdata simrel} `{HVE: Category layerdata simrel}.

(** * Layers *)

(** The semantic counterpart of modules are layers, which are indexed
  by abstract data and simulation relations. As for modules, there is
  a generic implementation using [positive] identifiers in the file
  [PTreeLayers]. *)

Class LayerOps ident primsem V (layer: layerdata -> Type)
    {gv_ops: GlobalVarsOps V}
    `{primsem_ops: PrimitiveOps layerdata primsem} :=
  {
    layer_empty :> forall D, Emptyset (layer D);
    layer_oplus :> forall D, Oplus (layer D);
    layer_mapsto_primitive :> forall D, Mapsto ident (primsem D) (layer D);
    layer_mapsto_globalvar :> forall D, Mapsto ident V (layer D);

    get_layer_primitive {D} (i: ident): layer D -> res (option (primsem D));
    get_layer_globalvar {D} (i: ident): layer D -> res (option V);
    layers_disjoint {D1} {D2} : layer D1 -> layer D2 -> Prop;
    layer_wf {D}: layer D -> Prop;

    layer_decide_primitive D (P: res (option (primsem D)) -> Prop) :>
      (forall σ, Decision (P σ)) ->
      (forall L, Decision (forall i, P (get_layer_primitive i L)));
    layer_decide_primitive_name D (P: ident -> Prop) :>
      (forall i, Decision (P i)) ->
      (forall L, Decision (forall i, get_layer_primitive (D:=D) i L <> OK None -> P i));
    layer_decide_globalvar D (P: res (option V) -> Prop) :>
      (forall τ, Decision (P τ)) ->
      (forall L, Decision (forall i, P (get_layer_globalvar (D:=D) i L)));
    layer_decide_globalvar_name D (P: ident -> Prop) :>
      (forall i, Decision (P i)) ->
      (forall L, Decision (forall i, get_layer_globalvar (D:=D) i L <> OK None -> P i));
    layers_disjoint_dec {D1 D2} (L1: layer D1) (L2: layer D2) :>
      Decision (layers_disjoint L1 L2)
  }.

(** Properties of layers *)

Class Layers ident primsem V layer
    `{lops: LayerOps ident primsem V layer}
    `{psim_op: Sim layerdata simrel primsem}
    `{lsim_op: Sim layerdata simrel layer} :=
  {
    layer_csim :>
      CategorySim layerdata simrel layer;
    layer_isjoin :>
      SimJoin layerdata simrel layer;
    layer_lower_bound D1 D2 R :>
      LowerBound (A := layer D1) (simRR D1 D2 R) ∅;

    layer_sim_intro D1 D2 (R: simrel D1 D2) i σ1 σ2 :
      sim R σ1 σ2 ->
      sim R (i ↦ σ1) (i ↦ σ2);

    get_layer_primitive_empty {D} i:
      get_layer_primitive (D:=D) i ∅ = OK None;
    get_layer_primitive_mapsto {D} i σ:
      get_layer_primitive (D:=D) i (i ↦ σ) = OK (Some σ);
    get_layer_primitive_mapsto_other_primitive {D} i j (σ: primsem D):
      i <> j -> get_layer_primitive (D:=D) i (j ↦ σ) = OK None;
    get_layer_primitive_mapsto_globalvar {D} i j (τ: V):
      get_layer_primitive (D:=D) i (j ↦ τ) = OK None;
    get_layer_primitive_oplus {D} i (L1 L2: layer D):
      get_layer_primitive i (L1 ⊕ L2) =
      get_layer_primitive i L1 ⊕ get_layer_primitive i L2;
    get_layer_primitive_sim_monotonic :>
      Monotonic
        (@get_layer_primitive _ _ _ _ _ _ _)
        (forallr R, - ==> sim R ++> res_le (option_le (sim R)));

    get_layer_globalvar_empty {D} i:
      get_layer_globalvar (D:=D) i ∅ = OK None;
    get_layer_globalvar_mapsto {D} i τ:
      get_layer_globalvar (D:=D) i (i ↦ τ) = OK (Some τ);
    get_layer_globalvar_mapsto_other_globalvar {D} i j (τ: V):
      i <> j -> get_layer_globalvar (D:=D) i (j ↦ τ) = OK None;
    get_layer_globalvar_mapsto_primitive {D} i j (σ: primsem D):
      get_layer_globalvar (D:=D) i (j ↦ σ) = OK None;
    get_layer_globalvar_oplus {D} i (L1 L2: layer D):
      get_layer_globalvar (D:=D) i (L1 ⊕ L2) =
      get_layer_globalvar i L1 ⊕ get_layer_globalvar i L2;
    get_layer_globalvar_sim_monotonic :>
      Monotonic
        (@get_layer_globalvar _ _ _ _ _ _ _)
        (forallr R, - ==> sim R ++> res_le (option_le eq));

    layers_disjoint_empty {D1 D2} L:
      layers_disjoint (D1:=D1) (D2:=D2) ∅ L;
    layers_disjoint_sym {D1 D2} L1 L2:
      layers_disjoint (D1:=D1) (D2:=D2) L1 L2 ->
      layers_disjoint L2 L1;
    layers_disjoint_oplus {D1 D2} L1 L21 L22:
      layers_disjoint (D1:=D1) (D2:=D2) L1 L21 ->
      layers_disjoint (D1:=D1) (D2:=D2) L1 L22 ->
      layers_disjoint L1 (L21 ⊕ L22);
    layers_disjoint_mapsto_primitive_primitive
      {D1 D2} i1 i2 (σ1: primsem D1) (σ2: primsem D2):
      i1 <> i2 ->
      layers_disjoint (i1 ↦ σ1) (i2 ↦ σ2);
    layers_disjoint_mapsto_primitive_globalvar
      {D1 D2} i1 i2 (σ1: primsem D1) (κ2: V):
      i1 <> i2 ->
      layers_disjoint (D2:=D2) (i1 ↦ σ1) (i2 ↦ κ2);
    layers_disjoint_mapsto_globalvar_globalvar
      {D1 D2} i1 i2 (κ1 κ2: V):
      i1 <> i2 ->
      layers_disjoint (D1:=D1) (D2:=D2) (i1 ↦ κ1) (i2 ↦ κ2);

    layer_sim_cancel_disjoint {D D'} (R: simrel D D') L L1 L2:
      layers_disjoint L L2 ->
      sim R L (L1 ⊕ L2) ->
      sim R L L1;
    layers_disjoint_primitive i D (L1 L2: layer D):
      layers_disjoint L1 L2 ->
      get_layer_primitive i (L1 ⊕ L2) = get_layer_primitive i L1 \/
      get_layer_primitive i (L1 ⊕ L2) = get_layer_primitive i L2;
    layers_disjoint_globalvar i D (L1 L2: layer D):
      layers_disjoint L1 L2 ->
      get_layer_globalvar i (L1 ⊕ L2) = get_layer_globalvar i L1 \/
      get_layer_globalvar i (L1 ⊕ L2) = get_layer_globalvar i L2;

    oplus_wf D (L1 L2: layer D):
      layer_wf L1 ->
      layer_wf L2 ->
      layer_wf (L1 ⊕ L2)
  }.

  Global Instance layer_pjoin `(Layers):
    SimPseudoJoin layerdata simrel layer (fun _ => ∅).
  Proof.
    eapply simjoin_pjoin; typeclasses eauto.
  Qed.

  (** Specialized version of [layer_sim_intro]. *)
  Lemma layer_le_intro `{Layers} {D} i (σ1 σ2: primsem D):
    σ1 ≤ σ2 ->
    i ↦ σ1 ≤ i ↦ σ2.
  Proof.
    apply layer_sim_intro.
  Qed.

(** NOW WRONG -- though can be enforced through layer_ok
  <<<
    get_layer_primitive_globalvar_disjoint {D} (L: layer D) (i: ident):
      isOK (get_layer_primitive i L) ->
      isOK (get_layer_globalvar i L) ->
      isOKNone (get_layer_primitive i L) \/ isOKNone (get_layer_globalvar i L)
  >>> *)
End WITH_LAYER_DATA.

Global Instance get_layer_primitive_sim_monotonic_params:
  Params (@get_layer_primitive) 3.

Global Instance get_layer_globalvar_sim_monotonic_params:
  Params (@get_layer_globalvar) 3.

(** Rewrite hints for [get_layer_primitive] and [get_layer_globalvar] *)

Ltac get_layer_normalize :=
  repeat rewrite
    ?get_layer_primitive_empty,
    ?get_layer_primitive_mapsto,
    ?get_layer_primitive_mapsto_other_primitive,
    ?get_layer_primitive_mapsto_globalvar,
    ?get_layer_primitive_oplus,
    ?get_layer_globalvar_empty,
    ?get_layer_globalvar_mapsto,
    ?get_layer_globalvar_mapsto_other_globalvar,
    ?get_layer_globalvar_mapsto_primitive,
    ?get_layer_globalvar_oplus by congruence.

Ltac get_layer_normalize_in H :=
  repeat rewrite
    ?get_layer_primitive_empty,
    ?get_layer_primitive_mapsto,
    ?get_layer_primitive_mapsto_other_primitive,
    ?get_layer_primitive_mapsto_globalvar,
    ?get_layer_primitive_oplus,
    ?get_layer_globalvar_empty,
    ?get_layer_globalvar_mapsto,
    ?get_layer_globalvar_mapsto_other_globalvar,
    ?get_layer_globalvar_mapsto_primitive,
    ?get_layer_globalvar_oplus in H by congruence.

(** * Asserting a property for all primitives *)

Section FORALL_PRIM.
  Context `{Hlayer: Layers}.
  Context `{Hident: EqDec ident}.

  Class ForallPrimitive D (P: primsem D -> Prop) (L: layer D) :=
    {
      forall_primitive_at i σ:
        get_layer_primitive i L = OK (Some σ) ->
        P σ
    }.

  Global Instance forallprim_empty D P:
    ForallPrimitive D P ∅.
  Proof.
    split.
    simpl.
    intros.
    rewrite get_layer_primitive_empty in H.
    discriminate.
  Qed.

  Global Instance forallprim_mapsto_primitive D (P: _ -> Prop) i σ:
    P σ ->
    ForallPrimitive D P (i ↦ σ).
  Proof.
    intros Hσ.
    split.
    - intros j σj Hσj.
      destruct (decide (j = i)); subst; get_layer_normalize_in Hσj; congruence.
  Qed.

  Global Instance forallprim_mapsto_globalvar D P i (τ: V):
    ForallPrimitive D P (i ↦ τ).
  Proof.
    split.
    - intros j σj Hσj.
      rewrite get_layer_primitive_mapsto_globalvar in Hσj.
      discriminate.
  Qed.

  Lemma forallprim_oplus_disjoint D (P: primsem D -> Prop) L1 L2:
    layers_disjoint L1 L2 ->
    ForallPrimitive D P L1 ->
    ForallPrimitive D P L2 ->
    ForallPrimitive D P (L1 ⊕ L2).
  Proof.
    intros HP H1 H2.
    constructor.
    intros i σ Hσ.
    destruct (layers_disjoint_primitive i D L1 L2); eauto.
    - eapply (forall_primitive_at (L:=L1) i).
      congruence.
    - eapply (forall_primitive_at (L:=L2) i).
      congruence.
  Qed.

  Lemma forallprim_oplus_union D (P: primsem D -> Prop) L1 L2:
    (forall σ1 σ2, P σ1 -> P σ2 -> P (σ1 ⊕ σ2)) ->
    ForallPrimitive D P L1 ->
    ForallPrimitive D P L2 ->
    ForallPrimitive D P (L1 ⊕ L2).
  Proof.
    intros HP H1 H2.
    split.
    - intros i σ Hσ.
      simpl in Hσ.
      rewrite get_layer_primitive_oplus in Hσ.
      destruct (get_layer_primitive i L1) as [[|]|] eqn:Hσ1;
      destruct (get_layer_primitive i L2) as [[|]|] eqn:Hσ2;
      try discriminate;
      simpl in Hσ;
      monad_norm;
      inversion Hσ; clear Hσ; subst.
      + eapply HP; eauto.
        * eapply (forall_primitive_at _ _ Hσ1).
        * eapply (forall_primitive_at _ _ Hσ2).
      + eapply (forall_primitive_at _ _ Hσ1).
      + eapply (forall_primitive_at _ _ Hσ2).
  Qed.

  Global Instance forallprim_mono:
    Monotonic ForallPrimitive (forallr -, (- ==> impl) ++> - ==> impl).
  Proof.
    repeat red.
    intros D P1 P2 HP L HL.
    constructor.
    intros i σ Hσ.
    apply HP.
    eapply HL.
    eassumption.
  Qed.

(** The following is wrong, because of [OK None] being refined by [OK (Some _)].
<<
  Global Instance forallprim_sim_mono:
    Proper
      (∀ R, (sim R ++> impl) ++> sim R ++> impl)
      ForallPrimitive.
>>
*)

End FORALL_PRIM.

(* unused ATM, needs [: typeclass_instances]
Hint Extern 2 (ForallPrimitive _ _ (_ ⊕ _)) =>
  eapply forallprim_oplus.
*)

(** * Well-formed layers *)

Section LAYER_OK.
  Context `{Hlayer: Layers}.
  Context `{Hprim: !Primitives primsem}.
  Context `{ident_dec: EqDec ident}.

  Record LayerOK_at {D} (L: layer D) (i: ident): Prop :=
    {
      layer_ok_primitive:
        isOK (get_layer_primitive i L);
      layer_ok_globalvar:
        isOK (get_layer_globalvar i L);
      layer_ok_disjoint:
        isOKNone (get_layer_primitive i L) \/
        isOKNone (get_layer_globalvar i L)
    }.

  Global Instance layer_ok_at_dec {D} (L: layer D) (i: ident):
    Decision (LayerOK_at L i) :=
    match (decide (isOK (get_layer_primitive i L) /\
                   isOK (get_layer_globalvar i L) /\
                   (isOKNone (get_layer_primitive i L) \/
                    isOKNone (get_layer_globalvar i L))))
    with
      | left Hyes => left _
      | right Hno => right _
    end.
  Proof.
    abstract (destruct Hyes as (H1 & H2 & H3); split; assumption).
    abstract (intros [H1 H2 H3]; eauto).
  Defined.

  Class LayerOK {D} (L: layer D): Prop :=
    layer_ok_at: forall i, LayerOK_at L i.

  (** This alternate definition is used for providing a decision procedure. *)
  Definition LayerOK_alt {D} (L: layer D) :=
    (forall i, get_layer_primitive i L <> OK None ->
               (fun i => isOK (get_layer_primitive i L) /\
                         isOKNone (get_layer_globalvar i L)) i) /\
    (forall i, get_layer_globalvar i L <> OK None ->
               (fun i => isOK (get_layer_globalvar i L) /\
                         isOKNone (get_layer_primitive i L)) i).

  (** Let's prove it is equivalent *)
  Lemma LayerOK_alt_equiv {D} (L: layer D):
    LayerOK_alt L <-> LayerOK L.
  Proof.
    unfold LayerOK_alt.
    split.
    * intros [H1 H2] i.
      specialize (H1 i).
      specialize (H2 i).
      split.
      + destruct (get_layer_primitive i L) as [[|]|]; eauto.
        destruct H1; try discriminate.
        assumption.
      + destruct (get_layer_globalvar i L) as [[|]|]; eauto.
        destruct H2; try discriminate.
        assumption.
      + destruct (get_layer_primitive i L) as [[|]|]; eauto.
        - destruct H1; try discriminate; eauto.
        - destruct H1; try discriminate; eauto.
    * intros H.
      split; intros i Hi; destruct (H i) as [Hp Hv Hd];
      split; destruct Hd; eauto; congruence.
  Qed.

  Global Instance LayerOK_dec {D} (L: layer D): Decision (LayerOK L) :=
    match decide (LayerOK_alt L) with
      | left Hyes => left _
      | right Hno => right _
    end.
  Proof.
    * abstract (apply LayerOK_alt_equiv; assumption).
    * abstract (rewrite <- LayerOK_alt_equiv; assumption).
  Defined.

  (** ** Monotonicity *)

  Global Instance layer_ok_at_le:
    Monotonic (@LayerOK_at) (forallr -, (≤) --> - ==> impl).
  Proof.
    intros D L2 L1 HL i [Hp Hg Hd].
    red in HL.
    split.
    - revert Hp; rauto.
    - revert Hg; rauto.
    - revert Hd; rauto.
  Qed.

  Lemma layer_ok_at_sim {D1 D2} (R: simrel D1 D2) L1 L2 i:
    sim R L1 L2 ->
    LayerOK_at L2 i ->
    LayerOK_at L1 i.
  Proof.
    intros HL [H2p H2v H2d].
    split.
    * eapply (isOK_le _ _ (option_le (sim R))); try eassumption.
      solve_monotonic.
    * eapply (isOK_le _ _ (option_le eq)); try eassumption.
      solve_monotonic.
    * destruct H2d; [left|right].
      + eapply (isOKNone_le _ _ (sim R)); try eassumption.
        solve_monotonic.
      + eapply (isOKNone_le _ _ eq); try eassumption.
        solve_monotonic.
  Qed.

  (** XXX: need as an instance of [LayerOK] also? *)
  Global Instance layer_ok_antitonic:
    Monotonic (@LayerOK) (forallr -, (≤) --> impl).
  Proof.
    intros D L2 L1 HL H i.
    specialize (H i).
    eapply layer_ok_at_le; eassumption.
  Qed.

  Global Instance layer_ok_sim_antitonic {D1 D2} (R: simrel D1 D2) L1 L2:
    sim R L1 L2 ->
    LayerOK L2 ->
    LayerOK L1.
  Proof.
    intros HL HL2 i.
    specialize (HL2 i).
    eapply layer_ok_at_sim; eassumption.
  Qed.

  (** ** Basic instances *)

  Global Instance empty_ok `{Layers} D:
    LayerOK (D := D) ∅.
  Proof.
    intros i.
    split; get_layer_normalize; eauto.
  Qed.

  Global Instance mapsto_function_ok {D} i (σ: primsem D):
    LayerOK (i ↦ σ).
  Proof.
    intros j.
    destruct (decide (j = i)); subst;
    split; get_layer_normalize; eauto.
  Qed.

  Global Instance mapsto_variable_ok {D} i (τ: V):
    LayerOK (D:=D) (i ↦ τ).
  Proof.
    intros j.
    destruct (decide (j = i)); subst;
    split; get_layer_normalize; eauto.
  Qed.

  Lemma layer_oplus_primitive_ok {D} (L: layer D) (i: ident) (σ: primsem D):
    isOKNone (get_layer_primitive i L) ->
    isOKNone (get_layer_globalvar i L) ->
    LayerOK L ->
    LayerOK (L ⊕ i ↦ σ).
  Proof.
    intros HLip HLiv HL j.
    specialize (HL j); destruct HL as [HLp HLv HLd].
    unfold isOKNone in *.
    destruct (decide (j = i)); subst.
    * split; get_layer_normalize;
      rewrite ?HLip, ?HLiv, ?id_left;
      eauto.
      right; reflexivity.
    * split; get_layer_normalize;
      rewrite ?id_right;
      eauto.
      destruct HLd as [H|H]; rewrite H; eauto.
      right; reflexivity.
  Qed.
End LAYER_OK.

(** * Other properties *)

(** Properties of [layers_disjoint]. *)

Lemma layers_disjoint_mapsto_globalvar_primitive `{Layers}
      {D1 D2} i1 i2 (κ1: V) (σ2: primsem D2):
      i1 <> i2 ->
      layers_disjoint (D1:=D1) (i1 ↦ κ1) (i2 ↦ σ2).
Proof.
  intros H0.
  apply layers_disjoint_sym.
  apply layers_disjoint_mapsto_primitive_globalvar.
  congruence.
Qed.

(** Express the monotonicity of [i ↦ σ] in terms of [≤]. *)

Global Instance layer_mapsto_mon `{Layers} D:
  @Monotonic (ident -> primsem D -> layer D) (↦) (- ==> (≤) ++> (≤)).
Proof.
  intros i σ1 σ2 Hσ.
  apply layer_le_intro.
  assumption.
Qed.

Lemma layer_oplus_primitive_same `{Layers} {D} L i (σ: primsem D):
  isOKNone (get_layer_primitive i L) ->
  get_layer_primitive i (L ⊕ i ↦ σ) = OK (Some σ).
Proof.
  intros HLi.
  get_layer_normalize.
  red in HLi.
  rewrite HLi.
  rewrite id_left.
  reflexivity.
Qed.

Lemma layer_oplus_primitive_other `{Layers} {D} L i (σ: primsem D) j:
  j <> i ->
  get_layer_primitive j (L ⊕ i ↦ σ) = get_layer_primitive j L.
Proof.
  intros Hij.
  get_layer_normalize.
  rewrite id_right.
  reflexivity.
Qed.

Lemma layer_oplus_globalvar `{Layers} {D} L i (σ: primsem D) j:
  get_layer_globalvar j (L ⊕ i ↦ σ) = get_layer_globalvar j L.
Proof.
  get_layer_normalize.
  autorewrite with res_option_globalvar.
  reflexivity.
Qed.

Section AuxLemma.

  Lemma get_layer_primitive_isOK `{LOps: Layers} {D}:
    forall i (a b: _ D),
      isOK (get_layer_primitive i (a ⊕ b)) ->
      isOK (get_layer_primitive i a)
      /\ isOK (get_layer_primitive i b).
  Proof.
    intros. destruct H as [? Hcom].
    specialize (get_layer_primitive_oplus i a b).
    rewrite Hcom.
    intros.
    destruct (get_layer_primitive i a);
      destruct (get_layer_primitive i b); inv_monad H.
    - eauto.
    - destruct o; inversion H1.
  Qed.

  Lemma get_layer_primitive_none `{LOps: Layers} {D}:
    forall i (a b: _ D),
      get_layer_primitive i b = OK None ->
      get_layer_primitive i a = OK None ->
      isOK (get_layer_primitive i (a ⊕ b)) ->
      get_layer_primitive i (a ⊕ b) = OK None.
  Proof.
    intros. destruct H1 as [? Hcom].
    specialize (get_layer_primitive_oplus i a b).
    rewrite Hcom. rewrite H. rewrite H0.
    intros. inv_monad H1.
    reflexivity.
  Qed.

  Lemma get_layer_globalvar_isOK `{LOps: Layers} {D}:
    forall i (a b: _ D),
      isOK (get_layer_globalvar i (a ⊕ b)) ->
      isOK (get_layer_globalvar i a)
      /\ isOK (get_layer_globalvar i b).
  Proof.
    intros. destruct H as [? Hcom].
    specialize (get_layer_globalvar_oplus i a b).
    rewrite Hcom.
    destruct (get_layer_globalvar i a) as [ [ va | ] | ] ;
      destruct (get_layer_globalvar i b) as [ [ vb | ] | ] ;
      res_option_globalvar_red;
      eauto;
      congruence.
  Qed.

  Lemma get_layer_globalvar_OK_Some_left `{LOps: Layers} {D}:
    forall i (a b: _ D) v v',
      get_layer_globalvar i a = OK (Some v) ->
      get_layer_globalvar i (a ⊕ b) = OK (Some v') ->
      v' = v.
  Proof.
    intros.
    specialize (get_layer_globalvar_oplus i a b).
    rewrite H. rewrite H0.
    destruct (get_layer_globalvar i b) as [ [ v0 | ] | ];
      res_option_globalvar_red;
      try congruence.
    destruct (globalvar_eq_dec v v0).
    - subst. autorewrite with res_option_globalvar. congruence.
    - rewrite res_option_globalvar_oplus_diff; congruence.
  Qed.

  Lemma get_layer_globalvar_OK_Some_right `{LOps: Layers} {D}:
    forall i (a b: _ D) v v',
      get_layer_globalvar i b = OK (Some v) ->
      get_layer_globalvar i (a ⊕ b) = OK (Some v') ->
      v' = v.
  Proof.
    intros.
    specialize (get_layer_globalvar_oplus i a b).
    rewrite H. rewrite H0.
    destruct (get_layer_globalvar i a) as [ [ v0 | ] | ];
      res_option_globalvar_red;
      try congruence.
    destruct (globalvar_eq_dec v v0).
    - subst. autorewrite with res_option_globalvar. congruence.
    - rewrite res_option_globalvar_oplus_diff; congruence.
  Qed.

  Lemma get_layer_globalvar_left `{LOps: Layers} {D}:
    forall i (a b: _ D) v,
      get_layer_globalvar i a = OK (Some v) ->
      isOK (get_layer_globalvar i (a ⊕ b)) ->
      get_layer_globalvar i (a ⊕ b) = OK (Some v).
  Proof.
    intros. destruct H0 as [? Hcom].
    specialize (get_layer_globalvar_oplus i a b).
    rewrite Hcom. rewrite H.
    destruct (get_layer_globalvar i b) as [ [ v0 | ] | ];
      res_option_globalvar_red;
      try congruence.
    destruct (globalvar_eq_dec v v0).
    - subst. autorewrite with res_option_globalvar. congruence.
    - rewrite res_option_globalvar_oplus_diff; congruence.
  Qed.

  Lemma get_layer_globalvar_right `{LOps: Layers} {D}:
    forall i (a b: _ D) v,
      get_layer_globalvar i b = OK (Some v) ->
      isOK (get_layer_globalvar i (a ⊕ b)) ->
      get_layer_globalvar i (a ⊕ b) = OK (Some v).
  Proof.
    intros. destruct H0 as [? Hcom].
    specialize (get_layer_globalvar_oplus i a b).
    rewrite Hcom. rewrite H.
    destruct (get_layer_globalvar i a) as [ [ v0 | ] | ];
      res_option_globalvar_red;
      try congruence.
    destruct (globalvar_eq_dec v v0).
    - subst. autorewrite with res_option_globalvar. congruence.
    - rewrite res_option_globalvar_oplus_diff; congruence.
  Qed.

  Lemma get_layer_globalvar_none `{LOps: Layers} {D}:
    forall i (a b:_ D),
      get_layer_globalvar i b = OK None ->
      get_layer_globalvar i a = OK None ->
      isOK (get_layer_globalvar i (a ⊕ b)) ->
      get_layer_globalvar i (a ⊕ b) = OK None.
  Proof.
    intros. destruct H1 as [? Hcom].
    specialize (get_layer_globalvar_oplus i a b).
    rewrite Hcom. rewrite H. rewrite H0.
    autorewrite with res_option_globalvar.
    congruence.
  Qed.

  Lemma get_layer_primitive_cancel `{LOps: Layers} {D}:
    forall i (a b: _ D),
      get_layer_primitive i (a ⊕ b) = OK None ->
      get_layer_primitive i b = OK None /\
      get_layer_primitive i a = OK None.
  Proof.
    intros.
    specialize (get_layer_primitive_oplus i a b).
    rewrite H.
    intros.
    destruct (get_layer_primitive i a); try destruct o;
    destruct (get_layer_primitive i b); try destruct o;
    inv_monad H0; eauto.
  Qed.

  Lemma get_layer_globalvar_cancel `{LOps: Layers} {D}:
    forall i (a b: _ D),
      get_layer_globalvar i (a ⊕ b) = OK None ->
      get_layer_globalvar i b = OK None /\
      get_layer_globalvar i a = OK None.
  Proof.
    intros.
    specialize (get_layer_globalvar_oplus i a b).
    rewrite H.
    destruct (get_layer_globalvar i a) as [ [ va | ] | ] ;
    destruct (get_layer_globalvar i b) as [ [ vb | ] | ] ;
    res_option_globalvar_red;
    try congruence;
    auto.
    destruct (globalvar_eq_dec va vb).
    - subst. autorewrite with res_option_globalvar. congruence.
    - rewrite res_option_globalvar_oplus_diff; congruence.
  Qed.

  Lemma get_layer_primitive_OK_eq `{LOps: Layers} `{Heq: EqDec ident} {D}:
    forall i j σ1 σ2,
      get_layer_primitive (D:=D) j (i ↦ σ2) = OK (Some σ1) ->
      σ2 = σ1.
  Proof.
    intros.
    destruct (Heq j i); subst.
    - subst. rewrite get_layer_primitive_mapsto in H.
      inversion H. reflexivity.
    - rewrite get_layer_primitive_mapsto_other_primitive in H.
      discriminate. assumption.
  Qed.

End AuxLemma.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Import Blech.Category.Under.
Require Blech.Reflect.

Import CategoryNotations.
Import BishopNotations.
Import UnderNotations.

Open Scope category_scope.
Open Scope bishop_scope.

#[local]
Obligation Tactic := Reflect.category_simpl.

#[program]
Definition Ptd (C: Category): Category := {|
  Obj := ∀ pt, C\pt ;
  Mor A B := (∀ pt, (C\pt) (A pt) (B pt)) ;
  Mor_Setoid _ _ := {| equiv f g := ∀ x, f x == g x |} ;

  id A _ := id _ ;
  compose A B C f g t := f t ∘ g t ;
|}.

Next Obligation.
Proof.
  exists.
  all: unfold Reflexive, Symmetric, Transitive.
  - reflexivity.
  - symmetry.
    auto.
  - intros ? ? ? p q t.
    rewrite p, q.
    reflexivity.
Qed.

Next Obligation.
Proof.
  intros ? ? p ? ? q t.
  cbn in *.
  rewrite (p t), (q t).
  reflexivity.
Qed.


(** * Indiscrete category *)
Require Import Functor.Core Category.Strict Category.Univalent Category.Morphisms.
Require Import Types.Unit Trunc HoTT.Tactics Equivalences.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

(** ** Definition of an indiscrete category *)
Module Export Core.
  Section indiscrete_category.
    (** The indiscrete category has exactly one morphism between any two
      objects. *)
    Variable X : Type.

    (** We define the symmetrized version of associaitivity differently
      so that the dual of an indiscrete category is convertible with
      the indiscrete category. *)

    Definition indiscrete_category : PreCategory
      := @Build_PreCategory' X
                             (fun _ _ => Unit)
                             (fun _ => tt)
                             (fun _ _ _ _ _ => tt)
                             (fun _ _ _ _ _ _ _ => idpath)
                             (fun _ _ _ _ _ _ _ => idpath)
                             (fun _ _ f => match f with tt => idpath end)
                             (fun _ _ f => match f with tt => idpath end)
                             (fun _ => idpath)
                             _.
  End indiscrete_category.

  (** *** Indiscrete categories are strict categories *)
  Definition isstrict_indiscrete_category `{H : IsHSet X}
  : IsStrictCategory (indiscrete_category X)
    := H.

  (** *** Indiscrete categories are (saturated/univalent) categories *)
  Global Instance iscategory_indiscrete_category `{H : IsHProp X}
  : IsCategory (indiscrete_category X).
  Proof.
    intros.

    eapply (isequiv_adjointify
              (idtoiso (indiscrete_category X) (x := s) (y := d))
              (fun _ => center _));
      abstract (
          repeat intro;
          destruct_head_hnf @Isomorphic;
          destruct_head_hnf @IsIsomorphism;
          destruct_head_hnf @Unit;
          path_induction_hammer
        ).
  Defined.
End Core.

(** ** Functors to an indiscrete category are given by their action on objects *)
Module Functors.
  Section to.
    Variable X : Type.
    Variable C : PreCategory.
    Variable objOf : C -> X.

    Definition to : Functor C (indiscrete_category X)
      := Build_Functor C (indiscrete_category X)
                       objOf
                       (fun _ _ _ => tt)
                       (fun _ _ _ _ _ => idpath)
                       (fun _ => idpath).
  End to.
End Functors.


From Autosubst Require Export Autosubst.
From fae_gtlc_mu.cast_calculus Require Export types types_lemmas.
From fae_gtlc_mu.cast_calculus Require Import types_notations.
From fae_gtlc_mu Require Import prelude.

Inductive consistency_open : type -> type -> Type :=
| GenSymUnit :
    consistency_open TUnit TUnit
| GenSymUnknownL τ :
    consistency_open TUnknown τ
| GenSymUnknownR τ :
    consistency_open τ TUnknown
| GenSymSum
    (τ1 τ1' τ2 τ2' : type)
    (s1 : consistency_open τ1 τ1')
    (s2 : consistency_open τ2 τ2')
  : consistency_open (τ1 + τ2)%types (τ1' + τ2')%types
| GenSymProd
    (τ1 τ1' τ2 τ2' : type)
    (s1 : consistency_open τ1 τ1')
    (s2 : consistency_open τ2 τ2')
  : consistency_open (τ1 × τ2)%types (τ1' × τ2')%types
| GenSymArrow τ1 τ1' τ2 τ2'
    (s1 : consistency_open τ1 τ1')
    (s2 : consistency_open τ2 τ2')
  : consistency_open (TArrow τ1 τ2) (TArrow τ1' τ2')
| GenSymVar i :
    consistency_open (TVar i) (TVar i)
| GenSymRec τ τ' (P : consistency_open τ τ') :
    consistency_open (TRec τ) (TRec τ').

Definition consistency τ (pτ : Closed τ) τ' (pτ' : Closed τ') : Type := consistency_open τ τ'.


Require Import Program Bvector List Relations.
From Equations Require Import Equations Signature DepElimDec.
Require Import Utf8.
Unset Equations WithK.

Inductive Vec (A : Set) : nat -> Set :=
  nil  : Vec A O
| cons : forall {n} (x : A) (xs : Vec A n), Vec A (S n).

Derive NoConfusion for Vec.
Derive NoConfusionHom for Vec.

Transparent NoConfusionHom_Vec.
Definition noConfVec_eq {A n} (v v' : Vec A n) : v = v' -> NoConfusionHom_Vec _ _ v v'.
Proof.
  intros ->. destruct v'; constructor.
Defined.

Definition noConfVec_eq_inv {A n} (v v' : Vec A n) : NoConfusionHom_Vec _ _ v v' -> v = v'.
Proof.
  funelim (NoConfusionHom_Vec _ _ v v'); simplify *; constructor.
Defined.

Lemma noConfVec_eq_eq_inv {A n} (v v' : Vec A n) (e : v = v') :
  noConfVec_eq_inv _ _ (noConfVec_eq _ _ e) = e.
Proof.
  destruct e. destruct v; reflexivity.
Defined.

Lemma noConfVec_eq_inv_eq {A n} (v v' : Vec A n) (e : NoConfusionHom_Vec _ _ v v') :
  noConfVec_eq _ _ (noConfVec_eq_inv _ _ e) = e.
Proof.
  destruct v; revert e. depelim v'. simplify *; reflexivity.
  depelim v'. simplify *. simpl. reflexivity.
Defined.


(** Coq coding by choukh, June 2022 **)

From HF Require Export Meta.

Reserved Notation "x ⨮ y" (at level 65, right associativity).
Reserved Notation "x ∈ y" (at level 70).

(** 遗传有穷结构 **)
Class HF := {
  集 : Type;
  空 : 集;
  并 : 集 → 集 → 集
    where "x ⨮ y" := (并 x y) (* {x} ∪ y *)
    and "x ∈ y" := (x ⨮ y = y);
  栖 x y : x ⨮ y ≠ 空;
  入 x y : x ∈ x ⨮ y;
  易 x y z : x ⨮ y ⨮ z = y ⨮ x ⨮ z;
  属 x y z : x ∈ y ⨮ z → x = y ∨ x ∈ z;
  强归纳 (P : 集 → Type) : P 空 → (∀ x y, P x → P y → P (x ⨮ y)) → ∀ x, P x;
}.

Coercion 集 : HF >-> Sortclass.
Arguments 空 {_}.

Notation "∅" := 空 : hf_scope.
Notation "x ⨮ y" := (并 x y) : hf_scope.
Notation "x ∈ y" := (x ⨮ y = y) : hf_scope.
Notation "x ∉ y" := (x ⨮ y ≠ y) (at level 70) : hf_scope.
Notation "x ⊆ y" := (∀ z, z ∈ x → z ∈ y) (at level 70) : hf_scope.
Notation "x ⊈ y" := (¬ x ⊆ y) (at level 70) : hf_scope.
Notation "x ⁺" := (x ⨮ x) (at level 50) : hf_scope.
Notation "{ x , }" := (x ⨮ ∅) (format "{ x , }") : hf_scope.
Notation "{ x , y }" := (x ⨮ {y,}) : hf_scope.
Notation 栖居 x := (∃ y, y ∈ x).

Notation "∀ x .. y ∈ A , P" :=
  (∀ x, x ∈ A → (.. (∀ y, y ∈ A → P) ..))
  (only parsing, at level 200, x binder, right associativity) : hf_scope.

Notation "∃ x .. y ∈ A , P" :=
  (∃ x, x ∈ A ∧ (.. (∃ y, y ∈ A ∧ P) ..))
  (only parsing, at level 200, x binder, right associativity) : hf_scope.

Ltac hf_ind x := pattern x; revert x; apply 强归纳.

(* 基本事实 *)
Section Basic.
Context {𝓜 : HF}.
Implicit Types x y z : 𝓜.

Theorem 空集定理 x : x ∉ ∅.
Proof. intros []%栖. Qed.

Example 并运算测试 : {{∅,},} ≠ {∅,}.
Proof.
  intros H. assert (H' := H). rewrite <- 入, H in H'.
  apply 属 in H' as [H'|H']; now apply 空集定理 in H'.
Qed.

Theorem 并运算规范 x y z : z ∈ x ⨮ y ↔ z = x ∨ z ∈ y.
Proof.
  split.
  - apply 属.
  - intros [-> | H].
    + apply 入.
    + now rewrite 易, H.
Qed.

Fact 并作子集 x y z : x ⨮ y ⊆ z ↔ x ∈ z ∧ y ⊆ z.
Proof.
  split.
  - intros H. split.
    + apply H, 入.
    + intros a ay. apply H, 并运算规范. now right.
  - intros [H1 H2] a [->|]%并运算规范; auto.
Qed.

Fact 空集的子集 x : x ⊆ ∅ → x = ∅.
Proof.
  hf_ind x.
  - auto.
  - intros x y _ _ H.
    assert (x0: x ∈ ∅) by apply H, 入.
    contradict (空集定理 x0).
Qed.

Fact 空集可判定 x : x = ∅ ∨ 栖居 x.
Proof.
  hf_ind x.
  - now left.
  - intros x y _ _. right. exists x. apply 入.
Qed.

Fact 非空即栖居 x : x ≠ ∅ ↔ 栖居 x.
Proof.
  destruct (空集可判定 x) as [->|[y yx]]; split.
  - easy.
  - intros [x x0]. contradict (空集定理 x0).
  - eauto.
  - intros _ ->. contradict (空集定理 yx).
Qed.

Definition 传递 x := ∀ y z, y ∈ z → z ∈ x → y ∈ x.

End Basic.

(** 自动化 **)

Lemma 全称等价左 T P Q : (∀ x : T, P x ↔ Q x) → ∀ x, P x → Q x.
Proof. firstorder. Qed.

Lemma 全称等价右 T P Q : (∀ x : T, P x ↔ Q x) → ∀ x, Q x → P x.
Proof. firstorder. Qed.

Ltac 非前提 P := match goal with
  |[_ : P |- _] => fail 1
  | _ => idtac
end.
Ltac 加前提 H := let T := type of H in 非前提 T; generalize H; intro.

Ltac 引入 := match goal with
  |[ |- _ → _ ] => intro
  |[ |- _ ∧ _ ] => split
  |[ |- _ ↔ _] => split
  |[ |- ¬ _ ] => intro
  |[ |- ∀ _, _ ] => intro
  |[ |- _ ∈ _ ⨮ _] => apply 并运算规范
  |[ |- 栖居 _] => apply 非空即栖居
  |[ |- 传递 _] => hnf
end.

Ltac 消去 := match goal with
  |[H: Σ _, _ |- _ ] => destruct H
  |[H: ∃ _, _ |- _ ] => destruct H
  |[H: _ ∧ _ |- _ ] => destruct H
  |[H: _ * _ |- _] => destruct H
  |[H: ∀ _, _ ↔ _  |- _] => 加前提 (全称等价左 H); 加前提 (全称等价右 H); clear H
  |[H: ?P ∨ ?Q |- _] => 非前提 P; 非前提 Q; destruct H
  |[H: ?P + ?Q |- _] => 非前提 P; 非前提 Q; destruct H
  |[H: _ ⨮ _ = ∅ |- _] => destruct (栖 H)
  |[H: ∅ = _ ⨮ _ |- _] => destruct (栖 (eq_sym H))
  |[H: _ ∈ ∅ |- _] => destruct (空集定理 H)
  |[H: ?z ∈ ?x ⨮ _ |- _] => apply 并运算规范 in H as [|]
  |[H: _ ⨮ _ ⊆ _ |- _ ] => apply 并作子集 in H as []
  |[H: _ ⊆ ∅ |- _] => apply 空集的子集 in H as ->
  |[H: 传递 ?x, H': _ ∈ ?x |- _] => 加前提 (H _ H')
end.

Ltac hf n := repeat progress (reflexivity || subst || 引入 || 消去);
  try tauto; match n with
  | O => idtac
  | S ?n => match goal with
    |[ |- _ ∨ _] => solve [left; hf n | right; hf n]
    |[ |- _ + _] => solve [left; hf n | right; hf n]
    |[ |- 可判定 _] => solve [left; hf n | right; hf n]
    |[ |- ?x ⨮ ?y ⨮ ?z = ?y ⨮ ?x ⨮ ?z ] => apply 易
    |[ |- ?x ∈ ?x ⨮ ?y ] => apply 入
    |[ |- ?x ⨮ ?y = ?x ⨮ ?x ⨮ ?y ] => now rewrite 入
    |[H: ?X |- ∃ x : ?X, _ ] => exists H; hf n
    |[H: ∀ x,  x ∈ ?z → _, H': ?X ∈ ?z |- _ ] => 加前提 (H X H'); clear H; hf n
    |[H: ∀ x, _ → x ∈ ?z |- _ ∈ ?z] => apply H; hf n
    |[H: ?x ⊆ _, H': ?z ∈ ?x |- _ ] => 加前提 (H z H'); clear H; hf n
  end
end.

Tactic Notation "hf" := cbn; solve [hf 7].


Require Export Ascii String.

Require Import QArith.
Require Export DTimeQ.

Require Export MinBFT.
Require Export RunSM.
Require Export Ref.

Require Export ComponentSM2.
Require Export ComponentSM4.

(* ================== MINBFT CONTEXT ================== *)

Definition minbft_digest : Set := string.

Definition minbft_digest_def : minbft_digest := "".

Lemma minbft_digest_deq : Deq minbft_digest.
Proof.
  introv; apply string_dec.
Defined.

Inductive sending_key_stub : Set :=
| minbft_sending_key_stub.

Inductive receiving_key_stub : Set :=
| minbft_receiving_key_stub.

Definition minbft_sending_key   : Set := sending_key_stub.
Definition minbft_receiving_key : Set := receiving_key_stub.

(*Definition F : nat := 1.*)
Definition nreps (F : nat) : nat := 2 * F + 1.

Definition replica (F : nat) : Set := nat_n (nreps F).

Lemma replica_deq (F : nat) : Deq (replica F).
Proof.
  apply nat_n_deq.
Defined.

Definition reps2nat (F : nat) : replica F -> nat_n (nreps F) := fun n => n.

Lemma bijective_reps2nat (F : nat) : bijective (reps2nat F).
Proof.
  exists (fun n : nat_n (nreps F) => n); introv; unfold reps2nat; auto.
Defined.

Definition replica0 (F : nat) : replica F.
Proof.
  exists 0.
  apply leb_correct.
  unfold nreps.
  omega.
Defined.

Definition replica1 : replica 1.
Proof.
  exists 1.
  apply leb_correct.
  unfold nreps.
  omega.
Defined.

Definition replica2 : replica 1.
Proof.
  exists 2.
  apply leb_correct.
  unfold nreps.
  omega.
Defined.

Definition nclients (C : nat) : nat := S C.

Definition client (C : nat) : Set := nat_n (nclients C).

Definition client0 (C : nat) : client C.
Proof.
  exists 0.
  apply leb_correct.
  unfold nclients.
  omega.
Defined.

Lemma client_deq (C : nat) : Deq (client C).
Proof.
  apply nat_n_deq.
Defined.

Definition clients2nat (C : nat) : client C -> nat_n (nclients C) := fun n => n.

Lemma bijective_clients2nat (C : nat) : bijective (clients2nat C).
Proof.
  exists (fun n : nat_n (nclients C) => n); introv; unfold clients2nat; auto.
Defined.
(* original
Inductive minbft_data_message :=
| minbft_data_message_plus (n : nat)
| minbft_data_message_minus (n : nat).

Lemma minbft_data_message_deq : Deq minbft_data_message.
Proof.
  introv; destruct x as [x|x], y as [y|y];
    destruct (deq_nat x y); prove_dec.
Defined.
 *)

Definition minbft_data_message := nat.

Lemma minbft_data_message_deq : Deq minbft_data_message.
Proof.
  introv; apply deq_nat.
Defined.

Definition minbft_result := nat.

Lemma minbft_result_deq : Deq minbft_result.
Proof.
  introv; apply deq_nat.
Defined.

Definition minbft_sm_state := nat.

Definition minbft_sm_initial_state : minbft_sm_state := 0.

(* original
Definition minbft_sm_update
           (C : nat)
           (c : client C)
           (s : minbft_sm_state)
           (m : minbft_data_message) : minbft_result * minbft_sm_state :=
  match m with
  | minbft_data_message_plus  n => let x := s + n in (x,x)
  | minbft_data_message_minus n => let x := s - n in (x,x)
  end.
 *)

Definition minbft_sm_update
           (C : nat)
           (c : client C)
           (s : minbft_sm_state)
           (m : minbft_data_message) : minbft_result * minbft_sm_state :=
  let x := s + m in (x,x).

Definition F := 1.
Definition C := 0.

Global Instance MinBFT_I_context : MinBFT_context :=
  Build_MinBFT_context
    minbft_digest
    minbft_digest_def
    minbft_digest_deq
    minbft_sending_key
    minbft_receiving_key
    F
    (replica F)
    (replica_deq F)
    (reps2nat F)
    (bijective_reps2nat F)
    (nclients C)
    (client C)
    (client_deq C)
    (clients2nat C)
    (bijective_clients2nat C)
    minbft_data_message
    minbft_data_message_deq
    minbft_result
    minbft_result_deq
    minbft_sm_state
    minbft_sm_initial_state
    (minbft_sm_update C).

(* =========================== *)
(* ====== GENERIC STUFF ====== *)
Module Type SM.
  Parameter level : nat.
  Parameter name  : CompName.
  Parameter sm    : n_proc level name.
End SM.

Module Type SMat.
  Parameter level : nat.
  Parameter name  : CompName.
  Parameter sm    : n_proc_at level name.
End SMat.

Module Msm (sm : SM).
  Definition state : ref (sf sm.name) := ref_cons (sm2state sm.sm).

  Definition update (i : cio_I (fio sm.name)) : unit * cio_O (fio sm.name) :=
    let (sop,o) := M_break_nil (sm2update sm.sm (get_ref state) i) in
    let u := match sop with | Some s => update_ref state s| None => tt end in
    (u,o).

  Fixpoint run (l : list (cio_I (fio sm.name))) : list (cio_O (fio sm.name)) :=
    match l with
    | [] => []
    | i :: rest => snd (update i) :: run rest
    end.

  Definition upd_lkup := update_lookup sm.level sm.name update.
End Msm.

Module Msmat (sm : SMat).
  Definition state : ref (sf sm.name) := ref_cons (ComponentSM.sm_state sm.sm).

  Definition update (i : cio_I (fio sm.name)) : unit * cio_O (fio sm.name) :=
    let (sop,o) := M_break_nil (sm_update sm.sm (get_ref state) i) in
    let u := match sop with | Some s => update_ref state s | None => tt end in
    (u,o).

  Fixpoint run (l : list (cio_I (fio sm.name))) : list (cio_O (fio sm.name)) :=
    match l with
    | [] => []
    | i :: rest => snd (update i) :: run rest
    end.

  Definition upd_lkup := update_lookup sm.level sm.name update.
End Msmat.
(* =========================== *)

(* ================== SIGNATURE ================== *)

Definition minbft_create_signature
           (m  : MinBFT_Bare_Msg)
           (ks : sending_keys) : list MinBFT_digest := [minbft_digest_def].

Definition minbft_verify_signature
           (m : MinBFT_Bare_Msg)
           (n : name)
           (k : receiving_key)
           (a : MinBFT_digest) : bool := true.

Global Instance MinBFT_I_auth : MinBFT_auth :=
  MkMinBFT_auth minbft_create_signature minbft_verify_signature.

(*Definition minbft_lookup_replica_sending_key   (src : Rep)    : minbft_sending_key   := minbft_sending_key_stub.
Definition minbft_lookup_replica_receiving_key (dst : Rep)    : minbft_receiving_key := minbft_receiving_key_stub.*)
Definition minbft_lookup_client_sending_key    (c   : Client) : minbft_sending_key   := minbft_sending_key_stub.
Definition minbft_lookup_client_receiving_key  (c   : Client) : minbft_receiving_key := minbft_receiving_key_stub.

Definition initial_minbft_local_key_map_replicas (src : name) : local_key_map :=
  match src with
  | MinBFT_replica i =>
    MkLocalKeyMap
      (map (fun c => MkDSKey [MinBFT_client c] (minbft_lookup_client_sending_key c)) clients)
      (map (fun c => MkDRKey [MinBFT_client c] (minbft_lookup_client_receiving_key c)) clients)
  | MinBFT_client _ => MkLocalKeyMap [] []
  end.

Global Instance MinBFT_I_keys : MinBFT_initial_keys :=
  MkMinBFT_initial_keys initial_minbft_local_key_map_replicas.

(* ================== USIG HASH ================== *)

Definition usig_lookup_replica_sending_key   (i : Rep) (src : Rep) : minbft_sending_key   := minbft_sending_key_stub.
Definition usig_lookup_replica_receiving_key (i : Rep) (dst : Rep) : minbft_receiving_key := minbft_receiving_key_stub.

Definition initial_usig_local_key_map_replicas (src : name) : local_key_map :=
  match src with
  | MinBFT_replica i =>
    MkLocalKeyMap
      (map (fun r => MkDSKey [MinBFT_replica r] (usig_lookup_replica_sending_key   i r)) reps)
      (map (fun r => MkDRKey [MinBFT_replica r] (usig_lookup_replica_receiving_key i r)) reps)
  | MinBFT_client _ => MkLocalKeyMap [] []
  end.

Global Instance USIG_I_keys : USIG_initial_keys :=
  MkUSIG_initial_keys initial_usig_local_key_map_replicas.

Definition minbft_create_hash_usig_stub (hd : HashData) (k : minbft_sending_key) : MinBFT_digest := minbft_digest_def.
Definition minbft_verify_hash_usig_stub (hd : HashData) (r : Rep) (k : minbft_receiving_key) (d : MinBFT_digest) : bool := true.

Definition rep0 : Rep := nat2rep 0.

Definition minbft_create_hash_usig0
           (hd : HashData)
           (lk : local_key_map) : MinBFT_digest := minbft_digest_def.

Definition minbft_create_hash_usig1
           (hd : HashData)
           (lk : local_key_map) : MinBFT_digest :=
  let rep := pre_ui_rid (hd_pre hd) in
  (* 1st [rep0] should be [rep] and 2nd should be recipient *)
  let key := usig_lookup_replica_sending_key rep0 rep0 in
  minbft_create_hash_usig_stub hd key.

Definition minbft_create_hash_usig
           (hd : HashData)
           (lk : local_key_map) : MinBFT_digest :=
  match lookup_dskeys lk rep0 with
  | MkDSKey _ key :: _ => minbft_create_hash_usig_stub hd key
  | _ => minbft_digest_def
  end.

Definition minbft_verify_hash_usig0
           (hd : HashData)
           (d  : MinBFT_digest)
           (lk : local_key_map) : bool := true.

Definition minbft_verify_hash_usig1
           (hd : HashData)
           (d  : MinBFT_digest)
           (lk : local_key_map) : bool :=
  let rep := pre_ui_rid (hd_pre hd) in
  (* 1st [rep0] should be the replica doing the call and 2nd should be [rep] *)
  let key := usig_lookup_replica_receiving_key rep0 rep0 in
  (* [rep0] here because we don't have access to the replica name doing the call---it's not used anyway *)
  minbft_verify_hash_usig_stub hd rep0 key d.

Definition minbft_verify_hash_usig
           (hd : HashData)
           (d  : MinBFT_digest)
           (lk : local_key_map) : bool :=
  match lookup_drkeys lk rep0 with
  | MkDRKey _ key :: _ => minbft_verify_hash_usig_stub hd rep0 key d
  | _ => true
  end.

Lemma minbft_verify_create_hash_usig :
  forall (hd : HashData) (keys : local_key_map),
    minbft_verify_hash_usig hd (minbft_create_hash_usig hd keys) keys = true.
Proof.
  introv.
  unfold minbft_verify_hash_usig, minbft_create_hash_usig.
  remember (lookup_drkeys keys (MinBFT_replica rep0)) as w; destruct w; auto;
    try (complete (destruct d;destruct w; auto)).
Qed.

Global Instance MinBFT_I_usig_hash : USIG_hash :=
  MkMinBFThash
    minbft_create_hash_usig
    minbft_verify_hash_usig
    minbft_verify_create_hash_usig.

(* ================== TIME ================== *)

Definition time_I_type : Set := unit.

Definition time_I_get_time : unit -> time_I_type := fun _ => tt.

Definition time_I_sub : time_I_type -> time_I_type -> time_I_type := fun _ _ => tt.

Definition time_I_2string : time_I_type -> string := fun _ => "".

Global Instance TIME_I : Time.
Proof.
  exists time_I_type.
  { exact time_I_get_time. }
  { exact time_I_sub. }
  { exact time_I_2string. }
Defined.

(* ================== PRETTY PRINTING ================== *)

Definition print_endline : string -> unit := fun _ => tt.
Definition nat2string (n : nat) : string := "-".

Definition CR : string := String (ascii_of_nat 13) "".

(* Fix: to finish *)
Definition tokens2string (toks : Tokens) : string := "-".

Definition minbft_digest2string (d : minbft_digest) : string := d.

Definition minbft_result2string (r : minbft_result) : string := nat2string r.

Definition nat_n2string {m} (n : nat_n m) : string := nat2string (proj1_sig n).

Definition replica2string (r : replica F) : string := nat_n2string r.
Definition client2string (c : client C) : string := nat_n2string c.

Definition timestamp2string (ts : Timestamp) : string :=
  match ts with
  | time_stamp n => nat2string n
  end.

Definition view2string (v : View) : string :=
  match v with
  | view n => nat2string n
  end.

Definition seq2string (s : SeqNum) : string :=
  match s with
  | seq_num n => nat2string n
  end.

Fixpoint str_concat (l : list String.string) : String.string :=
  match l with
  | [] => ""
  | s :: ss => String.append s (str_concat ss)
  end.

(* original
Definition minbft_data_message2string (opr : minbft_data_message) : string :=
  match opr with
  | minbft_data_message_plus  n => str_concat ["+", nat2string n]
  | minbft_data_message_minus n => str_concat ["-", nat2string n]
  end.
*)

Definition minbft_data_message2string (opr : minbft_data_message) : string := nat2string opr.

Definition bare_request2string (br : Bare_Request) : string :=
  match br with
  | bare_request c ts m =>
    str_concat [client2string c,
                ",",
                timestamp2string ts,
                ",",
                minbft_data_message2string m]
  end.

Definition request2string (r : Request) : string :=
  match r with
  | request br a => str_concat ["REQUEST(", bare_request2string br, ",", tokens2string a, ")"]
  end.

Definition bare_prepare2string (bp : Bare_Prepare) : string :=
  match bp with
  | bare_prepare v m =>
    str_concat [view2string v,
                ",",
                request2string m]
  end.

Definition pre_ui2string (pui : preUI) : string :=
  match pui with
  | Build_preUI rid cid counter =>
    str_concat [replica2string rid,
                ",",
                nat2string cid,
                ",",
                nat2string counter]
  end.

Definition ui2string (ui : UI) : string :=
  match ui with
  | Build_UI pui d => str_concat ["UI(", pre_ui2string pui, ",", minbft_digest2string d, ")"]
  end.

Definition HashData2string (hd : HashData) : string :=
  match hd with
  | Build_HashData v r pui => str_concat ["HASH-DATA(" , view2string v , "," , request2string r, "," , pre_ui2string pui , ")"]
  end.

Definition bare_commit2string (bc : Bare_Commit) : string :=
  match bc with
  | bare_commit v m ui =>
    str_concat [view2string v,
                ",",
                request2string m,
                ",",
                ui2string ui]
  end.

Definition prepare2string (p : Prepare) : string :=
  match p with
  | prepare bp a => str_concat ["PREPARE(", bare_prepare2string bp, ",", ui2string a, ")"]
  end.

Definition commit2string (c : Commit) : string :=
  match c with
  | commit bc a => str_concat ["COMMIT(", bare_commit2string bc, ",", ui2string a, ")"]
  end.

Definition accept2string (r : Accept) : string :=
  match r with
  | accept r c => str_concat ["ACCEPT(", request2string r, ",", nat2string c, ")"]
  end.

Definition bare_reply2string (br : Bare_Reply) : string :=
  match br with
  | bare_reply req res i v => str_concat [request2string req, ",", nat2string res, ",", replica2string i]
  end.

Definition reply2string (r : Reply) : string :=
  match r with
  | reply br a => str_concat ["REPLY(", bare_reply2string br, ",", tokens2string a, ")"]
  end.

Definition msg2string (m : MinBFT_msg) : string :=
  match m with
  | MinBFT_request r => request2string r
  | MinBFT_reply r   => reply2string r
  | MinBFT_prepare p => prepare2string p
  | MinBFT_commit  c => commit2string  c
  | MinBFT_accept  a => accept2string  a
  | MinBFT_debug   s => s
  end.

Definition bare_msg2string (m : MinBFT_Bare_Msg) : string :=
  match m with
  | MinBFT_msg_bare_request r => str_concat ["BARE-REQUEST(" , bare_request2string r , ")"]
  | MinBFT_msg_bare_reply   r => str_concat ["BARE-REPLY("   , bare_reply2string   r , ")"]
  | MinBFT_msg_bare_prepare p pui => str_concat ["BARE-PREPARE(" , bare_prepare2string p , "," , pre_ui2string pui , ")"]
  | MinBFT_msg_bare_commit  c pui => str_concat ["BARE-PREPARE(" , bare_commit2string  c , "," , pre_ui2string pui , ")"]
  end.

Definition name2string (n : name) : string :=
  match n with
  | MinBFT_replica r => replica2string r
  | MinBFT_client c => client2string c
  end.

Fixpoint names2string (l : list name) : string :=
  match l with
  | [] => ""
  | [n] => name2string n
  | n :: ns => str_concat [name2string n, ",", names2string ns]
  end.

Definition delay2string (delay : nat) : string := nat2string delay.

Definition z2string (z : Z) : string := "".
Definition pos2string (p : positive) : string := "".

Definition q2string (q : Q) : string :=
  str_concat ["(" ,
              z2string (Qnum q),
              "/",
              pos2string (Qden q),
              ")"].

Definition posdtime2string (p : PosDTime) : string :=
  q2string (pos_dt_t p).

Definition DirectedMsg2string (dm : DirectedMsg) : string :=
  match dm with
  | MkDMsg msg dst delay =>
    str_concat [msg2string msg, ":", "[", names2string dst, "]", ":", posdtime2string delay]
  end.

Fixpoint DirectedMsgs2string (l : DirectedMsgs) : string :=
  match l with
  | [] => ""
  | [dm] => DirectedMsg2string dm
  | dm :: dmsgs => str_concat [DirectedMsg2string dm, CR, DirectedMsgs2string dmsgs]
  end.

Definition TimedDirectedMsg2string (m : TimedDirectedMsg) : string :=
  match m with
  | MkTimedDMsg dm time => str_concat [DirectedMsg2string dm, ":", time_I_2string time]
  end.

Fixpoint TimedDirectedMsgs2string (l : TimedDirectedMsgs) : string :=
  match l with
  | [] => ""
  | [dm] => TimedDirectedMsg2string dm
  | dm :: dmsgs => str_concat [TimedDirectedMsg2string dm, CR, TimedDirectedMsgs2string dmsgs]
  end.

Definition SimState2string (s : SimState) : string :=
  match s with
  | MkSimState fls sys step out_inflight in_inflight delivered =>
    str_concat
      [CR,
       "====== STEP ======",
       CR,
       nat2string step,
       CR,
       "====== IN FLIGHT (from outside the system) ======",
       CR,
       DirectedMsgs2string out_inflight,
       CR,
       "====== IN FLIGHT (from inside the system) ======",
       CR,
       DirectedMsgs2string in_inflight,
       CR,
       "====== DELIVERED ======",
       CR,
       TimedDirectedMsgs2string delivered,
       CR]
  end.

(* ================== EXTRACTION ================== *)

Extraction Language OCaml.

(* printing stuff *)
Extract Inlined Constant print_endline => "Prelude.print_coq_endline".
Extract Inlined Constant nat2string    => "Prelude.char_list_of_int".
Extract Inlined Constant CR            => "['\n']".

(* numbers *)
Extract Inlined Constant Nat.modulo    => "(mod)".

(* lists *)
Extract Inlined Constant forallb => "List.for_all".
Extract Inlined Constant existsb => "List.exists".
Extract Inlined Constant length  => "List.length".
Extract Inlined Constant app     => "List.append".
Extract Inlined Constant map     => "List.map".
Extract Inlined Constant filter  => "List.filter".

(* timing stuff *)
Extract Inlined Constant time_I_type     => "float".
Extract Inlined Constant time_I_get_time => "Prelude.Time.get_time".
Extract Inlined Constant time_I_sub      => "Prelude.Time.sub_time".
Extract Inlined Constant time_I_2string  => "Prelude.Time.time2string".

(* == crypto stuff == *)
Extract Inlined Constant minbft_digest => "string".
Extract Inlined Constant minbft_digest_deq => "(=)".
Extract Inlined Constant minbft_digest_def => "(String.make 1 'x')".
Extract Inlined Constant minbft_digest2string => "Prelude.to_list".

(* === COMMENT OUT THIS PART IF YOU DON'T WANT TO USE KEYS ===*)
Extract Inlined Constant minbft_sending_key   => "Nocrypto.Rsa.priv".
Extract Inlined Constant minbft_receiving_key => "Nocrypto.Rsa.pub".
(*Extract Inlined Constant minbft_lookup_replica_sending_key   => "RsaKeyFun.lookup_replica_sending_key".
Extract Inlined Constant minbft_lookup_replica_receiving_key => "RsaKeyFun.lookup_replica_receiving_key".*)
Extract Inlined Constant minbft_lookup_client_receiving_key  => "RsaKeyFun.lookup_client_receiving_key".
Extract Inlined Constant minbft_lookup_client_sending_key    => "RsaKeyFun.lookup_client_sending_key".

Extract Inlined Constant minbft_create_signature => "RsaKeyFun.sign_list".
Extract Inlined Constant minbft_verify_signature => "RsaKeyFun.verify_one".

Extract Inlined Constant usig_lookup_replica_sending_key   => "MacKeyFun.lookup_replica_key".
Extract Inlined Constant usig_lookup_replica_receiving_key => "MacKeyFun.lookup_replica_key".

(*Extract Inlined Constant minbft_create_hash_usig => "Obj.magic (Hash.create_hash_object)".
Extract Inlined Constant minbft_verify_hash_usig => "Obj.magic (Hash.verify_hash_object)".*)
Extract Inlined Constant minbft_create_hash_usig_stub => "Obj.magic (MacKeyFun.sign_one)".
Extract Inlined Constant minbft_verify_hash_usig_stub => "Obj.magic (MacKeyFun.verify_one)".
(* === --- === *)

Require Export ExtrOcamlBasic.
Require Export ExtrOcamlNatInt.
Require Export ExtrOcamlString.

Definition local_system:=
  @MinBFTlocalSys.

(* ================== MODULES ================== *)

Parameter self : Rep.

(* ====== USIG ====== *)

Module SMUSIG <: SM.
  Definition level := 1.
  Definition name  := USIGname.
  Definition sm    := USIG_comp self.
End SMUSIG.

Module MUSIG := Msm (SMUSIG).

(* ====== LOG ====== *)

Module SMLOG <: SM.
  Definition level := 1.
  Definition name  := LOGname.
  Definition sm    := LOG_comp.
End SMLOG.

Module MLOG := Msm (SMLOG).

(* ====== Main ====== *)

Module SMMAIN <: SM.
  Definition level := 2.
  Definition name  := MAINname.
  Definition sm    := MAIN_comp self.
End SMMAIN.

Module MMAIN := Msm (SMMAIN).

Definition mk_request
           (c   : Client)
           (ts  : Timestamp)
           (m   : MinBFT_data_message)
           (tok : Tokens) : Request :=
  request (bare_request c ts m) tok.

Definition mk_minbft_request
           (c   : Client)
           (ts  : Timestamp)
           (m   : MinBFT_data_message)
           (tok : Tokens) : msg :=
  MinBFT_request (mk_request c ts m tok).

(* original
Definition mtest : unit :=
  let c   := client0 C in
  let ts  := time_stamp 0 in
  let m   := minbft_data_message_plus 17 in
  let tok := [minbft_digest_def] in
  print_endline (DirectedMsgs2string (snd (MMAIN.update (mk_minbft_request c ts m tok)))).
*)

Definition mtest : unit :=
  let c   := client0 C in
  let ts  := time_stamp 0 in
  let m   := 17 in
  let tok := [minbft_digest_def] in
  print_endline (DirectedMsgs2string (snd (MMAIN.update (mk_minbft_request c ts m tok)))).

Definition mk_ui r c d : UI := Build_UI (Build_preUI r cid0 c) d.

Definition mk_create_ui_out r c d : USIG_output_interface :=
  create_ui_out (Some (mk_ui r c d)).

Definition mk_verify_ui_out b : USIG_output_interface :=
  verify_ui_out b.

Definition mk_create_ui_in view client timestamp op toks : USIG_input_interface :=
  create_ui_in (view, mk_request client timestamp op toks, cid0, cid0).

Definition mk_verify_ui_in view client timestamp op toks rep digest count :=
  verify_ui_in (view, mk_request client timestamp op toks, mk_ui rep digest count).

Definition execute_request (i : USIG_input_interface) : USIG_output_interface :=
  snd (MUSIG.update i).

Parameter register : forall {A: Type}, String.string -> A -> unit.

Definition u1 : unit := register "execute_request" execute_request.
Definition u2 : unit := register "mk_create_ui_in" mk_create_ui_in.
Definition u3 : unit := register "mk_verify_ui_in" mk_verify_ui_in.
Definition u4 : unit := register "mk_create_ui_out" mk_create_ui_out.
Definition u5 : unit := register "mk_verify_ui_out" mk_verify_ui_out.

(* =========================== *)
(* =========================== *)

Extract Inductive ref => "ref" ["ref"].
Extract Inlined Constant get_ref => "!".
Extract Inlined Constant update_ref => "(:=)".

Extract Inlined Constant register => "(fun l -> Callback.register (Prelude.of_list l))".

Extract Inductive sigT => "(*)" [""].

Extract Inductive Proc => "Prelude.SM.id" ["Prelude.SM.ret"
                                             "Prelude.SM.bind"
                                             "Prelude.SM.call_proc (lookup_table __)"].

Extract Constant self => "Obj.magic 0".

Extract Constant n_proc => "unit mP_StateMachine".
Extract Constant M_n "'a" => "'a".
Extract Constant M_p "'a" "'b" => "'b".
Extract Constant UProc "'s" => "'s -> cio_I -> ('s * cio_O) m_n".

Extract Constant bind => "fun _ _ _ _ _ _ _ _ _ m f -> Prelude.SM.bind (m,f)".
Extract Constant ret => "fun _ _ _ _ _ _ _ _ _ a -> Prelude.SM.ret a".
Extract Constant M_on_pred => "fun _ _ _ _ _ _ _ _ _ x -> x".
Extract Constant M_simple_break => "fun _ _ _ _ _ _ _ _ _ sm subs f -> f sm".
Extract Constant M_break_nil => "fun _ _ _ _ _ _ _ _ _ sm -> sm".

Extraction Inline interp_s_proc.
Extraction Inline proc_bind_pair.
Extraction Inline to_proc_some_state.

Extract Inlined Constant interp_proc => "(fun _ _ _ _ _ _ _ _ _ x -> x)".

Extract Inlined Constant M_StateMachine => "n_proc".
Extract Inlined Constant n_proc_at => "n_proc".
Extract Inlined Constant n_procs => "((unit mP_StateMachine) p_nproc) list".

(* =========================== *)
(* =========================== *)

(* ***
   Add this only if you want to GC the log for a fair evaluation
   It *shouldn't* be ON by default!
   *** *)
(*Extract Inlined Constant log_new_prepare => "log_new_prepare_gc2".*)

(* =========================== *)
(* =========================== *)

(* ***
   To remove debug messages
   *** *)
Extract Inlined Constant send_debugs => "(fun _ _ _ _ -> [])".

(* =========================== *)
(* =========================== *)

(* TODO: Why can't we get rid of the last argument? *)
Extraction Implicit lookup_table [1 2 3 4 5].