(** Fault Handler Generation code and correctness proofs. *)

Require Import ZArith.
Require Import Lia.
Require Import List.
Require Import Utils.
Import ListNotations.
Require Coq.Vectors.Vector.

Require Import LibTactics.
Require Import Instr.
Require Import Lattices.
Require Import Concrete.
Require Import ConcreteMachine.
Require Import Rules.
Require Import CLattices.
Require Import CodeTriples.
Require Import CodeSpecs.
Require Import CodeGen.
Require Import CLattices.
Require Import ConcreteExecutions.
Require Import Encodable.
Require Import CLabels.
Require Import QuasiAbstractMachine.

(** * Definition of the fault handler generator *)

(** The following definition, and specification are generic in the abstract notion of label, and in the encoding thereof.
    We instanciate with IFC label and their concrete encoding at the end of the file *)
Section FaultHandler.

Context {T : Type}
        {ET : Encodable T}
        {labelCount : OpCode -> nat}
        {run_tmr : run_tmr_type labelCount T}
        {CT : ConcreteLabels T ET labelCount run_tmr}.

Definition opcodes :=
  [OpNoop; OpAdd; OpSub; OpPush; OpPop;
   OpLoad; OpStore; OpJump; OpBranchNZ;
   OpCall; OpRet; OpVRet; OpOutput].

(** Check if top of stack is an encoding of opcode [op] *)
Definition genCheckOp (op:OpCode): code :=
  genTestEqual (push (opCodeToZ op)) (loadFrom addrOpLabel).

(** Put rule application results on stack. *)
Definition genComputeResults: code :=
  indexed_cases nop genCheckOp genRule opcodes.

(** Write fault handler results to memory. *)
Definition genStoreResults: code :=
  ifNZ (storeAt addrTagRes ++
        storeAt addrTagResPC ++
        genTrue)
       genFalse.

Definition genError :=
  push (-1) ++ [Jump].

(** The entire handler *)
Definition faultHandler: code :=
  genComputeResults ++
  genStoreResults ++
  ifNZ [Ret] genError.

(** * Fault-handler Code Specifications.  *)
Section TMUSpecs.

(** Connecting to the definition used in [Concrete.v] *)
Lemma init_enough: forall {n} (vls:Vector.t T n) m opcode pcl,
    cache_hit m (opCodeToZ opcode) (labsToZs vls) (labToZ pcl) ->
    handler_initial_mem_matches
      (opCodeToZ opcode)
      (labsToZs vls)
      (labToZ pcl)
      m.
Proof.
  intros. unfold labsToZs in H.
  inv H. inv UNPACK. inv OP. inv TAG1. inv TAG2. inv TAG3. inv TAGPC.
  econstructor; eauto.
Qed.

Variable opcode: OpCode.

Variable vls: Vector.t T (labelCount opcode).
Variable pcl: T.
Variable m0: memory.
Hypothesis initial_mem_matches: handler_initial_mem_matches
                                  (opCodeToZ opcode)
                                  (labsToZs vls)
                                  (labToZ pcl) m0.

(** Spec of the code generated for a given opcode's rule *)
Lemma genRule_spec_GT :
  forall ar,
    run_tmr opcode pcl vls = ar ->
    GT (genRule opcode)
       (fun m s => m = m0)
       (fun m0' s0 m s => m = m0 /\
                          s = listify_apply_rule ar s0).
Proof.
  unfold GT; intros.
  eapply HT_strengthen_premise; eauto.
  - eapply genRuleCorrect; eauto.
  - intros m s (H1 & H2 & H3). subst. eauto.
Qed.

(** Spec of the code for comparison against a given opcode *)
Lemma genCheckOp_spec:
  forall opcode', forall s0,
    HT (genCheckOp opcode')
      (fun m s => m = m0 /\
                  s = s0)
      (fun m s => m = m0 /\
                  s = (boolToZ (opCodeToZ opcode' =? opCodeToZ opcode)
                      ,handlerTag) ::: s0).
Proof.
  unfold handler_initial_mem_matches in *;
  intuition;
  jauto_set_hyps; intros.
  unfold genCheckOp.
  eapply genTestEqual_spec.
  intros. eapply HT_strengthen_premise.
  eapply push_spec.
  split_vc. subst; eauto.
  intros. eapply HT_strengthen_premise. eapply loadFrom_spec.
  split_vc. subst; eauto.
  destruct (labsToZs vls) as [[tag1 tag2] tag3].
  intuition eauto.
Qed.

Lemma genCheckOp_spec_GT:
  forall opcode',
    GT (genCheckOp opcode')
       (fun m s => m = m0)
       (fun m0' s0 m s => m = m0 /\
                          s = (boolToZ (opCodeToZ opcode' =? opCodeToZ opcode)
                               ,handlerTag) ::: s0).
Proof.
  unfold GT; intros.
  eapply HT_consequence; eauto.
  - eapply genCheckOp_spec; eauto.
  - simpl; intuition (subst; eauto).
  - simpl; intuition (subst; eauto).
Qed.

Section FaultHandlerSpec.

Variable ar: option (T * T).
Hypothesis H_apply_rule: run_tmr opcode pcl vls = ar.

(* Don't really need to specify [Qnil] since it will never run *)
Definition Qnil: GProp := fun m0' s0 m s => True.
Definition genV: OpCode -> HFun :=
  fun i _ _ => boolToZ (opCodeToZ i =? opCodeToZ opcode).
Definition genC: OpCode -> code := genCheckOp.

Definition genQ: OpCode -> GProp :=
         (fun i m0' s0 m s => m = m0 /\
                              s = listify_apply_rule ar s0).

Lemma genCheckOp_spec_GT_push_v:
  forall opcode',
    GT_push_v (genC opcode')
              (fun m s => m = m0)
              (genV opcode').
Proof.
  intros; eapply GT_consequence'.
  eapply genCheckOp_spec_GT.
  eauto.
  intuition (subst; intuition).
Qed.

Lemma opCodeToZ_inj: forall opcode opcode',
  (boolToZ (opCodeToZ opcode' =? opCodeToZ opcode) <> 0) ->
  opcode' = opcode.
Proof.
  intros o o'.
  destruct o; destruct o'; simpl; solve [ auto | intros; false; lia ].
Qed.

Lemma genRule_spec_GT_guard_v :
  forall opcode',
    GT_guard_v (genRule opcode')
               (fun m s => m = m0)
               (genV opcode')
               (genQ opcode').
Proof.
  intros.
  cases (dec_eq_OpCode opcode' opcode) as Eq; clear Eq.
  - eapply GT_consequence'.
    + subst opcode'.
      eapply genRule_spec_GT. eauto.
    + iauto.
    + iauto.
  - unfold GT_guard_v, GT, HT.
    intros.
    unfold genV in *.
    pose (opCodeToZ_inj opcode opcode').
    false; intuition.
Qed.

Lemma H_indexed_hyps: indexed_hyps _ genC genRule genQ genV (fun m s => m = m0) opcodes.
Proof.
  simpl.
  intuition; try (solve
    [ eapply genCheckOp_spec_GT_push_v
    | eapply genRule_spec_GT_guard_v ]).
Qed.

(** Spec for the top level switch case on the opcode *)
Lemma genComputeResults_spec_GT:
  GT genComputeResults
     (fun m s => m = m0)
     (fun m0' s0 m s => m = m0 /\
                        s = listify_apply_rule ar s0).
Proof.
  intros.
  eapply GT_consequence'.
  unfold genComputeResults.
  eapply indexed_cases_spec with (Qnil:=Qnil).
  - (* default case that we never reach *)
    unfold GT; intros.
    eapply HT_strengthen_premise.
    eapply nop_spec.
    unfold Qnil; iauto.
  - exact H_indexed_hyps.
  - iauto.
  - (* untangle post condition *)
    simpl.
    assert (0 = 0) by reflexivity.
    assert (1 <> 0) by lia.
    (* NC: Otherwise [cases] fails.  Thankfully, [cases] tells us this
    is the problematic lemma, whereas [destruct] just spits out a huge
    term and says it's ill typed *)
    clear H_apply_rule.
    unfold genV, genQ.
    cases opcode; simpl; intuition.
Qed.

(** Under our assumptions, [genComputeResults] just runs the appropriate
   [genApplyRule] *)
Lemma genComputeResults_spec:
    forall s0,
      HT   genComputeResults
           (fun m s => m = m0 /\
                       s = s0)
           (fun m s => m = m0 /\
                       s = listify_apply_rule ar s0).
Proof.
  intros.
  eapply HT_consequence'.
  eapply genComputeResults_spec_GT.
  iauto.
  simpl; iauto.
Qed.

(** Spec for storing the result of a rule application *)
Lemma genStoreResults_spec_Some: forall lr lrpc,
  valid_address addrTagRes m0 ->
  valid_address addrTagResPC m0 ->
  ar = Some (lrpc, lr) ->
  forall s0,
    HT genStoreResults
       (fun m s => m = m0 /\
                   s = listify_apply_rule ar s0)
       (fun m s =>
        (exists m', upd_m addrTagRes (labToZ lr,handlerTag) m0
                    = Some m'
                 /\ upd_m addrTagResPC (labToZ lrpc,handlerTag) m'
                    = Some m)
        /\ s = (1,handlerTag) ::: s0).
Proof.
  introv HvalidRes HvalidResPC Har_eq; intros.
  unfold listify_apply_rule.
  rewrite Har_eq.
  unfold genStoreResults.

  (* Need to exploit early so that existentials can be unified against
  vars introduced here *)
  eapply valid_store in HvalidRes.
  destruct HvalidRes as [m' ?].
  eapply valid_address_upd in HvalidResPC.
  eapply valid_store in HvalidResPC.
  destruct HvalidResPC as [m'' ?]; eauto.

  eapply HT_strengthen_premise.
  eapply ifNZ_spec_NZ with (v:=1).
  eapply HT_compose_bwd.
  eapply HT_compose_bwd.
  eapply genTrue_spec.
  eapply storeAt_spec.
  eapply storeAt_spec.

  lia.
  simpl; intuition; subst; jauto.
  eauto.
Qed.

Lemma genStoreResults_spec_None:
  ar = None ->
  forall s0,
    HT genStoreResults
       (fun m s => m = m0 /\
                   s = listify_apply_rule ar s0)
       (fun m s => m = m0 /\
                   s = (0,handlerTag) ::: s0).
Proof.
  introv Har_eq; intros.
  unfold listify_apply_rule.
  rewrite Har_eq.
  unfold genStoreResults.

  eapply HT_strengthen_premise.
  eapply ifNZ_spec_Z with (v:=0).
  eapply genFalse_spec.

  reflexivity.
  jauto.
Qed.

(** The irrelevant memory never changes *)
Lemma genStoreResults_update_cache_spec_rvec:
  valid_address addrTagRes m0 ->
  valid_address addrTagResPC m0 ->
  forall s0,
    HT genStoreResults
       (fun m s => m = m0 /\
                   s = listify_apply_rule ar s0)
       (fun m s => update_cache_spec_rvec m0 m).
Proof.
  intros.
  unfold update_cache_spec_rvec in *.

  cases ar as Eq_ar.
  destruct p.

  + eapply HT_weaken_conclusion;
    rewrite <- Eq_ar in *.

    eapply genStoreResults_spec_Some; eauto.

    simpl.
    intros;

    jauto_set_hyps; intros.
    eapply transitivity.
    eapply update_list_Z_spec2; eauto.
    eapply update_list_Z_spec2; eauto.

  + eapply HT_weaken_conclusion;
    rewrite <- Eq_ar in *.

    eapply genStoreResults_spec_None; eauto.

    simpl; intuition; subst; auto.
Qed.

Definition handler_final_mem_matches (lrpc: T) (lr: T) (m: memory) (m': memory) :Prop :=
     cache_hit_read m' (labToZ lr) (labToZ lrpc)
  /\ update_cache_spec_rvec m m'.   (* Nothing else changed *)

Lemma genStoreResults_spec_Some': forall lr lpc,
  valid_address addrTagRes m0 ->
  valid_address addrTagResPC m0 ->
  ar = Some (lpc, lr) ->
  forall s0,
    HT genStoreResults
       (fun m s => m = m0 /\
                   s = listify_apply_rule ar s0)
       (fun m s => handler_final_mem_matches lpc lr m0 m
                   /\ s = (1,handlerTag) ::: s0).
Proof.
  introv HvalidRes HvalidResPC Har_eq; intros.
  generalize (valid_store _ (labToZ lr,  handlerTag) _ HvalidRes).
  intros [m' Hm'].
  generalize (valid_address_upd _ _ _ _ _ HvalidResPC Hm').
  clear HvalidRes HvalidResPC.
  intros HvalidResPC.
  generalize (valid_store _ (labToZ lpc,  handlerTag) _ HvalidResPC).
  intros [m'' Hm''].
  unfold genStoreResults.
  eapply HT_strengthen_premise.
  eapply ifNZ_spec_NZ with (v := 1); try lia.
  eapply HT_compose_bwd.
  eapply HT_compose_bwd.
  eapply genTrue_spec.
  simpl.
  eapply storeAt_spec.
  eapply storeAt_spec.
  rewrite Har_eq. simpl.
  intros m s [Hm Hs]. subst.
  eexists.
  generalize (update_list_Z_spec _ _ _ Hm''). intros H1.
  generalize (update_list_Z_spec _ _ _ Hm'). intros H2.
  erewrite update_list_Z_spec2 in H2; eauto; try solve [compute; lia].
  repeat (split; eauto); try econstructor; eauto.
  clear - Hm' Hm''.
  intros addr H1 H2.
  transitivity (read_m addr m'); eapply update_list_Z_spec2; eauto.
Qed.

(** Spec of the code handling a disallowed instruction *)
Lemma genError_specEscape: forall raddr (P: memory -> stack -> Prop),
  HTEscape raddr genError
           P
           (fun m s => (P m s , Failure)).
Proof.
  intros.
  unfold genError.
  eapply HTEscape_compose.
  2: eapply jump_specEscape_Failure.
  eapply HT_strengthen_premise.
  eapply push_spec.
  split_vc.
Qed.

(** Spec of the fault-handler return  *)
Definition genFaultHandlerReturn: code := ifNZ [Ret] genError.

Lemma genFaultHandlerReturn_specEscape_Some: forall raddr lr lpc,
  forall s0,
  HTEscape raddr genFaultHandlerReturn
       (fun (m : memory) (s : stack) =>
        handler_final_mem_matches lr lpc m0 m /\
        s = (1, handlerTag) ::: CRet raddr false false :: s0)
       (fun (m : memory) (s : stack) =>
        (s = s0 /\ handler_final_mem_matches lr lpc m0 m, Success)).
Proof.
  intros.
  unfold genFaultHandlerReturn.
  eapply HTEscape_strengthen_premise.
  - eapply ifNZ_specEscape with (v:=1) (Pf:=fun m s => True); intros.
    eapply ret_specEscape.
    auto.
    false.
  - subst.
    intuition.
    jauto_set_goal; eauto.
Qed.

Lemma genFaultHandlerReturn_specEscape_None: forall raddr s0,
 HTEscape raddr genFaultHandlerReturn
   (fun (m : memory) (s : stack) => m = m0 /\ s = (0, handlerTag) ::: s0)
   (fun (m : memory) (s : stack) => (m = m0 /\ s = s0, Failure)).
Proof.
  intros.
  unfold genFaultHandlerReturn.
  eapply HTEscape_strengthen_premise.
  - eapply ifNZ_specEscape with (v := 0) (Pt := fun m s => True); intros.
    + intuition.
    + eapply genError_specEscape.
  - intros.
    subst.
    intuition.
    jauto_set_goal; eauto.
Qed.

Lemma faultHandler_specEscape_Some: forall raddr lr lpc,
  valid_address addrTagRes m0 ->
  valid_address addrTagResPC m0 ->
  ar = Some (lpc, lr) ->
  forall s0,
    HTEscape raddr faultHandler
             (fun m s => m = m0 /\
                         s = (CRet raddr false false::s0))
             (fun m s => ( s = s0 /\
                           handler_final_mem_matches lpc lr m0 m
                         , Success )).
Proof.
  intros.
  unfold faultHandler.
  eapply HTEscape_compose.
  - eapply genComputeResults_spec.
  - eapply HTEscape_compose.
    + eapply genStoreResults_spec_Some'; eauto.
    + eapply genFaultHandlerReturn_specEscape_Some; auto.
Qed.

Lemma faultHandler_specEscape_None: forall raddr,
  ar = None ->
  forall s0,
    HTEscape raddr faultHandler
             (fun m s => m = m0 /\ s = s0)
             (fun m s => (m = m0 /\ s = s0
                         , Failure)).
Proof.
  intros.
  unfold faultHandler.
  eapply HTEscape_compose.
  - eapply genComputeResults_spec.
  - eapply HTEscape_compose.
    + eapply genStoreResults_spec_None; eauto.
    + eapply genFaultHandlerReturn_specEscape_None; auto.
Qed.

End FaultHandlerSpec.

End TMUSpecs.

(** ** Correctness theorems of the fault handler generator *)
Section HandlerCorrect.

Theorem handler_correct_succeed :
  forall opcode vls pcl c m raddr s i lr lpc,
  forall (INPUT: cache_hit c (opCodeToZ opcode) (labsToZs vls) (labToZ pcl))
         (RULE: run_tmr opcode pcl vls = Some (lpc,lr)),
    exists c',
    runsToEscape (CState c m faultHandler i (CRet raddr false false::s) (0,handlerTag) true)
                 (CState c' m faultHandler i s raddr false) /\
    handler_final_mem_matches lpc lr c c'.
Proof.
  intros.
  assert (valid_address addrTagRes c).
    inv INPUT. inv TAGR. eapply index_list_Z_valid; eauto.
  assert (valid_address addrTagResPC c).
    inv INPUT. inv TAGRPC. eapply index_list_Z_valid; eauto.
  edestruct (faultHandler_specEscape_Some opcode vls pcl c)
      as [stk1 [cache1 [pc1 [priv1 [[P1 P2] [P3 P4]]]]]]; eauto.
   eapply init_enough; auto.
  apply code_at_id. simpl. eauto.
  exists cache1.
  inversion P3.  subst.
  intuition.
  apply P4.
Qed.

Theorem handler_correct_fail :
  forall opcode vls pcl c m raddr s i,
  forall (INPUT: cache_hit c (opCodeToZ opcode) (labsToZs vls) (labToZ pcl))
         (RULE: run_tmr opcode pcl vls = None),
    exists st,
    runsToEscape (CState c m faultHandler i (CRet raddr false false::s) (0,handlerTag) true)
                 (CState c m faultHandler i st (-1,handlerTag) true).
Proof.
  intros.
  edestruct (faultHandler_specEscape_None opcode vls pcl c) with (raddr := (0,0))
      as [stk1 [cache1 [pc1 [priv1 [[P1 P2] [P3 P4]]]]]]; eauto.
   eapply init_enough; eauto.
   eapply code_at_id.
   simpl; eauto. inv P3. eexists. eauto.
Qed.

End HandlerCorrect.

End FaultHandler.

(** * Instantiating the above results for IFC labels *)

(** ** TMU Fault Handler generator  *)
Section TMU.

Local Open Scope Z_scope.

Context {T: Type}
        {Latt: JoinSemiLattice T}
        {CLatt: ConcreteLattice T}
        {ELatt : Encodable T}
        {WFCLatt: WfConcreteLattice T Latt CLatt ELatt}.

(** Compilation of rules *)

Definition genVar {n:nat} (l:LAB n) :=
  match l with
  (* NC: We assume the operand labels are stored at these memory
     addresses when the fault handler runs. *)
  | lab1 _ => loadFrom addrTag1
  | lab2 _ => loadFrom addrTag2
  | lab3 _ => loadFrom addrTag3
  | labpc _ => loadFrom addrTagPC
  end.

Fixpoint genExpr {n:nat} (e: rule_expr n) :=
  match e with
  | L_Bot _ => genBot
  | L_Var l => genVar l
  (* NC: push the arguments in reverse order. *)
  | L_Join e1 e2 => genExpr e2 ++ genExpr e1 ++ genJoin
 end.

Fixpoint genCond {n:nat} (s: rule_cond n) : code :=
  match s with
  | A_True _ => genTrue
  | A_LE e1 e2 => genExpr e2 ++ genExpr e1 ++ genFlows
  | A_And s1 s2 => genCond s2 ++ genCond s1 ++ genAnd
  | A_Or s1 s2 => genCond s2 ++ genCond s1 ++ genOr
  end.

Definition genApplyRule {n:nat} (am:AllowModify n): code :=
  ite (genCond (allow am))
      (some
        (genExpr (labResPC am) ++
         genExpr (labRes am))
      )
      none.

End TMU.

(** * Specifications *)
Section IFC.

Context {T : Type}
        {LT : JoinSemiLattice T}
        {ET : Encodable T}
        {CT : ConcreteLattice T}
        {WT : WfConcreteLattice T LT CT ET}.

Definition fetch_rule_impl_type: Type := forall (opcode:OpCode),  {n:nat & AllowModify n}.
Variable fetch_rule_impl: fetch_rule_impl_type.

Section Specs.

Variable opcode : OpCode.
Variable pcl : T.
Definition n := projT1 (fetch_rule_impl opcode).
Definition am := projT2 (fetch_rule_impl opcode).
Variable vls : Vector.t T n.
Variable m0: memory.
Hypothesis initial_mem_matches: handler_initial_mem_matches
                                  (opCodeToZ opcode)
                                  (labsToZs vls)
                                  (labToZ pcl) m0.

Definition eval_var := mk_eval_var vls pcl.

Lemma genVar_spec_wp: forall v (Q: memory -> stack -> Prop),
      HT (genVar v)
         (fun m s => m = m0 /\ Q m ((labToZ (eval_var v),handlerTag):::s))
         Q.
Proof.
  intros v Q.
  unfold genVar; subst. inv initial_mem_matches. intuition.
  destruct v;
    (eapply HT_strengthen_premise;
    try eapply loadFrom_spec;
    simpl; intros m s [Hmem HQ]; subst;
    try erewrite <- nth_order_valid in HQ; eauto).
Qed.

Lemma genExpr_spec_wp: forall (e: rule_expr n) (Q:memory->stack->Prop),
      HT   (genExpr e)
           (fun m s => m = m0 /\ Q m ((labToZ (eval_expr eval_var e),handlerTag):::s))
           Q.
Proof.
  induction e.
  - intros.
    eapply HT_strengthen_premise.
    eapply genBot_spec.
    split_vc.
 - intros.
   simpl. eapply HT_strengthen_premise.
   eapply genVar_spec_wp.
   split_vc.
 - intros. simpl.
   repeat eapply HT_compose_bwd.
   eapply genJoin_spec.
   eapply IHe1.
   eapply HT_strengthen_premise.
   eapply IHe2.
   split_vc.
Qed.

Lemma genScond_spec_wp: forall (c: rule_cond n) (Q:memory-> stack ->Prop),
      HT   (genCond c)
           (fun m s =>  m = m0  /\
                        Q m ((boolToZ (eval_cond eval_var c),handlerTag):::s))
           Q.

Proof.
  induction c; intros; simpl.

  - eapply HT_strengthen_premise.
    eapply genTrue_spec.
    split_vc.

  - repeat eapply HT_compose_bwd.
    eapply genFlows_spec.
    eapply genExpr_spec_wp.
    eapply HT_strengthen_premise.
    eapply genExpr_spec_wp.
    split_vc.

  - eapply HT_compose_bwd.
    eapply HT_compose_bwd.
    eapply genAnd_spec.
    eapply IHc1.
    eapply HT_strengthen_premise.
    eapply IHc2.
    split_vc.

  - eapply HT_compose_bwd.
    eapply HT_compose_bwd.
    eapply genOr_spec.
    eapply IHc1.
    eapply HT_strengthen_premise.
    eapply IHc2.
    split_vc.
Qed.

Lemma genApplyRule_spec_Some_wp:
  forall lrpc lr,
    apply_rule am pcl vls = Some (lrpc, lr) ->
    forall Q,
      HT   (genApplyRule am)
           (fun m s => m = m0 /\
                       Q m ((        1, handlerTag)  ::: (* [Some (...)] *)
                            (labToZ lr, handlerTag)  :::
                            (labToZ lrpc, handlerTag)::: s))
           Q.
Proof.
  introv Happly. intros.
  unfold genApplyRule.
  unfold apply_rule in Happly.
  cases_if in Happly.
  inv Happly; subst.

  eapply HT_strengthen_premise. unfold ite.
  eapply HT_compose_bwd.
  eapply ifNZ_spec_existential.
  eapply HT_compose_bwd.
  eapply push_spec.

  eapply HT_compose_bwd.
  eapply genExpr_spec_wp.
  eapply genExpr_spec_wp.
  eapply push_spec.
  eapply genScond_spec_wp.
  split_vc.
  unfold eval_var in H2.
  rewrite H in H2 at 1.
  false; lia.
Qed.

Lemma genApplyRule_spec_None_wp:
    apply_rule am pcl vls = None ->
    forall Q,
      HT   (genApplyRule am)
           (fun m s => m = m0 /\
                       Q m ((0, handlerTag) ::: (* [None] *)
                                         s))
           Q.
Proof.
  introv Happly. intros.
  unfold genApplyRule.
  unfold apply_rule in Happly.
  cases_if in Happly.
  eapply HT_strengthen_premise. unfold ite.
  eapply HT_compose_bwd.
  eapply ifNZ_spec_existential.
  eapply HT_compose_bwd.
  eapply push_spec.

  eapply HT_compose_bwd.
  eapply genExpr_spec_wp.
  eapply genExpr_spec_wp.
  eapply push_spec.
  eapply genScond_spec_wp.
  split_vc. substs.
  split; intros;
  (unfold eval_var in H0;
  rewrite H in H0 at 1);
  intuition.
Qed.

Lemma genApplyRule_spec_wp:
  forall ar,
    apply_rule am pcl vls = ar ->
    forall Q,
      HT   (genApplyRule am)
           (fun m s => m = m0 /\
                       Q m (listify_apply_rule ar s))
           Q.
Proof.
  intros.
  case_eq ar; intros p ?; subst.
  - destruct p as [lrpc lr].
    eapply genApplyRule_spec_Some_wp; eauto.
  - eapply genApplyRule_spec_None_wp; eauto.
Qed.

Lemma genCond_spec_wp: forall (c: rule_cond n),
  forall b,
    eval_cond eval_var c = b ->
    forall Q,
      HT   (genCond c)
           (fun m s => m = m0 /\ Q m ((boolToZ b, handlerTag) ::: s))
           Q .
Proof.
  induction c; intros; simpl;
    try (simpl in H); subst.

  (* True *)
  eapply HT_strengthen_premise.
  eapply genTrue_spec. split_vc.

  (* Flows *)
  eapply HT_compose_bwd.
  eapply HT_compose_bwd.
  eapply genFlows_spec.
  eapply genExpr_spec_wp.
  eapply HT_strengthen_premise.
  eapply genExpr_spec_wp. split_vc; eauto.

  (* And *)
  eapply HT_compose_bwd.
  eapply HT_compose_bwd.
  eapply genAnd_spec.
  eapply IHc1; eauto.
  eapply HT_strengthen_premise.
  eapply IHc2; eauto. split_vc; eauto.

  (* Or *)
  eapply HT_compose_bwd.
  eapply HT_compose_bwd.
  eapply genOr_spec.
  eapply IHc1; eauto.
  eapply HT_strengthen_premise.
  eapply IHc2; eauto. split_vc; eauto.
Qed.

End Specs.

#[refine]
Instance LatticeConcreteLabels :
  ConcreteLabels T ET _ (fun op pcl vls => apply_rule (am op) pcl vls) := {
  genRule op := genApplyRule (am op)
}.

Proof.
  intros.
  eapply genApplyRule_spec_wp; eauto.
Qed.

End IFC.


(** * The Yoneda Lemma *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Category.Dual Functor.Dual.
Require Import Functor.Composition.Core.
Require Import Category.Morphisms FunctorCategory.Morphisms.
Require Import SetCategory.
Require Import Functor.Attributes.
Require Import Functor.Composition.Functorial.
Require Import Functor.Identity.
Require Import HomFunctor.
Require Import FunctorCategory.Core.
Require Import NaturalTransformation.Paths.
Require Import HoTT.Tactics.

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

Local Open Scope morphism_scope.
Local Open Scope category_scope.
Local Open Scope functor_scope.

(** Quoting Wikipedia on the Yoneda lemma (chainging [A] to [a] and
    [C] to [A] so that we can use unicode superscripts and
    subscripts):

    In mathematics, specifically in category theory, the Yoneda lemma
    is an abstract result on functors of the type morphisms into a
    fixed object. It is a vast generalisation of Cayley's theorem from
    group theory (viewing a group as a particular kind of category
    with just one object). It allows the embedding of any category
    into a category of functors (contravariant set-valued functors)
    defined on that category. It also clarifies how the embedded
    category, of representable functors and their natural
    transformations, relates to the other objects in the larger
    functor category. It is an important tool that underlies several
    modern developments in algebraic geometry and representation
    theory. It is named after Nobuo Yoneda.

    ** Generalities

    The Yoneda lemma suggests that instead of studying the (locally
    small) category [A], one should study the category of all functors
    of [A] into [Set] (the category of sets with functions as
    morphisms). [Set] is a category we understand well, and a functor
    of [A] into [Set] can be seen as a "representation" of [A] in
    terms of known structures. The original category [A] is contained
    in this functor category, but new objects appear in the functor
    category which were absent and "hidden" in [A]. Treating these new
    objects just like the old ones often unifies and simplifies the
    theory.  This approach is akin to (and in fact generalizes) the
    common method of studying a ring by investigating the modules over
    that ring. The ring takes the place of the category [A], and the
    category of modules over the ring is a category of functors
    defined on [A].

    ** Formal statement

    *** General version

    Yoneda's lemma concerns functors from a fixed category [A] to the
    category of sets, [Set]. If [A] is a locally small category
    (i.e. the hom-sets are actual sets and not proper classes), then
    each object [a] of [A] gives rise to a natural functor to [Set]
    called a hom-functor. This functor is denoted:

    [hᵃ = Hom(a, ─)].

    The (covariant) hom-functor [hᵃ] sends [x] to the set of morphisms
    [Hom(a, x)] and sends a morphism [f] from [x] to [y] to the
    morphism [f ∘ ─] (composition with [f] on the left) that sends a
    morphism [g] in [Hom(a, x)] to the morphism [f ∘ g] in [Hom(a,
    y)]. That is,

    [f ↦ Hom(a, f) = ⟦ Hom(a, x) ∋ g ↦ f ∘ g ∈ Hom(a,y) ⟧].
 *)

(** ** The (co)yoneda functors [A → (Aᵒᵖ → set)] *)
Section yoneda.
  Context `{Funext}.

  (* TODO(JasonGross): Find a way to unify the [yoneda] and [coyoneda] lemmas into a single lemma which is more functorial. *)

  Definition coyoneda A : Functor A^op (A -> set_cat)
    := ExponentialLaws.Law4.Functors.inverse _ _ _ (hom_functor A).

  Definition yoneda A : Functor A (A^op -> set_cat)
    := coyoneda A^op.
End yoneda.

(** ** The (co)yoneda lemma *)
Section coyoneda_lemma.

  Section functor.
    Context `{Funext}.

    Variable A : PreCategory.
    (** Let [F] be an arbitrary functor from [A] to [Set]. Then Yoneda's
      lemma says that: *)
    (*Variable F : Functor A (@set_cat fs).*)
    (** For each object [a] of [A], *)
    (*Variable a : A.*)
    (** the natural transformations from [hᵃ] to [F] are in one-to-one
      correspondence with the elements of [F(a)]. That is,

      [Nat(hᵃ, F) ≅ F(a)].

      Moreover this isomorphism is natural in [a] and [F] when both
      sides are regarded as functors from [Setᴬ × A] to
      [Set].

      Given a natural transformation [Φ] from [hᵃ] to [F], the
      corresponding element of [F(a)] is [u = Φₐ(idₐ)]. *)

    (*   Definition coyoneda_lemma_morphism (a : A)
  : morphism set_cat
             (BuildhSet
                (morphism (A -> set_cat) (coyoneda A a) F)
                _)
             (F a)
    := fun phi => phi a 1%morphism. *)

    Definition coyoneda_functor
    : Functor (A -> set_cat)
              (A -> set_cat)
      := (compose_functor _ _ set_cat (coyoneda A)^op)
           o (yoneda (A -> set_cat)).
  End functor.

  Section nt.
    Context `{Funext}.

    Variable A : PreCategory.

    Definition coyoneda_natural_transformation_helper F
    : morphism (_ -> _) (coyoneda_functor A F) F.
    Proof.
      refine (Build_NaturalTransformation
                (coyoneda_functor A F) F
                (fun a phi => phi a 1%morphism)
                _).
      simpl.
      abstract (
          repeat (intro || apply path_forall);
          simpl in *;
            match goal with
              | [ T : NaturalTransformation _ _ |- _ ]
                => simpl rewrite <- (fun s d m => apD10 (commutes T s d m))
            end;
          rewrite ?left_identity, ?right_identity;
          reflexivity
        ).
    Defined.

    Definition coyoneda_natural_transformation
    : morphism (_ -> _)
               (coyoneda_functor A)
               1.
    Proof.
      hnf.
      simpl.
      let F := match goal with |- NaturalTransformation ?F ?G => constr:(F) end in
      let G := match goal with |- NaturalTransformation ?F ?G => constr:(G) end in
      refine (Build_NaturalTransformation
                F G
                coyoneda_natural_transformation_helper
                _).
      simpl.
      abstract (repeat first [ intro
                             | progress path_natural_transformation
                             | reflexivity ]).
    Defined.
  End nt.

  Definition coyoneda_lemma_morphism_inverse
             `{Funext}
             A
             (F : object (A -> set_cat))
             a
  : morphism set_cat
             (F a)
             (coyoneda_functor A F a).
  Proof.
    intro Fa.
    hnf.
    simpl in *.
    let F0 := match goal with |- NaturalTransformation ?F ?G => constr:(F) end in
    let G0 := match goal with |- NaturalTransformation ?F ?G => constr:(G) end in
    refine (Build_NaturalTransformation
              F0 G0
              (fun a' : A => (fun f : morphism A a a' => F _1 f Fa))
              _
           ).
    simpl.
    abstract (
        repeat first [ reflexivity
                     | intro
                     | apply path_forall
                     | progress rewrite ?composition_of, ?identity_of ]
      ).
  Defined.

  Global Instance coyoneda_lemma `{Funext} A
  : IsIsomorphism (coyoneda_natural_transformation A).
  Proof.
    eapply isisomorphism_natural_transformation.
    simpl.
    intro F.
    eapply isisomorphism_natural_transformation.
    intro a.
    simpl.
    exists (coyoneda_lemma_morphism_inverse F a);
      simpl in *;
    abstract (
        repeat (intro || apply path_forall || path_natural_transformation);
        simpl in *;
          solve [ simpl rewrite <- (fun c d m => ap10 (commutes x c d m));
                  rewrite ?right_identity, ?left_identity;
                  reflexivity
                | rewrite identity_of;
                  reflexivity ]
      ).
  Defined.
End coyoneda_lemma.

Section yoneda_lemma.
  (** There is a contravariant version of Yoneda's lemma which
      concerns contravariant functors from [A] to [Set]. This version
      involves the contravariant hom-functor

      [hₐ = Hom(─, A)],

      which sends [x] to the hom-set [Hom(x, a)]. Given an arbitrary
      contravariant functor [G] from [A] to [Set], Yoneda's lemma
      asserts that

      [Nat(hₐ, G) ≅ G(a)]. *)

  Section functor.
    Context `{Funext}.

    Variable A : PreCategory.
    (** Let [F] be an arbitrary functor from [A] to [Set]. Then Yoneda's
      lemma says that: *)
    (*Variable F : Functor A (@set_cat fs).*)
    (** For each object [a] of [A], *)
    (*Variable a : A.*)
    (** the natural transformations from [hᵃ] to [F] are in one-to-one
      correspondence with the elements of [F(a)]. That is,

      [Nat(hᵃ, F) ≅ F(a)].

      Moreover this isomorphism is natural in [a] and [F] when both
      sides are regarded as functors from [Setᴬ × A] to
      [Set].

      Given a natural transformation [Φ] from [hᵃ] to [F], the
      corresponding element of [F(a)] is [u = Φₐ(idₐ)]. *)

    (* Definition yoneda_lemma_morphism A (G : object (A^op -> set_cat)) (a : A)
  : morphism set_cat
             (BuildhSet
                (morphism (A^op -> set_cat) (yoneda A a) G)
                _)
             (G a)
    := fun phi => phi a 1%morphism.*)

    Definition yoneda_functor
    : Functor (A^op -> set_cat)
              (A^op -> set_cat)
      := coyoneda_functor A^op.
  End functor.

  Context `{Funext}.

  Variable A : PreCategory.

  Definition yoneda_natural_transformation
  : morphism (_ -> _)
             1
             (yoneda_functor A)
    := @morphism_inverse _ _ _ _ (coyoneda_lemma A^op).

  Global Instance yoneda_lemma
  : IsIsomorphism yoneda_natural_transformation
    := @isisomorphism_inverse _ _ _ _ (coyoneda_lemma A^op).
End yoneda_lemma.

(** ** The Yoneda embedding

    An important special case of Yoneda's lemma is when the functor
    [F] from [A] to [Set] is another hom-functor [hᵇ]. In this case,
    the covariant version of Yoneda's lemma states that

    [Nat(hᵃ, hᵇ) ≅ Hom(b, a)].

    That is, natural transformations between hom-functors are in
    one-to-one correspondence with morphisms (in the reverse
    direction) between the associated objects. Given a morphism [f : b
    → a] the associated natural transformation is denoted [Hom(f, ─)].

    Mapping each object [a] in [A] to its associated hom-functor [hᵃ=
    Hom(a, ─)] and each morphism [f : B → A] to the corresponding
    natural transformation [Hom(f, ─)] determines a contravariant
    functor [h⁻] from [A] to [Setᴬ], the functor category of all
    (covariant) functors from [A] to [Set]. One can interpret [h⁻] as
    a covariant functor:

    [h⁻ : Aᵒᵖ → Setᴬ].

    The meaning of Yoneda's lemma in this setting is that the functor
    [h⁻] is fully faithful, and therefore gives an embedding of [Aᵒᵖ]
    in the category of functors to [Set]. The collection of all
    functors {[hᵃ], [a] in [A]} is a subcategory of [Set̂ᴬ]. Therefore,
    Yoneda embedding implies that the category [Aᵒᵖ] is isomorphic to
    the category {[hᵃ], [a] in [A]}.

    The contravariant version of Yoneda's lemma states that

    [Nat(hₐ, h_b) ≅ Hom(a, b)].

    Therefore, [h₋] gives rise to a covariant functor from [A] to the
    category of contravariant functors to [Set]:

    [h₋ : A → Set⁽⁽ᴬ⁾ᵒᵖ⁾].

    Yoneda's lemma then states that any locally small category [A] can
    be embedded in the category of contravariant functors from [A] to
    [Set] via [h₋]. This is called the Yoneda embedding. *)

Section FullyFaithful.
  Context `{Funext}.

  Definition coyoneda_embedding (A : PreCategory) : IsFullyFaithful (coyoneda A).
  Proof.
    intros a b.
    pose proof (@isisomorphism_inverse
                  _ _ _ _
                  (@isisomorphism_components_of
                     _ _ _ _ _ _
                     (@isisomorphism_components_of
                        _ _ _ _ _ _
                        (@coyoneda_lemma _ A)
                        (@coyoneda _ A b))
                     a)) as H'.
    simpl in *.
    unfold coyoneda_lemma_morphism_inverse in *; simpl in *.
    unfold Functors.inverse_object_of_morphism_of in *; simpl in *.
    let m := match type of H' with IsIsomorphism ?m => constr:(m) end in
    apply isisomorphism_set_cat_natural_transformation_paths with (T1 := m).
    - simpl.
      clear H'.
      intros; apply path_forall;
      intro;
      rewrite left_identity, right_identity;
      reflexivity.
    - destruct H' as [m' H0' H1'].
      (exists m').
      + exact H0'.
      + exact H1'.
  Qed.

  Definition yoneda_embedding (A : PreCategory) : IsFullyFaithful (yoneda A).
  Proof.
    intros a b.
    pose proof (@coyoneda_embedding A^op a b) as CYE.
    unfold yoneda.
    let T := type of CYE in
    let T' := (eval simpl in T) in
    pose proof ((fun x : T => (x : T')) CYE) as CYE'.
    let G := match goal with |- ?G => constr:(G) end in
    let G' := (eval simpl in G) in
    exact ((fun x : G' => (x : G)) CYE').
  Qed.
End FullyFaithful.


(* (c) Copyright Christian Doczkal, Saarland University                   *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import Relations Lia.
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From CompDecModal.libs
 Require Import edone bcase fset base modular_hilbert sltype.

From CompDecModal.Kstar
 Require Import Kstar_def demo hilbert_ref gen_def gen_ref.

(** * Main Results *)

(** Soundness and Completeness of the Hilbert System *)

Lemma soundness s : prv s -> forall (M:cmodel) (w:M), eval s w.
Proof. exact: Kstar_def.soundness. Qed.

Theorem informative_completeness s :
    prv (fImp s fF)
  + (exists2 M:fmodel, #|M| <= 2^(2 * f_size s) & exists w:M, eval s w).
Proof. exact: informative_completeness s. Qed.

Corollary prv_dec s : decidable (prv s).
Proof. exact: prv_dec. Qed.

Corollary sat_dec s : decidable (exists (M:cmodel) (w:M), eval s w).
Proof. exact: sat_dec. Qed.

Corollary valid_dec s : decidable (forall (M:cmodel) (w:M), eval s w).
Proof. exact: valid_dec. Qed.

Corollary small_models s:
  (exists (M:cmodel) (w:M), eval s w) ->
  (exists2 M:fmodel, #|M| <= 2^(2 * f_size s) & exists w:M, eval s w).
Proof. exact: small_models. Qed.

(** Correctness of the Gentzen System *)

Lemma gen_completeness C : gen (C,aVoid) + (exists M : fmodel, sat M C).
Proof. exact: gen_completeness. Qed.

Theorem gen_correctness C : gen (C,aVoid) <-> ~ (exists M : cmodel, sat M C).
Proof. exact: gen_correctness. Qed.

(** Equivalence to Segerberg Style Hilbert System *)

Theorem prv_Sprv s : prv s <-> S.prv s.
Proof. exact: prv_Sprv. Qed.


Require Import
  HoTT.Types.Universe
  HoTT.Basics.Decidable
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.integers
  HoTT.Classes.interfaces.naturals
  HoTT.Classes.interfaces.rationals
  HoTT.Classes.interfaces.orders
  HoTT.Classes.implementations.natpair_integers
  HoTT.Classes.theory.rings
  HoTT.Classes.theory.integers
  HoTT.Classes.theory.dec_fields
  HoTT.Classes.orders.dec_fields
  HoTT.Classes.theory.rationals
  HoTT.Classes.orders.lattices
  HoTT.Classes.theory.additional_operations
  HoTT.Classes.theory.premetric
  HoTT.Classes.implementations.assume_rationals
  HoTTClasses.cauchy_completion.

Require Export
  HoTTClasses.cauchy_reals.base
  HoTTClasses.cauchy_reals.abs
  HoTTClasses.cauchy_reals.order
  HoTTClasses.cauchy_reals.metric
  HoTTClasses.cauchy_reals.ring.

Local Set Universe Minimization ToSet.

Lemma uniform_on_intervals_continuous `{Closeness A} (f:real -> A)
  (mu : Q+ -> Q+ -> Q+)
  {Emu : forall a : Q+,
    Uniform (f ∘ interval_proj (rat (- ' a)) (rat (' a))) (mu a)}
  : Continuous f.
Proof.
intros u e.
apply (merely_destruct (R_Qpos_bounded u)). intros [a Ea].
hnf in Emu. unfold Compose in Emu.
apply (merely_destruct (R_archimedean _ _ Ea)). intros [q [Eq Eq']].
apply rat_lt_reflecting in Eq'.
apply tr;exists (meet (mu a e) (Qpos_diff _ _ Eq')).
intros v xi.
assert (xi1 : close (mu a e) u v).
{ eapply rounded_le;[exact xi|].
  apply meet_lb_l. }
assert (xi2 : close (Qpos_diff q (' a) Eq') u v).
{ eapply rounded_le;[exact xi|].
  apply meet_lb_r. }
assert (E1 :  rat (- ' a) <= u /\ u <= rat (' a)).
{ change (rat (- ' a)) with (- (rat (' a))). apply Rabs_le_pr.
  transitivity (rat q);apply R_lt_le;trivial.
  apply rat_lt_preserving;trivial.
}
assert (E2 : rat (- ' a) <= v /\ v <= rat (' a)).
{ change (rat (- ' a)) with (- (rat (' a))). apply Rabs_le_pr.
  rewrite (Qpos_diff_pr _ _ Eq').
  apply R_lt_le.
  eapply Rlt_close_rat_plus;[exact Eq|].
  apply (non_expanding abs),xi2.
}
exact (Emu _ _ (existT _ _ E1) (existT _ _ E2) xi1).
Qed.


Definition S    : Type := Prop .
Definition Cl   : Type := Prop .
Definition Pol  : Type := Prop -> Prop .

Definition Pos : Pol := fun p => p.
Definition Neg : Pol := fun p => not p.
Definition UseCl : Pol -> Cl -> S :=
  fun pol c => pol c.

Parameter VP   : Type.
Parameter PN   : Type.
Parameter NP   : Type.
Parameter AP   : Type.
Parameter A    : Type.
Parameter CN   : Type.
Parameter Det  : Type.
Parameter N    : Type.
Parameter V    : Type.
Parameter V2   : Type.
Parameter AdA  : Type.
Parameter Conj : Type.

Parameter PredVP  : NP -> VP -> Cl.
Parameter ComplV2 : V2 -> NP -> VP.
Parameter DetCN   : Det -> CN -> NP.
Parameter ModCN   : AP -> CN -> CN.
Parameter CompAP  : AP -> VP.
Parameter AdAP    : AdA -> AP -> AP.
Parameter ConjS   : Conj -> S  -> S  -> S.
Parameter ConjNP  : Conj -> NP -> NP -> NP.
Parameter UsePN   : PN -> NP.
Parameter UseV    : V -> VP.
Parameter UseN    : N -> CN.
Parameter UseA    : A -> AP.
Parameter some_Det : Det.
Parameter every_Det : Det.
Parameter we_NP   : NP.
Parameter you_NP : NP.
Parameter very_AdA : AdA.
Parameter and_Conj : Conj.
Parameter or_Conj : Conj.

Parameter man_N :  N.
Parameter woman_N : N .
Parameter house_N :  N.
Parameter tree_N : N .
Parameter   big_A : A .
Parameter small_A : A .
Parameter green_A : A .
Parameter  walk_V : V  .
Parameter arrive_V : V .
Parameter love_V2 : V2  .
Parameter please_V2 : V2 .
Parameter john_PN : PN .
Parameter mary_PN : PN.

Theorem POL : UseCl Pos (PredVP (UsePN john_PN) (UseV walk_V)) ->
               UseCl Neg (PredVP (UsePN john_PN)(UseV walk_V)) -> False.
cbv.
intros P N. apply N. assumption.
Qed.


(**************************************************************************)
(*  This is part of EXCEPTIONS, it is distributed under the terms of the  *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2015: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                        *)
(**************************************************************************)

Require Import Relations Morphisms.
Require Import Program.
Require Prerequistes Terms Decorations Axioms Derived_CoProjections.
Set Implicit Arguments.

Module Make(Import M: Prerequistes.T).
  Module Export Derived_CoProductsExp := Derived_CoProjections.Make(M).

Definition lcoprod {X1 Y1 X2 Y2} (f1: term X1 X2) (f2: term Y1 Y2) : term (X1 + Y1) (X2 + Y2) := copair (in1 o f1) (in2 o f2).

Definition rcoprod {X Y X' Y'} (f1: term X X') (f2: term Y Y') : term (X+Y) (X'+Y') := rcopair (in1 o f1) (in2 o f2).

Lemma is_lcoprod: forall k X' X Y' Y (f1: term X X') (f2: term Y Y'), PPG f1 -> is k f1 -> is k f2 -> is k (lcoprod f1 f2). (* FIXED *)
Proof. intros k X' X Y' Y f1 f2 H1 H2 H3. induction k; edecorate. Qed.

Lemma is_rcoprod: forall k X' X Y' Y (f1: term X X') (f2: term Y Y'), PPG f2 -> is k f1 -> is k f2 -> is k (rcoprod f1 f2). (* FIXED *)
Proof. intros k X' X Y' Y f1 g2 H1 H2 H3. induction k; edecorate. Qed.

Lemma w_lcoprod_eq: forall X1 X2 Y1 Y2 (f: term X1 X2) (g: term Y1 Y2), PPG f -> (lcoprod f g) o in1 ~ in1 o f.
Proof. intros X1 X2 Y1 Y2 f g H. apply w_lcopair_eq; edecorate. Qed.

Lemma s_lcoprod_eq: forall X1 X2 Y1 Y2 (f: term X1 X2) (g: term Y1 Y2), PPG f -> (lcoprod f g) o in2 == in2 o g.
Proof. intros X1 X2 Y1 Y2 f g H. apply s_lcopair_eq; edecorate. Qed.

Lemma s_rcoprod_eq: forall X1 X2 Y1 Y2 (f: term X1 X2) (g: term Y1 Y2), PPG g -> (rcoprod f g) o in1 == in1 o f.
Proof. intros X1 X2 Y1 Y2 f g H. apply s_rcopair_eq; edecorate. Qed.

Lemma w_rcoprod_eq: forall X1 X2 Y1 Y2 (f: term X1 X2) (g: term Y1 Y2), PPG g -> (rcoprod f g) o in2 ~ in2 o g.
Proof. intros X1 X2 Y1 Y2 f g H. apply w_rcopair_eq; edecorate. Qed.

Lemma lcoprod_u: forall X1 X2 Y1 Y2 (f1 f2: term (Y2 + Y1) (X2 + X1)), (f1 o in1 ~ f2 o in1) /\ (f1 o in2 == f2 o in2) -> f1 == f2.
Proof. intros X1 X2 Y1 Y2 f1 f2 (H0&H1). apply lcopair_u. split; [exact H0| exact H1]. Qed.

Lemma rcoprod_u: forall X1 X2 Y1 Y2 (f1 f2: term (Y2 + Y1) (X2 + X1)), (f1 o in1 == f2 o in1) /\ (f1 o in2 ~ f2 o in2) -> f1 == f2.
Proof. intros X1 X2 Y1 Y2 f1 f2 (H0&H1). apply rcopair_u. split; [exact H0| exact H1]. Qed.

End Make.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia Relations.

From Undecidability.MinskyMachines
  Require Import MM2 ndMM2.

From Undecidability.Shared.Libs.DLW
  Require Import utils.

From Undecidability.Synthetic
  Require Import Definitions ReducibilityFacts.

Set Implicit Arguments.

Section MM2_ndMM2.

  Notation STOP := (@ndmm2_stop _).
  Notation INC  := (@ndmm2_inc _).
  Notation DEC  := (@ndmm2_dec _).
  Notation ZERO := (@ndmm2_zero _).

  Notation α := true.
  Notation β := false.

  Definition mm2_instr_enc i ρ :=
    match ρ with
      | mm2_inc_a   => INC α i (1+i) :: nil
      | mm2_inc_b   => INC β i (1+i) :: nil
      | mm2_dec_a j => DEC α i j :: ZERO true  i (1+i) :: nil
      | mm2_dec_b j => DEC β i j :: ZERO false i (1+i) :: nil
    end.

  Fixpoint mm2_linstr_enc i l :=
    match l with
      | nil => nil
      | ρ::l => mm2_instr_enc i ρ ++ mm2_linstr_enc (1+i) l
    end.

  Fact mm2_linstr_enc_app i l m : mm2_linstr_enc i (l++m) = mm2_linstr_enc i l ++ mm2_linstr_enc (length l+i) m.
  Proof.
    revert i; induction l as [ | ? l IHl ]; intros ?; simpl; auto.
    rewrite app_ass, IHl; do 3 f_equal; auto.
  Qed.

  Fact mm2_linstr_enc_In i P c :
          In c (mm2_linstr_enc i P)
       -> exists l r ρ, P = l++ρ::r /\ In c (mm2_instr_enc (length l+i) ρ).
  Proof.
    revert i; induction P as [ | ρ P IH ]; intros i.
    + intros [].
    + simpl; rewrite in_app_iff; intros [ H | H ].
      * exists nil, P, ρ; split; auto.
      * destruct (IH (1+i)) as (l & r & ρ' & H1 & H2); auto.
        exists (ρ::l), r, ρ'; split; auto.
        - simpl; f_equal; auto.
        - eq goal H2; do 2 f_equal; simpl; lia.
  Qed.

  Notation "Σ // a ⊕ b ⊦ u" := (ndmm2_accept Σ a b u) (at level 70, no associativity).

  Local Fact mm2_instr_enc_sound Σ ρ s1 s2 :
          mm2_atom ρ s1 s2
       -> match s1, s2 with
            | (i,(a,b)), (j,(a',b')) => incl (mm2_instr_enc i ρ) Σ
                                     -> Σ // a' ⊕ b' ⊦ j
                                     -> Σ // a  ⊕ b  ⊦ i
          end.
  Proof.
    induction 1 as [ i a b | i a b | i j a b | i j a b | i j b | i j a ]; simpl; intros HΣ H.
    + constructor 2 with (1+i); auto; apply HΣ; simpl; auto.
    + constructor 3 with (1+i); auto; apply HΣ; simpl; auto.
    + constructor 4 with j; auto; apply HΣ; simpl; auto.
    + constructor 5 with j; auto; apply HΣ; simpl; auto.
    + constructor 6 with (1+i); auto; apply HΣ; simpl; auto.
    + constructor 7 with (1+i); auto; apply HΣ; simpl; auto.
  Qed.

  Local Fact mm2_step_linstr_sound Σ P s1 s2 :
          mm2_step P s1 s2
       -> match s1, s2 with
            | (i,(a,b)), (j,(a',b')) => incl (mm2_linstr_enc 1 P) Σ
                                     -> Σ // a' ⊕ b' ⊦ j
                                     -> Σ // a  ⊕ b  ⊦ i
          end.
  Proof.
    intros (ρ & (l&r&H1&H2) & H3).
    apply mm2_instr_enc_sound with (Σ := Σ) in H3; revert s1 s2 H2 H3.
    intros (i,(a,b)) (j,(a',b')); simpl; intros H2 H3 H4 H5.
    apply H3; auto.
    apply incl_tran with (2 := H4).
    rewrite H1, mm2_linstr_enc_app.
    apply incl_appr; simpl.
    apply incl_appl.
    rewrite <- H2, Nat.add_comm.
    apply incl_refl.
  Qed.

  Notation "P // x ↠ y" := (clos_refl_trans _ (mm2_step P) x y) (at level 70).

  Variable P : list mm2_instr.

  Definition mm2_prog_enc := STOP 0 :: mm2_linstr_enc 1 P.

  Notation Σ := mm2_prog_enc.

  Local Lemma mm2_prog_enc_compute s1 s2 :
          P // s1 ↠ s2
       -> match s1, s2 with
            | (i,(a,b)), (j,(a',b')) => Σ // a' ⊕ b' ⊦ j
                                     -> Σ // a  ⊕ b  ⊦ i
          end.
  Proof.
    induction 1 as [ (?,(?,?)) (?,(?,?)) H
                   | (?,(?,?))
                   | (?,(?,?)) (?,(?,?)) (?,(?,?))  ]; eauto.
    apply mm2_step_linstr_sound with (Σ := Σ) in H.
    apply H, incl_tl, incl_refl.
  Qed.

  Local Lemma mm2_prog_enc_stop : Σ // 0 ⊕ 0 ⊦ 0.
  Proof. constructor 1; simpl; auto. Qed.

  Hint Resolve mm2_prog_enc_stop : core.

  Local Lemma mm2_prog_enc_complete a b p :
             Σ // a ⊕ b ⊦ p -> P // (p,(a,b)) ↠ (0,(0,0)).
  Proof.
    induction 1 as [ u H
                   | a b u v H H1 IH1
                   | a b u v H H1 IH1
                   | a b u v H H1 IH1
                   | a b u v H H1 IH1
                   | b p u H H1 IH1
                   | a p u H H1 IH1 ].
    + destruct H as [ H | H ].
      * inversion H; subst u; constructor 2.
      * apply mm2_linstr_enc_In in H
          as (l & r & [ | | | ] & H1 & H2); simpl in H2.
        1-2: now destruct H2.
        1-2: now destruct H2 as [ | [] ].
    + destruct H as [ H | H ]; try discriminate.
      apply mm2_linstr_enc_In in H
        as (l & r & [ | | | ] & H3 & H2); simpl in H2.
      2: now destruct H2.
      2-3: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [] ]; inversion H2; subst.
      constructor 3 with (length l+2, (S a,b)).
      * constructor 1.
        exists mm2_inc_a; split.
        - exists l, r; simpl; split; auto; lia.
        - rewrite !(Nat.add_comm (length l)); constructor.
      * eq goal IH1; do 2 f_equal; lia.
    + destruct H as [ H | H ]; try discriminate.
      apply mm2_linstr_enc_In in H
        as (l & r & [ | | | ] & H3 & H2); simpl in H2.
      1: now destruct H2.
      2-3: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [] ]; inversion H2; subst.
      constructor 3 with (length l+2, (a,S b)).
      * constructor 1.
        exists mm2_inc_b; split.
        - exists l, r; simpl; split; auto; lia.
        - rewrite !(Nat.add_comm (length l)); constructor.
      * eq goal IH1; do 2 f_equal; lia.
    + destruct H as [ H | H ]; try discriminate.
      apply mm2_linstr_enc_In in H
        as (l & r & [ | | | ] & H3 & H2); simpl in H2.
      1-2: now destruct H2.
      2: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | H2 ].
      2: now destruct H2.
      inversion H2; subst.
      constructor 3 with (v, (a,b)); auto.
      constructor 1.
      exists (mm2_dec_a v); split; auto.
      * exists l, r; simpl; split; auto; lia.
      * rewrite !(Nat.add_comm (length l)); constructor.
    + destruct H as [ H | H ]; try discriminate.
      apply mm2_linstr_enc_In in H
        as (l & r & [ | | | ] & H3 & H2); simpl in H2.
      1-2: now destruct H2.
      1: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | H2 ].
      2: now destruct H2.
      inversion H2; subst.
      constructor 3 with (v, (a,b)); auto.
      constructor 1.
      exists (mm2_dec_b v); split; auto.
      * exists l, r; simpl; split; auto; lia.
      * rewrite !(Nat.add_comm (length l)); constructor.
    + destruct H as [ H | H ]; try discriminate.
      apply mm2_linstr_enc_In in H
        as (l & r & [ | | | ] & H3 & H2); simpl in H2.
      1-2: now destruct H2.
      2: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [ H2 | [] ] ].
      1: easy.
      inversion H2; subst.
      constructor 3 with (length l+2, (0,b)).
      * constructor 1.
        exists (mm2_dec_a n); split.
        - exists l, r; simpl; split; auto; lia.
        - rewrite !(Nat.add_comm (length l)); constructor.
      * eq goal IH1; do 2 f_equal; lia.
    + destruct H as [ H | H ]; try discriminate.
      apply mm2_linstr_enc_In in H
        as (l & r & [ | | | ] & H3 & H2); simpl in H2.
      1-2: now destruct H2.
      1: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [ H2 | [] ] ].
      1: easy.
      inversion H2; subst.
      constructor 3 with (length l+2, (a,0)).
      * constructor 1.
        exists (mm2_dec_b n); split.
        - exists l, r; simpl; split; auto; lia.
        - rewrite !(Nat.add_comm (length l)); constructor.
      * eq goal IH1; do 2 f_equal; lia.
  Qed.

  Theorem MM2_ndMM2_equiv a b : MM2_HALTS_ON_ZERO (P,a,b) <-> Σ // a ⊕ b ⊦ 1.
  Proof.
    split.
    + intros H; apply mm2_prog_enc_compute in H; auto.
    + apply mm2_prog_enc_complete.
  Qed.

End MM2_ndMM2.

Theorem reduction : MM2_HALTS_ON_ZERO ⪯ @ndMM2_ACCEPT nat.
Proof.
  apply reduces_dependent; exists.
  intros ((P,a),b).
  exists (existT _ (mm2_prog_enc P) (1,(a,b))).
  apply MM2_ndMM2_equiv.
Qed.


(** remove printing ~ *)
(** printing ~ %\textasciitilde% *)
(** printing R $R$ *)
(** printing done %\texttt{\emph{done}}% *)
(** printing congr %\texttt{\emph{congr}}% *)
(** printing of %\texttt{\emph{of}}% *)
(** printing first %\texttt{{first}}% *)
(** printing last %\texttt{\emph{last}}% *)
(** printing suff %\texttt{\emph{suff}}% *)
(** printing have %\texttt{\emph{have}}% *)
(** printing View %\texttt{\emph{View}}% *)
(** printing >-> %\texttt{>->}% *)
(** printing bot $\bot$ *)
(** printing <== $\pre$ *)
(** printing From %\textsf{{From}}% *)

(**
%
\chapter{Encoding Mathematical Structures}
\label{ch:depstruct}
%
*)

(**

Long before programming has been established as a discipline,
mathematics came to be perceived as a science of building
abstractions and summarizing important properties of various entities
necessary for describing nature's phenomenons.%\footnote{In
addition to being a science of rewriting, as we have already covered
in Chapter~\ref{ch:eqrew}.}% From the basic course of algebra, we are
familiar with a number of mathematical structures, such as monoids,
groups, rings, fields etc., which couple a _carrier_ set (or a number of
sets), a number of operations on it (them), and a collection of
properties of the set itself and operations on them.

From a working programmer's perspective, a notion of a mathematical
abstract structure is reminiscent to a notion of a class from
object-oriented programming, modules from Standard ML and type
classes%~\cite{Wadler-Blott:POPL89}% from Haskell: all these
mechanisms are targeted to solve the same goal: _package_ a number of
operations manipulating with some data, while abstracting of a
particular implementation of this data itself. What neither of these
programming mechanisms is capable of doing, comparing to mathematics,
is enforcing the requirement for one to provide the _proofs_ of
properties, which restrict the operations on the data structure. For
instance, one can implement a type class for a _lattice_ in Haskell as
follows: %\index{type classes}\index{Haskell}%

<<
  class Lattice a where
    bot :: a
    top :: a
    pre :: a -> a -> Bool
    lub :: a -> a -> a
    glb :: a -> a -> a
>>

That is, the class %\texttt{Lattice}% is parametrized by a _carrier_
type %\texttt{a}%, and provides the abstract interfaces for top and
bottom elements of the lattice, as well as for the ordering predicate
%\texttt{pre}% and the binary _least-upper-bound_ and
_greatest-lower-bound_ operations. What this class cannot capture is a
number of restrictions, for instance, that the %\texttt{pre}% relation
should be transitive, reflexive and antisymmetric. That said, one can
instantiate the %\texttt{Lattice}% class, e.g., for integers,
%\index{lattice}% providing an implementation of %\texttt{pre}%, which
is _not_ a partial order (e.g., just constant %\texttt{true}%). While
this relaxed approach is supposedly fine for the programming needs, as
the type classes are used solely for computing, not the reasoning
about the correctness of the computations, this is certainly
unsatisfactory from the mathematical perspective. Without the
possibility to establish and enforce the necessary properties of a
mathematical structure's operations, we would not be able to carry out
any sort of sound formal reasoning, as we simply could not distinguish
a "correct" implementation from a flawed one.

Luckily, Coq's ability to work with dependent types and combine
programs and propositions about them in the same language, as we've
already witnessed in the previous chapters, makes it possible to
define mathematical structures with a necessary degree of rigour and
describe their properties precisely by means of stating them as
_types_ (i.e., propositions) of the appropriate implementation's
parameters. Therefore, any faithful instance of an abstract
mathematical structure implemented this way, would be enforced to
provide not just the _carrier_ and implementations of the declared
operations but also _proofs_ of propositions that constrain these
operations and the carrier.

In this chapter we will learn how to encode common algebraic data
structures in Coq in a way very similar to how data structures are
encoded in languages like C (with a bit of Haskell-ish type class-like
machinery), so the representation, unlike the one in C or Haskell,
would allow for flexible and generic reasoning about the structures'
properties. In the process, we will meet some old friends from the
course of abstract algebra---partial commutative monoids, and implement
them using Coq's native constructs: dependent records and canonical
structures.

As usual, we will require a number of Ssreflect package imported.

*)

From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype ssrfun.

(* begin hide *)
Module DepRecords.
(* end hide *)

(**

We will also require to execute a number of Vernacular commands
simplifying the handling of implicit datatype arguments.

%\ccom{Set Implicit Arguments}%
%\ccom{Unset Strict Implicit}%
%\ccom{Unset Printing Implicit}%

*)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(**

* Encoding partial commutative monoids
%\label{sec:pcms}%

%\index{partial commutative monoid}%
%\index{PCM|see {partial commutative monoid}}%

We will be using partial commutative monoids (PCMs) as an illustrative
example of a simple algebraic data structure, a subject of encoding
and formalization. A PCM is defined as an algebraic structure with a
carrier set [U], abstract binary "join" operation $\join$ and a unit
element $\unit$.%\footnote{Sometimes also referred to as an
\emph{identity} or \emph{neutral} element.}%%\index{unit element}%
%\index{join operation}% The join operation is required to be
associative and commutative, and for the unit element the left and
right identity equalities should hold. Moreover, partiality means that
the operation $\join$ might be undefined for some pairs of elements
[a] and [b] (and in this case it is denoted as $a \join b =
\bot$). PCMs are fairly ubiquitous: in particular, natural numbers
with addition and multiplication, sets with a disjoin union,
partially-defined functions with a point-wise union, are all PCM
instances. Furthermore, partial commutative monoids are omnipresent in
program verification%~\cite{Nanevski-al:POPL10}%, as they capture
exactly the properties of _heaps_, as well as the effect of programs
that can be executed in
parallel%~\cite{Nanevski-al:ESOP14}%. Therefore, it is useful to have
PCMs formalized as a structure, so they could be employed for future
reasoning.

%\index{identity element|see {unit element}}%

%\newpage%

** Describing algebraic data structures via dependent records

*)

Module PCMDef.

(**

In %Section~\ref{sec:exists} of Chapter~\ref{ch:logic}% we have
already seen a use of a dependent pair type, exemplified by the Coq's
definition of the universal quantification.

*)

Print ex.

(**
[[
Inductive ex (A : Type) (P : A -> Prop) : Prop :=
    ex_intro : forall x : A, P x -> ex P
]]

The only constructor [ex_intro] of the predicate [ex], whose type is a
dependent function type, is a way to encode a $\Sigma$-type of a
dependent pair, such that its second component's type _depends_ on the
value of the first one.%\index{dependent pair}% More specifically, the
result of the existential quantification's encoding in Coq is a
dependent pair $(\Sigma x:A, P~x)$, such that the proposition in
the second component is determined by the value of the first
component%~%[x].

%\index{dependent records}%

Coq provides an alternative way to encode _iterated_ dependent pairs
via the mechanism of _dependent records_, also allowing one to give
names to the subsequent components. Dependent records are defined
using the [Record] command. Getting back to our PCM example, we
illustrate the use of dependent records by the following definition of
the abstract PCM structure.

%\index{mixins}%
%\ccom{Record}%

*)

Record mixin_of (T : Type) := Mixin {
    valid_op : T -> bool;
    join_op : T -> T -> T;
    unit_op : T;
    _ : commutative join_op;
    _ : associative join_op;
    _ : left_id unit_op join_op;
    _ : forall x y, valid_op (join_op x y) -> valid_op x;
    _ : valid_op unit_op
}.

(**

[[
mixin_of is defined
mixin_of_rect is defined
mixin_of_ind is defined
mixin_of_rec is defined
valid_op is defined
join_op is defined
unit_op is defined
]]

%\index{record types|see {dependent records}}%

The syntax of Coq's dependent records is reminiscent to the one of
records in C. Following Ssreflect's naming
pattern%~\cite{Garillot-al:TPHOL09}%, we call the record type (defined
in a dedicated module for the reasons explained further) [mixin_of]
and its only constructor [Mixin]. The reasons for such naming
convention will be explained soon, and for now let us discuss the
definition. The PCM record type is parametrized over the carrier type
[T], which determines the carrier set of a PCM. It then lists three
_named_ fields: [join_op] describes an implementation of the PCM's
binary operation, [unit_op] defines the unit element, finally, the
[valid_op] predicate determines whether a particular element of the
carrier set [T] is valid or not, and, thus, serves as a way to express
the partiality of the [join_op] operation (the result is undefined,
whenever the corresponding value of [T] is non-valid). Next, the PCM
record lists five unnamed PCM _properties_, which should be satisfied
whenever the record is instantiated and are defined using the standard
propositions from Ssreflect's [ssrfun] %\ssrm{ssrfun}% module (see
%Section~\ref{sec:funprops}%). In particular, the PCM type definition
requires the operation to be [commutative] and [associative]. It also
states that if $a \join b \neq \bot$ then $a \neq \bot$ (the same
statement about $b$ can be proved by commutativity), and that the unit
element is a valid one.

Notice that in the definition of the [mixin_of] record type, the types
of some of the later fields (e.g., any of the properties) depend on
the values of fields declared earlier (e.g., [unit_op] and [join_op]),
which makes [mixin_of] to be a truly dependent type.

Upon describing the record, a number of auxiliary definitions have been
generated by Coq automatically. Along with the usual recursion and
induction principles, the system also generated three _getters_,
[valid_op], [join_op] and [unit_op] %\index{getters}% for the record's
named fields. That is, similarly to Haskell's syntax, given an
instance of a PCM, one can extract, for example, its operation, via
the following getter function.

*)

Check valid_op.

(**
[[
valid_op
     : forall T : Type, mixin_of T -> T -> bool
]]

Coq supports the syntax for anonymous record fields (via the
underscore [_]), so getters for them are not generated. We have
decided to make the property fields of [mixin_of] to be anonymous,
since they will usually appear only in the proofs, where the structure
is going to be decomposed by case analysis anyway, as we will soon
see.

We can now prove a number of facts about the structure, very much in
the spirit of the facts that are being proven in the algebra course.
For instance, the following lemma states that [unit_op] is also the
_right unit_, in addition to it being the left unit, as encoded by the
structure's definition.

%\index{right unit}%
%\index{left unit}%

*)

Lemma r_unit T (pcm: mixin_of T) (t: T) : (join_op pcm t (unit_op pcm)) = t.
Proof.
case: pcm=>_ join unit Hc _ Hlu _ _ /=.

(**
[[
  T : Type
  t : T
  join : T -> T -> T
  unit : T
  Hc : commutative join
  Hlu : left_id unit join
  ============================
   join t unit = t
]]

The first line of the proof demonstrates that dependent records in Coq
are actually just product types in disguise, so the proofs about them
should be done by case analysis. In this particular case, we decompose
the [pcm] argument of the lemma into its components, replacing those
of no interest with wildcards [_]. The [join] and [unit], therefore,
bind the operation and the identity element, whereas [Hc] and [Hlu]
are the commutativity and left-unit properties, named explicitly in
the scope of the proof. The trailing Ssreflect's simplification
tactical %\texttt{/=}\ssrtl{/=}% replaces the calls to the getters in
the goal (e.g., [join_op pcm]) by the bound identifiers. The proof can
be now accomplished by a series of rewritings by the [Hc] and [Hlu]
hypotheses.

*)

by rewrite Hc Hlu.
Qed.

(**

** An alternative definition

In the previous section we have seen how to define the algebraic
structure of PCMs using Coq's dependent record mechanism. The same PCM
structure could be alternatively defined using the familiar syntax for
inductive types, as a datatype with precisely one constructor:

*)

Inductive mixin_of' (T: Type) :=
  Mixin' (valid_op: T -> bool) (join_op : T -> T -> T) (unit_op: T) of
    commutative join_op &
    associative join_op &
    left_id unit_op join_op &
    forall x y, valid_op (join_op x y) -> valid_op x &
    valid_op unit_op.

(**

Although this definition seems more principled and is closer to what
we have seen in previous chapters, the record notation is more
convenient in this case, as it defined getters automatically as well
as allows one to express inheritance between data structures by means
of the coercion operator %\texttt{:>}%
operator%~\cite{Garillot-al:TPHOL09}%.%\footnote{In the next section
will show a different way to encode implicit inheritance, though.}%

** Packaging the structure from mixins
%\label{sec:packaging}%

*)

Section Packing.

(**

%\index{packaging}%

By now, we have defined a structure of a PCM "interface" in a form of
a set of the components (i.e., the carrier set and operations on it)
and their properties. However, it might be the case that the same
carrier set (which we represented by the type parameter [T]), should
be given properties from other algebraic data structures (e.g.,
lattices), which are essentially orthogonal to those of a
PCM. Moreover, at some point one might be interested in implementing
the proper inheritance of the PCM structure with respect to the
carrier type [T]. More precisely, if the type [T] comes with some
additional operations, they should be available from it, even if it's
seen as being "wrapped" into the PCM structure. That said, if [T] is
proven to be a PCM, one should be able to use this fact as well as the
functions, defined on [T] separately.

%\index{packed classes}%

These two problems, namely, (a) combining together several structures
into one, and (b) implementing inheritance and proper mix-in
composition, can be done in Coq using the description pattern, known
as "packed classes"%~\cite{Garillot-al:TPHOL09}%. The idea of the
approach is to define a "wrapper" record type, which would "pack"
several mix-ins together, similar to how it is done in object-oriented
languages with implicit trait composition, e.g.,
Scala%~\cite{Odersky-Zenger:OOPSLA05}%.%\footnote{Using this mechanism
will, however, afford us a greater degree of flexibility, as it is up
to the Coq programmer to define the resolution policy of the combined
record's members, rather than to rely on an implicit mechanism of
field linearization.}%

%\index{Scala}\index{traits}%
%\label{ref:pack_type}%
*)

Structure pack_type : Type := Pack {type : Type; _ : mixin_of type}.

(**

The dependent data structure [pack_type] declares two fields: the
field [type] of type [Type], which described the carrier type of the
PCM instance, and the actual PCM structure (without an explicit name
given) of type ([mixin_of type]). That is, in order to construct an
instance of [pack_type], one will have to provide _both_ arguments:
the carrier set and a PCM structure for it.

Next, we specify that the field [type] of the [pack_type] should be
also considered as a _coercion_, that is, whenever we have a value of
type [pack_type], whose field [type] is some [T], it can be implicitly
seen as an element of type [T]. The coercion is specified locally, so
it will work only in the scope of the current section (i.e.,
[Packing]) by using Coq's [Local Coercion] command. We address the
reader to Chapter 18 of the Coq Reference Manual%~\cite{Coq-manual}%
for more details of the implicit coercions.

%\ccom{Local Coercion}%
*)

Local Coercion type : pack_type >-> Sortclass.

(**

%\index{Sortclass@\emph{Sortclass}}%

The [>->] simply specifies the fact of the coercion, whereas
[Sortclass] is an abstract class of sorts, so the whole command
postulates that whenever an instance of [pack_type] should be coerced
into an element of an arbitrary sort, it should be done via referring
to is [type] field.

Next, in the same section, we provide a number of abbreviations to
simplify the work with the PCM packed structure and prepare it to be
exported by clients.

*)
Variable cT: pack_type.

Definition pcm_struct : mixin_of cT :=
    let: Pack _ c := cT return mixin_of cT in c.

(**

The function [pcm_struct] extracts the PCM structure from the "packed"
instance. Notice the use of dependent pattern matching
%\index{dependent pattern matching}% in the [let:]-statement with the
explicit [return]-statement, so Coq would be able to refine the result
of the whole expression basing on the dependent type of the [c]
component of the data structure [cT], which is being scrutinized. With
the help of this definition, we can now define three aliases for the
PCM's key components, "lifted" to the packed data structure.

*)

Definition valid := valid_op pcm_struct.
Definition join := join_op pcm_struct.
Definition unit := unit_op pcm_struct.

End Packing.

(**

Now, as the packaging mechanism and the aliases are properly defined,
we come to the last step of the PCM package description: preparing the
batch of definitions, notations and facts to be exported to the
client. Following the pattern of nesting modules, presented in
%Section~\ref{sec:secmod}%, we put all the entities to be exported
into the inner module [Exports].

*)

Module Exports.

Notation pcm := pack_type.
Notation PCMMixin := Mixin.
Notation PCM T m := (@Pack T m).

Notation "x \+ y" := (join x y) (at level 43, left associativity).
Notation valid := valid.
Notation Unit := unit.

(**

We will have to define the coercion from the PCM structure with
respect to its [type] field once again, as the previous one was
defined locally for the section [Packing], and, hence, is invisible in
this submodule.

*)

Coercion type : pack_type >-> Sortclass.

(**

* Properties of partial commutative monoids

Before we close the [Exports] module of the [PCMDef] package, it makes
sense to supply as many properties to the clients, as it will be
necessary for them to build the reasoning involving PCMs. In the
traditions of proper encapsulation, %\index{encapsulation}% requiring
to expose only the relevant and as abstract as possible elements of
the interface to its clients, it is undesirable for users of the [pcm]
datatype to perform any sort of analysis on the structure of the
[mixin_of] datatype, as it will lead to rather tedious and cumbersome
proofs, which will first become a subject of massive changes, once we
decide to change the implementation of the PCM mixin structure.

This is why in this section we supply a number of properties of PCM
elements and operations, derived from its structure, which we observe
to be enough to build the reasoning with arbitrary PCM instances.

*)

Section PCMLemmas.
Variable U : pcm.

(**

For instance, the following lemma re-establishes the commutativity of
the [\+] operation:

*)

Lemma joinC (x y : U) : x \+ y = y \+ x.
Proof.
by case: U x y=> tp [v j z Cj *]; apply Cj.
Qed.

(**

Notice that in order to make the proof to go through, we had to "push"
the PCM elements [x] and [y] to be the assumption of the goal before
case-analysing on [U]. This is due to the fact that the structure of
[U] affects the type of [x] and [y], therefore destructing it by means
of [case] would change the representation of [x] and [y] as well,
doing some rewriting and simplifications. Therefore, when [U] is being
decomposed, all values, whose type depends on it (i.e., [x] and [y])
should be in the scope of decomposition. The naming pattern $*$ helped
us to give automatic names to all remaining assumptions, appearing
from decomposition of [U]'s second component before moving it to the
context before finishing the proof by applying the commutativity
"field" [Cj].

*)

Lemma joinA (x y z : U) : x \+ (y \+ z) = x \+ y \+ z.
Proof.
by case: U x y z=>tp [v j z Cj Aj *]; apply: Aj.
Qed.

(**

%\begin{exercise}[PCM laws]%
Prove the rest of the PCM laws.

*)

Lemma joinAC (x y z : U) : x \+ y \+ z = x \+ z \+ y.
(* begin hide *)
Proof. by rewrite -joinA (joinC y) joinA. Qed.
(* end hide *)

Lemma joinCA (x y z : U) : x \+ (y \+ z) = y \+ (x \+ z).
(* begin hide *)
Proof. by rewrite joinA (joinC x) -joinA. Qed.
(* end hide *)

Lemma validL (x y : U) : valid (x \+ y) -> valid x.
(* begin hide *)
Proof. case: U x y=>tp [v j z Cj Aj Uj /= Mj inv f]; apply: Mj. Qed.
(* end hide *)

Lemma validR (x y : U) : valid (x \+ y) -> valid y.
(* begin hide *)
Proof. by rewrite joinC; apply: validL. Qed.
(* end hide *)

Lemma unitL (x : U) : (@Unit U) \+ x = x.
(* begin hide *)
Proof. by case: U x=>tp [v j z Cj Aj Uj *]; apply: Uj. Qed.
(* end hide *)

Lemma unitR (x : U) : x \+ (@Unit U) = x.
(* begin hide *)
Proof. by rewrite joinC unitL. Qed.
(* end hide *)

Lemma valid_unit : valid (@Unit U).
(* begin hide *)
Proof. by case: U=>tp [v j z Cj Aj Uj Vm Vu *]. Qed.
(* end hide *)

(**

%\end{exercise}%

*)

End PCMLemmas.

End Exports.

End PCMDef.

Export PCMDef.Exports.

(**

* Implementing inheritance hierarchies

%\index{inheritance}%

By packaging an arbitrary type [T] into one record with the PCM
structure in %Section~\ref{sec:packaging}% and supplying it with a
specific implicit coercion, we have already achieved some degree of
inheritance: any element of a PCM can be also perceived by the system
in an appropriate context, as an element of its carrier type.

In this section, we will go even further and show how to build
hierarchies of mathematical structures using the same way of encoding
inheritance. We will use a _cancellative PCM_ as a running example.

*)

Module CancelPCM.

(**

PCMs with cancellation %\index{cancellativity}% extend ordinary PCMs
with an extra property, that states that the equality $a \join b = a
\join c$ for any $a$, $b$ and $c$, whenever $a \join b$ is defined,
implies $b = c$. We express such property via an additional mixin
record type, parametrized over an arbitrary PCM [U].

*)

Record mixin_of (U : pcm) := Mixin {
  _ : forall a b c: U, valid (a \+ b) -> a \+ b = a \+ c -> b = c
}.

(**

Notice that the validity of the sum [a \+ c] is not imposed, as it can
be proven from propositional equality and the validity of [a \+ b].

We continue the definition by describing the standard packaging data
structure.

*)

Structure pack_type : Type := Pack {pcmT : pcm; _ : mixin_of pcmT}.

Module Exports.

Notation cancel_pcm := pack_type.
Notation CancelPCMMixin := Mixin.
Notation CancelPCM T m:= (@Pack T m).

(**

There is a tiny twist in the definition of the specific coercion,
though, as now we it specifies that the instance of the packed data
structure, describing the cancellative PCM, can be seen as an instance
of the underlying PCM. The coercions are transitive, which means that
the same instance can be coerced even further to [U]'s carrier type
[T].

*)

Coercion pcmT : pack_type >-> pcm.

(**

We finish the definition of the cancellative PCM by providing its only
important law, which is a direct consequence of the newly added
property.

*)

Lemma cancel (U: cancel_pcm) (x y z: U):
  valid (x \+ y) -> x \+ y = x \+ z -> y = z.
Proof.
by case: U x y z=>Up [Hc] x y z; apply: Hc.
Qed.

End Exports.
End CancelPCM.

Export CancelPCM.Exports.

(**

The proof of the following lemma, combining commutativity and
cancellativity, demonstrates how the properties of a cancellative PCM
work in combination with the properties of its base PCM structure.

*)

Lemma cancelC (U: cancel_pcm) (x y z : U) :
  valid (y \+ x \+ z) -> y \+ x = x \+ z -> y = z.
Proof.
by move/validL; rewrite ![y \+ _]joinC; apply: cancel.
Qed.

(**

* Instantiation and canonical structures

Now, as we have defined a PCM structure along with its specialized
version, a cancellative PCM, it is time to see how to _instantiate_
these abstract definitions with concrete datatypes, i.e., _prove_ the
latter ones to be instances of a PCM.

%\index{instantiation}%

** Defining arbitrary PCM instances

Natural numbers form a PCM, in particular, with addition as a join
operation and zero as a unit element. The validity predicate is
constant true, because the addition of two natural numbers is again a
valid natural number. Therefore, we can instantiate the PCM structure
for [nat] as follows, first by constructing the appropriate mixin.

*)

Definition natPCMMixin :=
  PCMMixin addnC addnA add0n (fun x y => @id true) (erefl _).

(**

The constructor [PCMMixin], defined in %Section~\ref{sec:packaging}%
is invoked with five parameters, all of which correspond to the
properties, ensured by the PCM definition. The rest of the arguments,
namely, the validity predicate, the join operation and the zero
element are implicit and are soundly inferred by Coq's type inference
engine from the types of lemmas, provided as propositional
arguments. For instance, the first argument [addnC], whose type is
[commutative addn] makes it possible to infer that the join operation
is the addition. In the same spirit, the third argument, [add0n] makes
it unambiguous that the unit element is zero.

After defining the PCM mixin, we can instantiate the PCM packed class
for [nat] by the following definition:

*)

Definition NatPCM := PCM nat natPCMMixin.

(**

This definition will indeed work, although, being somewhat
unsatisfactory. For example, assume we want to prove the following
lemma for natural numbers treated as elements of a PCM, which should
trivially follow from the PCM properties of [nat] with addition and
zero:

[[
Lemma add_perm (a b c : nat) : a \+ (b \+ c) = a \+ (c \+ b).
]]

[[
The term "a" has type "nat" while it is expected to have type "PCMDef.type ?135".
]]

This error is due to the fact that Coq is unable to recognize natural
numbers to be elements of the corresponding PCM, and one possible way
to fix it is to declare the parameters of the lemma [add_perm], [a],
[b] and [c] to be of type [NatPCM] rather than [nat]. This is still
awkward: it means that the lemmas cannot be just applied to mere
natural numbers, instead they need to be _coerced_ to the [NatPCM]
type explicitly whenever we need to apply this lemma. Coq suggests a
better solution to this problem by providing a mechanism of _canonical
structures_ as a flexible way to specify _how exactly_ each concrete
datatype should be embedded into an abstract mathematical
structure%~\cite{Saibi:PhD}%.

%\index{canonical structures}%

The Vernacular syntax for defining canonical structures is similar to
the one of definitions and makes use of the %\texttt{Canonical}%
command.%\footnote{The command \texttt{Canonical Structure}
\ccom{Canonical Structure} serves the same purpose.}\ccom{Canonical}%
The following definition defines [natPCM] to be a canonical instance
of the PCM structure for natural numbers.

*)

Canonical natPCM := PCM nat natPCMMixin.

(**

To see what kind of effect it takes, we will print all _canonical
projections_, currently available in the context of the module.

*)

Print Canonical Projections.

(**

[[
...
nat <- PCMDef.type ( natPCM )
pred_of_mem <- topred ( memPredType )
pred_of_simpl <- topred ( simplPredType )
sig <- sub_sort ( sig_subType )
number <- sub_sort ( number_subType )
...
]]

%\index{canonical projections}%
The displayed list enumerates all _canonical projections_ that specify,
which implicit canonical instances are currently available and will be
picked implicitly for appropriate types (on the left of the arrow
[<-]). That is, for example, whenever an instance of [nat] is
available, but in fact it should be treated as the [type] field of the
[PCM] structure (with all getters typed properly), the canonical
instance [natPCM] will be automatically picked by Coq for such
embedding. In other words, the machinery of canonical structures
allows us to define the policy for finding an appropriate _dictionary_
of functions and propositions for an arbitrary concrete datatype,
whenever it is supposed to have them. In fact, upon declaring the
canonical structure [natPCM], the canonical projections are
registered by Coq for all _named_ fields of the record [PCM], which is
precisely just the [type] field, since [PCM]'s second component of
type ([mixin_of type]) was left unnamed (see the definition of
the record [pack_type] on page%~\pageref{ref:pack_type}%).

The mechanism of defining canonical structures for concrete data types
is reminiscent of the resolution of type class constraints in
Haskell%~\cite{Wadler-Blott:POPL89}%. However, unlike Haskell, where
the resolution algorithm for type class instances is _hard-coded_, in
the case of Coq one can actually _program_ the way the canonical
instances are resolved.%\footnote{In addition to canonical structures,
Coq also provides mechanism of type classes, which are even more
reminiscent of the ones from Haskell, and, similar to the latter
ones, do not provide a way to program the resolution
policy~\cite{Sozeau-Oury:TPHOL08}.}% This leads to a very powerful
technique to automate the process of theorem proving by encoding the
way to find and apply necessary lemmas, whenever it is required. These
techniques are, however, outside of the scope of this course, so we
direct the interested reader to the relevant research papers that
describe the patterns of programming with canonical
structures%~\cite{Gontier-al:ICFP11,Mahboubi-Tassi:ITP13,Garillot:PhD}%.

Similarly to the way we have defined a canonical instance of PCM for
[nat], we can define a canonical instance of a PCM with
cancellativity. In order to instantiate it, we will, however, need to
prove the following lemma, which states that the addition on natural
numbers is indeed cancellative, so this fact will be used as an
argument for the [CancelPCMMixin] constructor.

*)

Lemma cancelNat : forall a b c: nat, true -> a + b = a + c -> b = c.
Proof.
move=> a b c; elim: a=>// n /(_ is_true_true) Hn _ H.
by apply: Hn; rewrite !addSn in H; move/eq_add_S: H.
Qed.

(**

Notice the first assumption [true] of the lemma. Here it serves as a
placeholder for the general validity hypothesis [valid (a \+ b)],
which is always [true] in the case of natural numbers.

*)

Definition cancelNatPCMMixin := CancelPCMMixin cancelNat.

Canonical cancelNatPCM := CancelPCM natPCM cancelNatPCMMixin.

(**

Let us now see the canonical instances in action, so we can prove a
number of lemmas about natural numbers employing the general PCM
machinery.

*)

Section PCMExamples.

(** %\label{pg:addnprops}% *)

Variables a b c: nat.

Goal a \+ (b \+ c) =  c \+ (b \+ a).
by rewrite joinA [c \+ _]joinC [b \+ _]joinC.
Qed.

(**

The next goal is proved by using the combined machinery of [PCM] and
[CancelPCM].

*)

Goal c \+ a = a \+ b -> c = b.
by rewrite [c \+ _]joinC; apply: cancel.
Qed.

(**

It might look a bit cumbersome, though, to write the PCM join
operation [\+] instead of the boolean addition when specifying the
facts about natural numbers (even though they are treated as elements
of the appropriate PCM). Unfortunately, it is not trivial to encode
the mechanism, which will perform such conversion implicitly. Even
though Coq is capable of figuring out what PCM is necessary for a
particular type (if the necessary canonical instance is defined),
e.g., when seeing [(a b : nat)] being used, it infers the [natPCM],
alas, it's not powerful enough to infer that by writing the
addition function [+] on natural numbers, we mean the PCM's
join. However, if necessary, in most of the cases the conversion like
this can be done by manual rewriting using the following trivial
"conversion" lemma.

*)

Lemma addn_join (x y: nat): x + y = x \+ y.
Proof. by []. Qed.

End PCMExamples.

(**
%\begin{exercise}[Partially ordered sets]%

%\index{partially ordered set}%

A partially ordered set order is a pair $(T, \pre)$, such that $T$ is
a set and $\pre$ is a (propositional) relation on $T$, such that

%
\begin{enumerate}
\item $\forall x \in T, x \pre x$ (reflexivity);

\item $\forall x, y \in T, x \pre y \wedge y \pre x \implies x = y$ (antisymmetry);

\item $\forall x, y, z \in T, x \pre y \wedge y \pre z \implies x \pre z$ (transitivity).
\end{enumerate}
%

%\noindent%
Implement a data structure for partially-ordered sets using mixins and
packed classes. Prove the following laws:

[[
Lemma poset_refl (x : T) : x <== x.
Lemma poset_asym (x y : T) : x <== y -> y <== x -> x = y.
Lemma poset_trans (y x z : T) : x <== y -> y <== z -> x <== z.
]]

%\end{exercise}%

%\begin{exercise}[Canonical instances of partially ordered sets]%

Provide canonical instances of partially ordered sets for the
following types:

- [nat] with [<=] as a partial order;
- [prod], whose components are partially-ordered sets;
- functions [A -> B], whose codomain (range) [B] is a partially
  ordered set.

In order to provide a canonical instance for functions, you will need
to assume and make use of the following axiom of functional
extensionality:

%\index{extensionality}%

*)

Axiom fext : forall A (B : A -> Type) (f1 f2 : forall x, B x),
               (forall x, f1 x = f2 x) -> f1 = f2.

(**
%\end{exercise}%

** Types with decidable equalities
%\index{decidable equality}%

When working with Ssreflect and its libraries, one will always come
across multiple canonical instances of a particularly important
dependent record type---a structure with decidable equality. As it has
been already demonstrated in %Section~\ref{sec:eqrefl}%, for concrete
datatypes, which enjoy the decidable boolean equality [(==)], the
"switch" to Coq's propositional equality and back can be done
seamlessly by means of using the view lemma [eqP], leveraging the
[reflect] predicate instance of the form [reflect (b1 = b2) (b1 ==
b2)].%\ssrd{reflect}% Let us now show how the decidable equality is
defined and instantiated.

The module [eqtype]%\ssrm{eqtype}% of Ssreflect's standard library
provides a definition of the equality mixin and packaged class of the
familiar shape, which, after some simplifications, boil to the
following ones:

[[
Module Equality.

Definition axiom T (e : rel T) := forall x y, reflect (x = y) (e x y).

Structure mixin_of T := Mixin {op : rel T; _ : axiom op}.
Structure type := Pack {sort; _ : mixin_of sort}.

...

Notation EqMixin := Mixin.
Notation EqType T m := Pack T m.

End Equality.
]]

That is, the mixin for equality is a dependent record, whose first
field is a relation [op] on a particular carrier type [T] (defined
internally as a function [T * T -> bool]), and the second argument is
a proof of the definition [axiom], which postulates that the relation
is in fact equivalent to propositional equality (which is
established by means of inhabiting the [reflect] predicate
instance). Therefore, in order to make a relation [op] to be a
decidable equality on [T], one needs to prove that, in fact, it is
equivalent to the standard, propositional equality.

Subsequently, Ssreflect libraries deliver the canonical instances of
the decidable equality structure to all commonly used concrete
datatypes. For example, the decidable equality for natural numbers is
implemented in the [ssrnat]%\ssrm{ssrnat}% module by the following
recursive function:%\footnote{Coq's %[{struct n}]% annotation
explicitly specifies, which of the two arguments should be considered
by the system as a decreasing one, so the recursion would be
well-founded and %[eqn]% would terminate.}%

[[
Fixpoint eqn m n {struct m} :=
  match m, n with
  | 0, 0 => true
  | m'.+1, n'.+1 => eqn m' n'
  | _, _ => false
  end.
]]

%\noindent%
The following lemma ensures that [eqn] correctly reflects the
propositional equality.

[[
Lemma eqnP : Equality.axiom eqn.
Proof.
move=> n m; apply: (iffP idP) => [ | <- ]; last by elim n.
by elim: n m => [ | n IHn] [| m ] //= /IHn ->.
Qed.
]]
%\ssrtl{//=}%

%\noindent%
Finally, the following two definitions establish the canonical instance
of the decidable equality for [nat], which can be used whenever
[ssrnat] is imported.

[[
Canonical nat_eqMixin := EqMixin eqnP.
Canonical nat_eqType := EqType nat nat_eqMixin.
]]

*)

(* begin hide *)
End DepRecords.
(* end hide *)