Require Import TraceSemantics.
Require Import Shape.
Require Import Compiler.

(* _____________________________________
               DEFINITIONS
   _____________________________________ *)

Reserved Notation "'LOW_NEQ' P '≁L' P'" (at level 40).
Inductive neq_progL : Target.program -> Target.program -> Prop :=
  | neqprogL : forall P P',
    (cprogram_terminates P /\ cprogram_diverges P')
      \/
    (cprogram_diverges P /\ cprogram_terminates P')
      ->
    (neq_progL P P')
  where "'LOW_NEQ' P '≁L' P'" := (neq_progL P P').

Reserved Notation "'HIGH_NEQ' P '≁H' P'" (at level 40).
Inductive neq_progH : Source.program -> Source.program -> Prop :=
  | neqprog : forall P P',
    (program_terminates P /\ program_diverges P')
      \/
    (program_diverges P /\ program_terminates P')
      ->
    (neq_progH P P')
  where "'HIGH_NEQ' P '≁H' P'" := (neq_progH P P').

(* If a[P↓] ≁L a[Q↓] we say that a distinguish the partial
   programs P↓ and Q↓. The same concept exists for ≁H *)

Lemma low_neq_symmetry :
  forall P Q,
  neq_progL P Q -> neq_progL Q P.
Proof.
  intros. inversion H. constructor.
  destruct H0.
  - right. apply and_comm. apply H0.
  - left. apply and_comm. apply H0.
Qed.

Lemma high_neq_symmetry :
  forall P Q,
  neq_progH P Q -> neq_progH Q P.
Proof.
  intros. inversion H. constructor.
  destruct H0.
  - right. apply and_comm. apply H0.
  - left. apply and_comm. apply H0.
Qed.

(* _____________________________________
           LEMMAS & PROPERTIES
   _____________________________________ *)

Lemma app_is_cons :
  forall {X:Type} a (l:list X), a::l = [a]++l.
Proof.
  intros. reflexivity.
Qed.

(* ------- Canonicalization ------- *)
(** Already proved **)
Lemma canonicalization :
  forall t s, wellformed_shape s ->
  forall P, (PROGRAM_SHAPE P ∈• s) ->
    (program_fully_defined s P) ->
    (in_Traces_p t (COMPILE_PROG P↓) s
      <->
     in_Traces_p (zetaC_t t) (COMPILE_PROG P↓) s).
Proof.
Admitted.

(* ------- Definability / Trace mappping algorithm ------- *)
(** An OCaml algorithm is available **)
Lemma definability :
  forall t g1 s, wellformed_shape s ->
    t = zetaC_t t /\ (exists p, (LL_PROGRAM_SHAPE p ∈• s) ->
    in_Traces_p (t++[Ext g1 ProgramOrigin]) p s)
      ->
    exists A,
    (CONTEXT_SHAPE A ∈∘ s) /\ (context_fully_defined s A) /\
    (* 1 *)
    in_Traces_a t (COMPILE_PROG A↓) s /\
    (* 2 *)
    ((g1 <> End) ->
    in_Traces_a (t++[Ext g1 ProgramOrigin]++[Ext End ContextOrigin])
      (COMPILE_PROG A↓) s) /\
    (* 3 *)
    forall g, ((zeta_gamma g) <> (zeta_gamma g1)) ->
      forall g',
      ~(in_Traces_a (t++[Ext g ProgramOrigin]++[Ext g' ContextOrigin])
        (COMPILE_PROG A↓) s).
Proof.
Admitted.

Definition structured_full_abstraction : Prop :=
  forall s, wellformed_shape s ->
  forall P Q,
    (PROGRAM_SHAPE P ∈• s) ->
    (PROGRAM_SHAPE Q ∈• s) ->
    (program_fully_defined s P) ->
    (program_fully_defined s Q) ->
    (exists a, (LL_CONTEXT_SHAPE a ∈∘ s) /\
       let ap := (LL_context_application a (COMPILE_PROG P↓)) in
       let aq := (LL_context_application a (COMPILE_PROG Q↓)) in
       LOW_NEQ ap ≁L aq)
    ->
    (exists A,
    let AP := (context_application A P) in
    let AQ := (context_application A Q) in
    (CONTEXT_SHAPE A ∈∘ s) /\ (context_fully_defined s A) ->
    HIGH_NEQ AP ≁H AQ).

(* Equal to the previous one by prenex normal form transformation *)
Definition structured_full_abstraction_aux
  (a : Target.program) (P Q : Source.partial_program)
  (s:shape) : Prop :=
    wellformed_shape s ->
    (PROGRAM_SHAPE P ∈• s) ->
    (PROGRAM_SHAPE Q ∈• s) ->
    (program_fully_defined s P) ->
    (program_fully_defined s Q) ->
    ((LL_CONTEXT_SHAPE a ∈∘ s) /\
       let ap := (LL_context_application a (COMPILE_PROG P↓)) in
       let aq := (LL_context_application a (COMPILE_PROG Q↓)) in
       LOW_NEQ ap ≁L aq)
    ->
    (exists A,
    let AP := (context_application A P) in
    let AQ := (context_application A Q) in
    (CONTEXT_SHAPE A ∈∘ s) /\ (context_fully_defined s A) ->
    HIGH_NEQ AP ≁H AQ).

Definition separate_compilation_correctness : Prop :=
  forall s, wellformed_shape s ->
  forall A P,
    (CONTEXT_SHAPE A ∈∘ s) ->
    (PROGRAM_SHAPE P ∈• s) ->
    program_fully_defined s P ->
    context_fully_defined s A ->
    (* 1 *)
    ((program_terminates (context_application A P)
    <-> cprogram_terminates (LL_context_application
    (COMPILE_PROG A↓) (COMPILE_PROG P↓)))
      /\
    (* 2 *)
    (program_diverges (context_application A P)
    <-> cprogram_diverges (LL_context_application
    (COMPILE_PROG A↓) (COMPILE_PROG P↓)))).

(* _____________________________________
   SECURE COMPARTMENTALIZING COMPILATION
            AND PROOFS OF LEMMAS
   _____________________________________ *)

Lemma shape_closed_under_compilation_program :
  forall s P, PROGRAM_SHAPE P ∈• s
  -> LL_PROGRAM_SHAPE (COMPILE_PROG P↓) ∈• s.
Proof.
Admitted.

Lemma shape_closed_under_compilation_context :
  forall s A, CONTEXT_SHAPE A ∈∘ s
  -> LL_CONTEXT_SHAPE (COMPILE_PROG A↓) ∈∘ s.
Proof.
Admitted.

Definition is_a_prefix_of (u:trace) (t:trace) : Prop :=
  exists v, u++v = t.

Definition is_longest_prefix_of (u:trace)
  (t:trace) (p: program) (s:shape) : Prop :=
  (is_a_prefix_of u t /\ in_Traces_p u p s) /\
  (forall v, is_a_prefix_of v t /\ in_Traces_p v p s ->
               is_a_prefix_of v u).

Hypothesis longest_prefix_of :
  trace -> program -> shape -> trace.

Hypothesis longest_prefix_of_spec :
  forall t p s,
    let u := longest_prefix_of t p s in
    (is_longest_prefix_of u t p s).

(* ---- Nothing can follows the terminal symbol ---- *)
Lemma action_post_terminaison :
  forall t a p s o,
  ~(in_Traces_p (t++[Ext End o]++[a]) p s).
Proof.
  intros. intro contra.
  destruct s as [Is comps].
  destruct p as [[Isp mem] E].
  unfold in_Traces_p in contra. destruct contra.
  inversion H.
  - symmetry in H3. apply app_eq_nil in H3.
    destruct H3. inversion H3.
  - symmetry in H0. apply app_eq_nil in H0.
    destruct H0. inversion H4.
  - symmetry in H0. apply app_eq_unit in H0.
    destruct H0. destruct H0. inversion H4.
    destruct H0. inversion H4.
  - symmetry in H0. rewrite app_is_cons in H0.
    rewrite app_assoc in H0.
    assert ([t0; u] = [t0]++[u]). reflexivity.
    rewrite H5 in H0. apply app_inj_tail in H0.
    destruct H0. apply app_eq_unit in H0.
    destruct H0; destruct H0; inversion H7.
    + rewrite H0 in H. rewrite app_nil_l in H.
      rewrite <- H9 in H1. rewrite <- H6 in H4.
      inversion H1. inversion H12.
      destruct (decode (fetch_mem C mem0 pc)).
      * destruct i; inversion H15.
      * inversion H15.
      * rewrite <- H14 in H4. inversion H4. inversion H20.
      * rewrite <- H16 in H4. inversion H4. inversion H21.
Qed.

(* ---- Compiled fully defined k yield canonical actions ---- *)
Lemma only_yield_canonical_actions_context :
  forall s A t,
    wellformed_shape s /\ CONTEXT_SHAPE A ∈∘ s ->
    context_fully_defined s A ->
    in_Traces_a t (COMPILE_PROG A↓) s ->
    t = zetaC_t t.
Proof.
Admitted.

Lemma only_yield_canonical_actions_program :
  forall s P t,
    wellformed_shape s /\ PROGRAM_SHAPE P ∈• s ->
    program_fully_defined s P ->
    in_Traces_p t (COMPILE_PROG P↓) s ->
    t = zetaP_t t.
Proof.
Admitted.

Definition is_turn_of_program (t:trace) (s:shape) :=
  match s with
  | (Is, comps) =>
    (In (Some main_cid) comps /\ ev (length t))
      \/
    (~(In (Some main_cid) comps) /\ ~(ev (length t)))
  end.

Lemma program_turn_lead_to_programs_origin :
  forall t p s,
  LL_PROGRAM_SHAPE p ∈• s ->
  is_turn_of_program t s ->
  in_Traces_p t p s ->
  (forall g o, in_Traces_p (t++[Ext g o]) p s ->
  o = ProgramOrigin).
Proof.
Admitted.

Lemma program_turn :
  forall t p s,
  LL_PROGRAM_SHAPE p ∈• s ->
  (exists g, in_Traces_p (t++[Ext g ProgramOrigin]) p s) ->
  is_turn_of_program t s.
Proof.
Admitted.

Lemma programs_turn_contradiction :
  forall t p s,
  is_turn_of_program t s ->
  (forall g, ~in_Traces_p (t++[Ext g ProgramOrigin]) p s) ->
  (forall Ea, ~in_Traces_p (t++Ea) p s).
Proof.
  intros. intro contra.
Admitted.

Lemma origin_repetition_contradiction :
  forall p t g g' o s,
  LL_PROGRAM_SHAPE p ∈• s ->
  ~in_Traces_p (t++[Ext g o]++[Ext g' o]) p s.
Proof.
Admitted.

Lemma zeta_preserves_turn :
  forall t s,
  is_turn_of_program t s <->
  is_turn_of_program (zetaC_t t) s.
Proof.
Admitted.

Lemma twolist_possibilities :
  forall {X:Type} (t u : X) (t' u' : list X),
  [t; u] = t' ++ u' ->
  (t' = [] /\ u' = [t]++[u]) \/
  (t' = [t]++[u] /\ u' = []) \/
  (t' = [t] /\ u' = [u]).
Proof.
  intros. generalize dependent u'.
  induction t'.
  - intros. left. split.
    + reflexivity.
    + rewrite app_nil_l in H. symmetry. apply H.
  - intros. induction u'.
    + simpl. right. left. split.
      * symmetry. rewrite app_nil_r in H. apply H.
      * reflexivity.
    + simpl in *. inversion H. symmetry in H2.
      apply app_eq_unit in H2. destruct H2.
      * right. right. destruct H0. rewrite H0.
        split. reflexivity. apply H2.
      * destruct H0. right. left.
        rewrite H0. split. reflexivity. apply H2.
Qed.

Lemma strict_prefix_continuation :
  forall tp ti s p,
  is_a_prefix_of tp ti -> tp <> ti ->
  in_Traces_p ti p s ->
  exists g o, is_a_prefix_of (tp++[Ext g o]) ti.
Proof.
  intros. unfold is_a_prefix_of in H.
  destruct H. destruct x.
  - rewrite app_nil_r in H. apply H0 in H. contradiction.
  - destruct a. rewrite app_is_cons in H.
    + exists e. exists o. unfold is_a_prefix_of.
      exists x. rewrite app_assoc in H. apply H.
    + destruct p as [[Isp mem] E]. destruct s as [Is comps].
      unfold in_Traces_p in H1. destruct H1.
      rewrite <- H in H1. rewrite app_is_cons in H1.
      inversion H1.
      * symmetry in H5. apply app_eq_nil in H5.
        destruct H5. inversion H5.
      * symmetry in H2. apply app_eq_nil in H2.
        destruct H2. inversion H6.
      * symmetry in H2. apply app_eq_unit in H2.
        destruct H2.
        { destruct H2. inversion H6. }
        { destruct H2. inversion H6. }
      * apply twolist_possibilities in H2.
        destruct H2.
        { destruct H2. rewrite H2 in H1.
          rewrite app_nil_l in H1. inversion H1.
          inversion H12. }
        { destruct H2. destruct H2. inversion H7.
          destruct H2. inversion H7. rewrite <- H9 in H6.
          inversion H6. }
Qed.

Lemma trace_sets_closed_under_prefix_program :
  forall t' t p s, (LL_PROGRAM_SHAPE p ∈• s) ->
    is_a_prefix_of t' t -> in_Traces_p t p s ->
    in_Traces_p t' p s.
Proof.
  intros.
  destruct p as [[Isp mem] E].
  destruct s as [Is comps].
  unfold is_a_prefix_of in H0.
  destruct H0 as [trace H_t].
  rewrite <- H_t in H1. unfold in_Traces_p in H1.
  destruct H1. inversion H0.
  - unfold in_Traces_p. exists o'.
    symmetry in H4. apply app_eq_nil in H4.
    destruct H4. rewrite H3. constructor.
  - unfold in_Traces_p. exists o'.
    symmetry in H1. apply app_eq_nil in H1.
    destruct H1. rewrite H1. constructor.
  - unfold in_Traces_p. exists o'.
    symmetry in H1. apply app_eq_unit in H1.
    destruct H1.
    + destruct H1. rewrite H1. constructor.
    + destruct H1. rewrite H1. constructor.
      rewrite H3. apply H4.
  - unfold in_Traces_p. apply twolist_possibilities in H1.
    destruct H1 as [H1 | H1].
    + exists o'. destruct H1. rewrite H1. constructor.
    + destruct H1.
      * exists x. destruct H1. rewrite H6 in H0.
        rewrite app_nil_r in H0. apply H0.
      * exists o'. destruct H1. rewrite H1.
        apply H2.
Qed.

Lemma trace_sets_closed_under_prefix_context :
  forall t' t a s, (LL_CONTEXT_SHAPE a ∈∘ s) ->
    is_a_prefix_of t' t -> in_Traces_a t a s ->
    in_Traces_p t' a s.
Proof.
  intros.
  destruct a as [[Isp mem] E].
  destruct s as [Is comps].
  unfold is_a_prefix_of in H0.
  destruct H0 as [trace H_t].
  rewrite <- H_t in H1. unfold in_Traces_a in H1.
  destruct H1. inversion H0.
  - unfold in_Traces_a. exists o'.
    symmetry in H4. apply app_eq_nil in H4.
    destruct H4. rewrite H3. constructor.
  - unfold in_Traces_a. exists o'.
    symmetry in H1. apply app_eq_nil in H1.
    destruct H1. rewrite H1. constructor.
  - unfold in_Traces_a. exists o'.
    symmetry in H1. apply app_eq_unit in H1.
    destruct H1.
    + destruct H1. rewrite H1. constructor.
    + destruct H1. rewrite H1. constructor.
      rewrite H3. apply H4.
  - unfold in_Traces_a. apply twolist_possibilities in H1.
    destruct H1 as [H1 | H1].
    + exists o'. destruct H1. rewrite H1. constructor.
    + destruct H1.
      * exists x. destruct H1. rewrite H6 in H0.
        rewrite app_nil_r in H0. apply H0.
      * exists o'. destruct H1. rewrite H1.
        apply H2.
Qed.

Lemma program_Ea_immuable_to_zeta:
  forall t g,
  zetaC_t (t ++ [Ext g ProgramOrigin]) =
  zetaC_t t ++ [Ext g ProgramOrigin].
Proof.
  intros.
  induction t.
  - simpl. reflexivity.
  - rewrite app_is_cons. rewrite <- app_assoc.
    destruct a; destruct o;
    simpl; rewrite IHt; reflexivity.
Qed.

Lemma clear_regs_aux_idempotent :
  forall l k n, clear_regs_aux l k n =
  clear_regs_aux (clear_regs_aux l k n) k n.
Proof.
  induction l.
  - auto.
  - intros k n. simpl.
    rewrite <- IHl. destruct (eq_nat_dec n k); auto.
Qed.

Lemma clear_regs_idempotent :
  forall l, clear_regs l = clear_regs (clear_regs l).
Proof.
  intros. unfold clear_regs.
  rewrite <- clear_regs_aux_idempotent. auto.
Qed.

Lemma zeta_gamma_idempotent :
  forall e,
  zeta_gamma e = zeta_gamma (zeta_gamma e).
Proof.
  intros. destruct e;
  try (simpl; rewrite <- clear_regs_idempotent; reflexivity).
  simpl. reflexivity.
Qed.

Lemma zetaC_t_linear :
  forall t1 t2,
    zetaC_t (t1++t2) = (zetaC_t t1) ++ (zetaC_t t2).
Proof.
  intros. induction t1.
  - simpl. reflexivity.
  - destruct a; destruct o; simpl;
    rewrite IHt1; reflexivity.
Qed.

Lemma zetaP_t_linear :
  forall t1 t2,
    zetaP_t (t1++t2) = (zetaP_t t1) ++ (zetaP_t t2).
Proof.
  intros. induction t1.
  - simpl. reflexivity.
  - destruct a; destruct o; simpl;
    rewrite IHt1; reflexivity.
Qed.

Lemma zetaC_t_idempotent :
  forall t, zetaC_t t = zetaC_t (zetaC_t t).
Proof.
  intros. induction t.
  - reflexivity.
  - destruct a; destruct o; simpl; try (reflexivity);
    try (rewrite <- zeta_gamma_idempotent);
    rewrite <- IHt; reflexivity.
Qed.

Lemma zeta_gamma_injective :
  forall g g',
  zeta_gamma g <> zeta_gamma g' -> g <> g'.
Proof.
  intros.
  intro contra.
  destruct g; destruct g'; simpl in H;
  try (inversion contra; rewrite H1 in H; rewrite H2 in H;
  rewrite H3 in H; destruct H; reflexivity).
  - inversion contra. rewrite H1 in H. destruct H. trivial.
  - apply H in contra. contradiction.
Qed.

Lemma zetaP_t_gamma_extraction :
  forall t1 g,
  zetaP_t (t1++[Ext g ProgramOrigin]) = t1 ++ [Ext g ProgramOrigin] ->
  zeta_gamma g = g.
Proof.
  intros.
  rewrite zetaP_t_linear in H.
  simpl in H. apply app_inj_tail in H.
  destruct H. inversion H0.
  rewrite <- zeta_gamma_idempotent.
  reflexivity.
Qed.

Theorem separate_compilation_correctness_proof :
  separate_compilation_correctness.
Proof.
Admitted.

(* We suppose that a[P↓] terminates and a[Q↓] diverges *)
Lemma structured_full_abstraction_aux_proof :
  forall a P Q s,
  let ap := (LL_context_application a COMPILE_PROG P↓) in
  let aq := (LL_context_application a COMPILE_PROG Q↓) in
  cprogram_terminates ap -> cprogram_diverges aq ->
  structured_full_abstraction_aux a P Q s.
Proof.
  unfold structured_full_abstraction_aux.
  intros a P Q s ap_terminates aq_diverges WF_s
    H_shP H_shQ H_PFD H_QFD.
  (* We consider a ∈∘ s distinguishing P ∈• s and Q ∈• s *)
  intros H_a. destruct H_a as [H_sha H_low_neq].
  inversion H_low_neq as [ap aq H_behavior ap_eq aq_eq].
  (* Goal : build a full-defined A ∈∘ s such that A[P] ≁ A[Q] *)
  (* We first apply trace decomposition *)
  assert (H_shq := H_shQ).
  apply shape_closed_under_compilation_program in H_shq.
  assert (H_shp := H_shP).
  apply shape_closed_under_compilation_program in H_shp.
  pose (trace_decomposition s (COMPILE_PROG P↓)
    H_shp a H_sha ap_terminates) as t_decomposition.
  destruct t_decomposition as [ti H_decomposition].
  (* We call tp the longest prefix of ti such that tp ∈ Tr•s(a) *)
  assert (exists tp, is_longest_prefix_of tp ti
    (COMPILE_PROG Q↓) s) as tp_exists.
  Case "Proof of existence of tp".
  { exists (longest_prefix_of ti (COMPILE_PROG Q↓) s).
    apply longest_prefix_of_spec. }
  destruct tp_exists as [tp H_tp].
  unfold is_longest_prefix_of in H_tp.
  destruct H_tp as [H_tp H_tp3].
  destruct H_tp as [H_tp H_tp2].
  unfold is_a_prefix_of in H_tp. inversion H_tp as [v H_prefix].
  assert (is_a_prefix_of tp ti) as H_tp1.
  { rewrite <- H_prefix. unfold is_a_prefix_of.
    exists v. reflexivity. }
  destruct H_decomposition as [t' [o]].
  destruct H as [H_tEnd H_tSets].
  destruct H_tSets as [H_tSets1 H_tSets2].
  (* We know that tp ∈ Tr∘s(P↓) ∩ Tr•s(a) *)
  assert ((in_Traces_p tp (COMPILE_PROG P↓) s)
       /\ (in_Traces_a tp a s)) as H_tp_in_Pa.
  Case "Proof of tp ∈ Tr∘s(P↓) ∩ Tr•s(a)".
  { split.
    apply (trace_sets_closed_under_prefix_program
      tp ti (COMPILE_PROG P↓) s H_shp H_tp1 H_tSets1).
    apply (trace_sets_closed_under_prefix_context
      tp ti a s H_sha H_tp1 H_tSets2). }
  (* tp is a strict prefix *)
  assert (tp <> ti) as strict_prefix.
  Case "Proof of distinction between tp and ti".
  { unfold not. intro contra.
    assert (in_Traces_p ti COMPILE_PROG Q ↓ s /\
      in_Traces_a ti a s) as H_and.
    { split. rewrite contra in H_tp2. apply H_tp2. apply H_tSets2. }
    assert ((forall (Ea : external_action) (o : origin),
      ~(in_Traces_p (ti ++ [Ext Ea o]) COMPILE_PROG Q ↓ s /\
      in_Traces_a (ti ++ [Ext Ea o]) a s))) as Hassert.
    { intros. intro contra_assert. destruct contra_assert.
      rewrite H_tEnd in H0. rewrite <- app_assoc in H0.
      apply action_post_terminaison in H0. contradiction. }
    pose (trace_composition ti s (COMPILE_PROG Q↓)
      H_shq a H_sha H_and Hassert) as t_composition.
    destruct t_composition as [t_compositionL t_compositionR].
    assert (cprogram_terminates
      (LL_context_application a COMPILE_PROG Q ↓)) as H_absurd.
    { apply t_compositionR. exists t'. exists o. apply H_tEnd. }
    assert (
      cprogram_terminates
        (LL_context_application a COMPILE_PROG Q ↓) /\
      cprogram_diverges
        (LL_context_application a COMPILE_PROG Q ↓))
      as absurd.
    split. apply H_absurd. apply aq_diverges.
    apply (LL_program_behavior_exclusion
      (LL_context_application a COMPILE_PROG Q ↓)) in absurd.
    contradiction. }
  (* There exists Ea such that tp.Ea such that tp.Ea
     is a prefix of ti *)
  assert (exists g1 o, is_a_prefix_of (tp++[Ext g1 o]) ti) as Ea_exists.
  { pose (strict_prefix_continuation tp ti s (COMPILE_PROG P↓)
      H_tp1 strict_prefix H_tSets1) as lemma.
    destruct lemma as [g1 [o_origin [H_prefix']]].
    exists g1. exists o_origin. unfold is_a_prefix_of.
    exists H_prefix'. apply H. }
  destruct Ea_exists as [g1 H_EaExists].
  destruct H_EaExists as [origin_Ea H_EaExists].
  remember [Ext g1 origin_Ea] as Ea.
  rename HeqEa into H_g1.
  (* Ea is a program action *)
  assert (origin_Ea = ProgramOrigin)
    as H_program_action.
  { destruct origin_Ea.
    (* Ea cannot be a context action *)
    pose (trace_extensibility tp s g1 (COMPILE_PROG Q↓)
    H_shq a H_sha) as t_extensibility.
    destruct t_extensibility as [t_ext1 t_ext2].
    assert (in_Traces_p tp COMPILE_PROG Q ↓ s /\
      in_Traces_a (tp ++ [Ext g1 ContextOrigin]) a s)
      as H_assert.
    { split. assumption. rewrite <- H_g1.
      apply (trace_sets_closed_under_prefix_context
        (tp++Ea) ti a s H_sha H_EaExists H_tSets2). }
    apply t_ext1 in H_assert.
    pose (H_tp3' := H_tp3).
    specialize (H_tp3' (tp ++ [Ext g1 ContextOrigin])).
    rewrite H_g1 in H_EaExists.
    specialize (H_tp3' (conj H_EaExists H_assert)).
    unfold is_a_prefix_of in H_tp3'. destruct H_tp3'.
    rewrite <- app_assoc in H.
    rewrite <- (app_nil_r tp) in H.
    assert ((tp ++ []) ++ [Ext g1 ContextOrigin] ++ x
      = tp ++ [Ext g1 ContextOrigin] ++ x) as H_a.
    { rewrite (app_nil_r tp). reflexivity. }
    rewrite H_a in H. clear H_a.
    apply app_inv_head in H. inversion H.
    (* Ea is a program action *)
    reflexivity. }
  rewrite H_program_action in H_g1.
  (* Let tc be the canonicalization of tp *)
  pose (tc := zetaC_t tp).
  (* tc is a trace of P↓ *)
  pose (canonicalization (tp++Ea) s WF_s P H_shP H_PFD)
    as H_canonicalization.
  destruct H_canonicalization as [H_canon1 H_canon2].
  assert (in_Traces_p (tp ++ Ea) COMPILE_PROG P ↓ s)
    as H_zeta.
  { apply (trace_sets_closed_under_prefix_program
      (tp++Ea) ti (COMPILE_PROG P↓) s H_shp H_EaExists
      H_tSets1). }
  apply H_canon1 in H_zeta.
  (* Use of the definability assumption to build A *)
  pose (definability tc g1 s) as H_definability.
  assert (tc = zetaC_t tc /\
    (exists p : program, LL_PROGRAM_SHAPE p ∈• s ->
    in_Traces_p (tc ++ [Ext g1 ProgramOrigin]) p s))
    as H_definability_premises.
  Case "Proof of premises of definability".
  { split.
    unfold tc. rewrite <- zetaC_t_idempotent. reflexivity.
    exists (COMPILE_PROG P↓). intros H_def. unfold tc.
    rewrite <- (program_Ea_immuable_to_zeta tp g1).
    rewrite <- H_g1. apply H_zeta. }
  specialize (H_definability WF_s H_definability_premises).
  destruct H_definability as
    [A [H_shA [H_AFD [H_def1 [H_def2 H_def3]]]]].
  assert (H_sha' := H_shA).
  apply shape_closed_under_compilation_context in H_sha'.
  (* Now, we want to show that A↓[P↓] terminates while
     A↓[Q↓] diverges with the A generated by definability *)
  (* We first prove that A↓[P↓] terminates *)
  assert (cprogram_terminates (LL_context_application
    (COMPILE_PROG A↓) (COMPILE_PROG P↓))) as AP_terminates.
  Case "that A↓[P↓] terminates".
  { destruct g1 eqn:HD_g1.
    SCase "g1 = ExtCall".
    { assert (ExtCall c p r <> ✓) as Hassert.
      intro contra. inversion contra.
      apply H_def2 in Hassert.
      rename Hassert into H_context_action.
      apply H_canon2 in H_zeta.
      rewrite H_g1 in H_zeta.
      (* Apply trace extensibility to P↓ *)
      pose (trace_extensibility
        (tc ++ [Ext (ExtCall c p r) ProgramOrigin]) s ✓
        (COMPILE_PROG P↓) H_shp (COMPILE_PROG A↓) H_sha')
        as t_extensibility.
      destruct t_extensibility as [t_ext1 t_ext2].
      assert (in_Traces_p
           (tc ++ [Ext (ExtCall c p r) ProgramOrigin])
           COMPILE_PROG P ↓ s /\
         in_Traces_a
           ((tc ++ [Ext (ExtCall c p r) ProgramOrigin]) ++
            [Ext ✓ ContextOrigin]) COMPILE_PROG A ↓ s)
      as ext_premise.
      { split.
        rewrite <- H_g1 in H_zeta. apply H_canon1 in H_zeta.
        rewrite H_g1 in H_zeta.
        rewrite program_Ea_immuable_to_zeta in H_zeta.
        apply H_zeta.
        rewrite <- app_assoc. apply H_context_action. }
      apply t_ext1 in ext_premise.
      (* Apply trace composition *)
      pose (trace_composition
        ((tc ++ [Ext (ExtCall c p r) ProgramOrigin]) ++
        [Ext ✓ ContextOrigin]) s (COMPILE_PROG P↓)
        H_shp (COMPILE_PROG A↓) H_sha')
        as t_composition.
      assert (in_Traces_p
        ((tc ++ [Ext (ExtCall c p r) ProgramOrigin]) ++
        [Ext ✓ ContextOrigin]) COMPILE_PROG P ↓ s /\
        in_Traces_a
        ((tc ++ [Ext (ExtCall c p r) ProgramOrigin]) ++
        [Ext ✓ ContextOrigin]) COMPILE_PROG A ↓ s)
        as t_composition_premise.
      { split. apply ext_premise.
        rewrite <- app_assoc. apply H_context_action. }
      specialize (t_composition t_composition_premise).
      assert ((forall (Ea : external_action) (o : origin),
        ~(in_Traces_p (((tc ++ [Ext (ExtCall c p r) ProgramOrigin]) ++
          [Ext ✓ ContextOrigin]) ++
          [Ext Ea o]) COMPILE_PROG P ↓ s /\
        in_Traces_a (((tc ++ [Ext (ExtCall c p r) ProgramOrigin]) ++
          [Ext ✓ ContextOrigin]) ++
          [Ext Ea o]) COMPILE_PROG A ↓ s)))
        as t_composition_premise'.
      { intros. intro contra_assert. destruct contra_assert.
        pose (action_post_terminaison
          (tc ++ [Ext (ExtCall c p r) ProgramOrigin])
          (Ext Ea0 o0) (COMPILE_PROG P↓) s ContextOrigin)
          as H_absurd.
        rewrite app_assoc in H_absurd.
        apply H_absurd in H. contradiction. }
      specialize (t_composition t_composition_premise').
      clear t_composition_premise; clear t_composition_premise'.
      destruct t_composition as [t_comp1 t_comp2].
      apply t_comp2.
      exists (tc ++ [Ext (ExtCall c p r) ProgramOrigin]).
      exists ContextOrigin. reflexivity. }
    SCase "g1 = ExtRet".
    { assert (ExtRet r <> ✓) as Hassert.
      intro contra. inversion contra.
      apply H_def2 in Hassert.
      rename Hassert into H_context_action.
      apply H_canon2 in H_zeta.
      rewrite H_g1 in H_zeta.
      (* Apply trace extensibility to P↓ *)
      pose (trace_extensibility
        (tc ++ [Ext (ExtRet r) ProgramOrigin]) s ✓
        (COMPILE_PROG P↓) H_shp (COMPILE_PROG A↓) H_sha')
        as t_extensibility.
      destruct t_extensibility as [t_ext1 t_ext2].
      assert (in_Traces_p
           (tc ++ [Ext (ExtRet r) ProgramOrigin])
           COMPILE_PROG P ↓ s /\
         in_Traces_a
           ((tc ++ [Ext (ExtRet r) ProgramOrigin]) ++
            [Ext ✓ ContextOrigin]) COMPILE_PROG A ↓ s)
      as ext_premise.
      { split.
        rewrite <- H_g1 in H_zeta. apply H_canon1 in H_zeta.
        rewrite H_g1 in H_zeta.
        rewrite program_Ea_immuable_to_zeta in H_zeta.
        apply H_zeta.
        rewrite <- app_assoc. apply H_context_action. }
      apply t_ext1 in ext_premise.
      (* Apply trace composition *)
      pose (trace_composition
        ((tc ++ [Ext (ExtRet r) ProgramOrigin]) ++
        [Ext ✓ ContextOrigin]) s (COMPILE_PROG P↓)
        H_shp (COMPILE_PROG A↓) H_sha')
        as t_composition.
      assert (in_Traces_p
        ((tc ++ [Ext (ExtRet r) ProgramOrigin]) ++
        [Ext ✓ ContextOrigin]) COMPILE_PROG P ↓ s /\
        in_Traces_a
        ((tc ++ [Ext (ExtRet r) ProgramOrigin]) ++
        [Ext ✓ ContextOrigin]) COMPILE_PROG A ↓ s)
        as t_composition_premise.
      { split. apply ext_premise.
        rewrite <- app_assoc. apply H_context_action. }
      specialize (t_composition t_composition_premise).
      assert ((forall (Ea : external_action) (o : origin),
        ~(in_Traces_p (((tc ++ [Ext (ExtRet r) ProgramOrigin]) ++
          [Ext ✓ ContextOrigin]) ++
          [Ext Ea o]) COMPILE_PROG P ↓ s /\
        in_Traces_a (((tc ++ [Ext (ExtRet r) ProgramOrigin]) ++
          [Ext ✓ ContextOrigin]) ++
          [Ext Ea o]) COMPILE_PROG A ↓ s)))
        as t_composition_premise'.
      { intros. intro contra_assert. destruct contra_assert.
        pose (action_post_terminaison
          (tc ++ [Ext (ExtRet r) ProgramOrigin])
          (Ext Ea0 o0) (COMPILE_PROG P↓) s ContextOrigin)
          as H_absurd.
        rewrite app_assoc in H_absurd.
        apply H_absurd in H. contradiction. }
      specialize (t_composition t_composition_premise').
      clear t_composition_premise; clear t_composition_premise'.
      destruct t_composition as [t_comp1 t_comp2].
      apply t_comp2.
      exists (tc ++ [Ext (ExtRet r) ProgramOrigin]).
      exists ContextOrigin. reflexivity. }
    SCase "g1 = ✓".
    { (* We apply trace extensibility to A↓ *)
      pose (trace_extensibility tc s g1 (COMPILE_PROG P↓)
        H_shp (COMPILE_PROG A↓) H_sha')
        as t_extensibility.
      destruct t_extensibility as [t_ext1 t_ext2].
      assert (in_Traces_a tc COMPILE_PROG A ↓ s /\
         in_Traces_p (tc ++ [Ext g1 ProgramOrigin])
         COMPILE_PROG P ↓ s) as H_conj.
      { split. apply H_def1. unfold tc.
        rewrite <- program_Ea_immuable_to_zeta.
        rewrite HD_g1. rewrite <- H_g1. apply H_zeta. }
      apply t_ext2 in H_conj.
      (* We apply trace composition *)
      pose (trace_composition (tc ++ Ea) s (COMPILE_PROG P↓)
        H_shp (COMPILE_PROG A↓) H_sha') as t_composition.
      assert (in_Traces_p (tc ++ Ea) COMPILE_PROG P ↓ s /\
        in_Traces_a (tc ++ Ea) COMPILE_PROG A ↓ s) as H_or.
      { split. unfold tc. rewrite H_g1.
        rewrite <- program_Ea_immuable_to_zeta.
        rewrite <- H_g1. apply H_zeta.
        rewrite H_g1. rewrite <- HD_g1. apply H_conj. }
      specialize (t_composition H_or); clear H_or.
      assert (forall (Ea0 : external_action) (o : origin),
        ~(in_Traces_p ((tc ++ Ea) ++ [Ext Ea0 o]) COMPILE_PROG P ↓ s /\
        in_Traces_a ((tc ++ Ea) ++ [Ext Ea0 o]) COMPILE_PROG A ↓ s))
        as H_premise.
      { intros. intro contra_assert. destruct contra_assert.
        rewrite H_g1 in H.
        pose (action_post_terminaison
          tc (Ext Ea0 o0) (COMPILE_PROG P↓) s ProgramOrigin)
          as H_absurd.
        rewrite app_assoc in H_absurd.
        apply H_absurd in H. contradiction. }
      specialize (t_composition H_premise); clear H_premise.
      destruct t_composition as [t_comp1 t_comp2].
      apply t_comp2. exists tc. exists ProgramOrigin.
      rewrite H_g1. reflexivity. }
  }
  (* Now we prove that A↓[Q↓] diverges *)
  assert (cprogram_diverges (LL_context_application
    (COMPILE_PROG A↓) (COMPILE_PROG Q↓))) as AQ_diverges.
  Case "that A↓[Q↓] diverges".
  { (* We deduce 3 things by canonicalization *)
    (* a *)
    assert (in_Traces_p tc (COMPILE_PROG Q↓) s) as canon_a.
    { unfold tc. apply canonicalization in H_tp2.
      apply H_tp2. apply WF_s. apply H_shQ. apply H_QFD. }
    (* b *)
    assert (in_Traces_p (zetaC_t (tp++[Ext End ProgramOrigin]))
     (COMPILE_PROG Q↓) s ->
     in_Traces_p (tp++[Ext End ProgramOrigin]) (COMPILE_PROG Q↓) s)
     as canon_b.
    { intro. apply canonicalization in H. apply H.
      apply WF_s. apply H_shQ. apply H_QFD. }
    (* c *)
    assert (in_Traces_p (zetaC_t (tp++[Ext g1 ProgramOrigin]))
     (COMPILE_PROG Q↓) s ->
     in_Traces_p (tp++[Ext g1 ProgramOrigin]) (COMPILE_PROG Q↓) s)
     as canon_c.
    { intro. apply canonicalization in H. apply H.
      apply WF_s. apply H_shQ. apply H_QFD. }
    (* We prove that Q↓ cannot perform (✓) *)
    assert (~(in_Traces_p (tc++[Ext ✓ ProgramOrigin])
      (COMPILE_PROG Q↓) s)) as cant_be_End.
    { intro contra. unfold tc in contra.
      rewrite <- program_Ea_immuable_to_zeta in contra.
      (* We use (b) *)
      apply canon_b in contra.
      (* We use trace extensibility *)
      pose (trace_extensibility tp s ✓ (COMPILE_PROG Q↓)
        H_shq a H_sha) as t_extensibility.
      destruct t_extensibility as [t_ext1 t_ext2].
      assert (in_Traces_a tp a s /\ in_Traces_p
        (tp ++ [Ext ✓ ProgramOrigin]) COMPILE_PROG Q ↓ s)
        as ext_premise.
      { split. destruct H_tp_in_Pa as [H_tp_in_Pa1 H_tp_in_Pa2].
        apply H_tp_in_Pa2. apply contra. }
      (* We use trace composition *)
      pose (trace_composition (tp ++ [Ext ✓ ProgramOrigin])
        s (COMPILE_PROG Q↓) H_shq a H_sha)
        as t_composition.
      assert (in_Traces_p (tp ++ [Ext ✓ ProgramOrigin])
        COMPILE_PROG Q ↓ s /\ in_Traces_a
        (tp ++ [Ext ✓ ProgramOrigin]) a s) as ext_premise'.
      { split. apply contra. apply t_ext2.
        split. apply (trace_sets_closed_under_prefix_context
        tp ti a s H_sha H_tp1 H_tSets2). apply contra. }
      specialize (t_composition ext_premise').
      assert ((forall (Ea : external_action) (o : origin),
        ~(in_Traces_p ((tp ++ [Ext ✓ ProgramOrigin]) ++
        [Ext Ea o]) COMPILE_PROG Q ↓ s /\ in_Traces_a
        ((tp ++ [Ext ✓ ProgramOrigin]) ++ [Ext Ea o]) a s)))
        as ext_premise''.
      { intros. intro contra_assert. destruct contra_assert.
        pose (action_post_terminaison
          tp (Ext Ea0 o0) (COMPILE_PROG Q↓) s ProgramOrigin)
          as H_absurd.
        rewrite app_assoc in H_absurd.
        apply H_absurd in H. contradiction. }
      specialize (t_composition ext_premise'').
      destruct t_composition as [t_comp1 t_comp2].
      (* We state that Q↓ terminates which is a contradiction *)
      assert (cprogram_terminates
        (LL_context_application a COMPILE_PROG Q ↓)) as absurd.
      { apply t_comp2. exists tp. exists ProgramOrigin. trivial. }
      assert (cprogram_terminates
        (LL_context_application a COMPILE_PROG Q ↓) /\
        cprogram_diverges
        (LL_context_application a COMPILE_PROG Q ↓)) as absurd'.
      { split. apply absurd. apply aq_diverges. }
      apply LL_program_behavior_exclusion in absurd'.
      contradiction.
    }
    (* We prove that Q↓ cannot perform (g1) *)
    assert (~(in_Traces_p (tc++[Ext g1 ProgramOrigin])
      (COMPILE_PROG Q↓) s)) as cant_be_g1.
    { intro contra. unfold tc in contra.
      rewrite <- program_Ea_immuable_to_zeta in contra.
      apply canon_c in contra.
      pose (H_tp3' := H_tp3).
      specialize (H_tp3' (tp ++ [Ext g1 ProgramOrigin])).
      rewrite H_g1 in H_EaExists.
      specialize (H_tp3' (conj H_EaExists contra)).
      unfold is_a_prefix_of in H_tp3'. destruct H_tp3'.
      rewrite <- app_assoc in H.
      rewrite <- (app_nil_r tp) in H.
      assert ((tp ++ []) ++ [Ext g1 ProgramOrigin] ++ x
        = tp ++ [Ext g1 ProgramOrigin] ++ x) as H_a.
      { rewrite (app_nil_r tp). reflexivity. }
      rewrite H_a in H. clear H_a.
      apply app_inv_head in H. inversion H. }
    (* We have now two useful hypothesis *)
    (* Either Q↓ produces an external action or it doesn't *)
    (* We use the excluded middle law of classical logic *)
    pose (excluded_middle
      (forall g, ~in_Traces_p (tc++[Ext g ProgramOrigin])
      (COMPILE_PROG Q↓) s)) as EX1.
    destruct EX1 as [EX1 | EX1].
    SCase "No external action produced by Q↓".
    { pose (trace_composition tc s (COMPILE_PROG Q↓) H_shq
        (COMPILE_PROG A↓) H_sha') as t_composition.
      assert (in_Traces_p tc COMPILE_PROG Q ↓ s /\
        in_Traces_a tc COMPILE_PROG A ↓ s) as comp_premise.
      { split; assumption. }
      assert ((forall (Ea : external_action) (o : origin),
         ~(in_Traces_p (tc ++ [Ext Ea o]) COMPILE_PROG Q ↓ s /\
         in_Traces_a (tc ++ [Ext Ea o]) COMPILE_PROG A ↓ s)))
          as comp_premise'.
      { intros. intro contra. destruct contra. destruct o0.
        - assert (is_turn_of_program tc s) as Ha.
          { apply H_canon2 in H_zeta. rewrite H_g1 in H_zeta.
            pose (program_turn tp (COMPILE_PROG P↓) s H_shp) as lemma.
            pose (zeta_preserves_turn tp s) as lemma2.
            destruct lemma2 as [lemma2 lemma2'].
            unfold tc. apply lemma2.
            apply lemma. exists g1. apply H_zeta.
          }
          pose (programs_turn_contradiction tc (COMPILE_PROG Q↓) s Ha
            EX1 [Ext Ea0 ContextOrigin]) as lemma.
          apply lemma in H. contradiction.
        - apply (EX1 Ea0) in H. contradiction. }
      specialize (t_composition comp_premise comp_premise').
      destruct t_composition as [t_comp1 t_comp2].
      apply contrapositive in t_comp1.
      apply cterminates_cdiverges_opposition in t_comp1.
      apply t_comp1. intro contra.
      destruct contra as [t_contra contra].
      destruct contra as [o_contra contra].
      (* We can't have a terminating action *)
      unfold tc in contra. rewrite H_g1 in H_zeta.
      rewrite program_Ea_immuable_to_zeta in H_zeta.
      rewrite contra in H_zeta. rewrite <- app_assoc in H_zeta.
      apply (action_post_terminaison t_contra (Ext g1 ProgramOrigin)
        (COMPILE_PROG P↓) s o_contra) in H_zeta.
      contradiction.
    }
    SCase "External action performed by Q↓".
    { apply not_forall_dist in EX1.
      destruct EX1 as [g EX1].
      apply (double_negation_elimination
        (in_Traces_p (tc ++ [Ext g ProgramOrigin])
          COMPILE_PROG Q ↓ s)) in EX1.
      (* Either the context produces an action or it doesn't *)
      pose (excluded_middle (forall g', ~in_Traces_a
        (tc++[Ext g ProgramOrigin]++[Ext g' ContextOrigin])
        (COMPILE_PROG A↓) s)) as EX2.
      destruct EX2 as [EX2 | EX2].
      SSCase "No external action produced by the context".
      { pose (trace_composition (tc ++ [Ext g ProgramOrigin])) as t_comp.
        specialize (t_comp s (COMPILE_PROG Q↓) H_shq).
        specialize (t_comp (COMPILE_PROG A↓) H_sha').
        assert (in_Traces_p (tc ++ [Ext g ProgramOrigin]) COMPILE_PROG Q ↓ s /\
          in_Traces_a (tc ++ [Ext g ProgramOrigin]) COMPILE_PROG A ↓ s) as t_comp_pre.
        { split.
          - apply EX1.
          - pose (trace_extensibility tc s g (COMPILE_PROG Q↓) H_shq
              (COMPILE_PROG A↓) H_sha') as t_ext.
            destruct t_ext as [t_ext1 t_ext2].
            clear t_ext1.
            specialize (t_ext2 (conj H_def1 EX1)).
            apply t_ext2.
        }
        specialize (t_comp t_comp_pre).
        destruct t_comp as [t_comp1 t_comp2].
        { intros Ea0 o0. intro contra. destruct contra.
          destruct o0.
          - rewrite <- app_assoc in H0. apply (EX2 Ea0) in H0.
            contradiction.
          - rewrite <- app_assoc in H.
            apply (origin_repetition_contradiction (COMPILE_PROG Q↓)
              tc g Ea0 ProgramOrigin s H_shq) in H.
            contradiction.
        }
        clear t_comp2.
        apply contrapositive in t_comp1.
        - apply cterminates_cdiverges_opposition in t_comp1.
          apply t_comp1.
        - intro contra. destruct contra as [t'' [o'' H_contra]].
          apply app_inj_tail in H_contra. destruct H_contra.
          inversion H0.
          rewrite H2 in EX1.
          apply cant_be_End in EX1.
          contradiction.
      }
      SSCase "External action produced by the context".
      { apply not_forall_dist in EX2.
        destruct EX2 as [g' EX2].
        apply (double_negation_elimination
          (in_Traces_a (tc ++ [Ext g ProgramOrigin] ++
          [Ext g' ContextOrigin]) (COMPILE_PROG A↓) s)) in EX2.
        specialize (H_def3 g).
        (* g = g1 or g <> g1 *)
        pose (excluded_middle (g = g1 \/ g = End)) as EX3.
        destruct EX3 as [EX3 | EX3].
        SSSCase "g = g1".
        { destruct EX3.
          - rewrite H in EX1. apply cant_be_g1 in EX1. contradiction.
          - rewrite H in EX2.
            apply (action_post_terminaison tc (Ext g' ContextOrigin)
              (COMPILE_PROG A↓) s ProgramOrigin) in EX2.
              contradiction.
        }
        SSSCase "g <> g1".
        { apply de_morgan_not_or_not' in EX3. destruct EX3.
          assert (g = zeta_gamma g /\ g1 = zeta_gamma g1) as Ha.
          { split.
            - pose (only_yield_canonical_actions_program s Q
                (tc ++ [Ext g ProgramOrigin]) (conj WF_s H_shQ)
                H_QFD EX1) as lemma.
              symmetry in lemma.
              apply zetaP_t_gamma_extraction in lemma.
              symmetry. apply lemma.
            - apply H_canon2 in H_zeta.
              rewrite H_g1 in H_zeta.
              pose (only_yield_canonical_actions_program s P
                (tp ++ [Ext g1 ProgramOrigin]) (conj WF_s H_shP) H_PFD H_zeta) as lemma.
              symmetry in lemma.
              apply zetaP_t_gamma_extraction in lemma.
              symmetry. apply lemma.
          }
          destruct Ha. rewrite H1 in H; rewrite H2 in H.
          specialize (H_def3 H g').
          apply H_def3 in EX2. contradiction.
        }
      }
    }
  }
  exists A. intros. constructor. left. split.
  pose (separate_compilation_correctness_proof) as CompCorrectP.
  unfold separate_compilation_correctness in CompCorrectP.
  specialize (CompCorrectP s WF_s A P H_shA H_shP H_PFD H_AFD).
  destruct CompCorrectP.
  apply H0 in AP_terminates. apply AP_terminates.
  pose (separate_compilation_correctness_proof) as CompCorrectQ.
  unfold separate_compilation_correctness in CompCorrectQ.
  specialize (CompCorrectQ s WF_s A Q H_shA H_shQ H_QFD H_AFD).
  destruct CompCorrectQ.
  apply H1 in AQ_diverges. apply AQ_diverges.
Qed.

Theorem structured_full_abstraction_proof :
  structured_full_abstraction.
Proof.
  unfold structured_full_abstraction.
  intros s WF_s P Q H_shP H_shQ H_PFD H_QFD.
  intro H_a. destruct H_a as [a [H_sha H_low_neq]].
  inversion H_low_neq as [ap aq H_behavior ap_eq aq_eq].
  destruct H_behavior as [H_behavior | H_behavior].
  - destruct H_behavior as [ap_terminates aq_diverges].
    pose (structured_full_abstraction_aux_proof a P Q
      s ap_terminates aq_diverges) as lemma.
    unfold structured_full_abstraction_aux in lemma.
    apply (lemma WF_s H_shP H_shQ H_PFD H_QFD (conj H_sha H_low_neq)).
  - destruct H_behavior as [ap_diverges aq_terminates].
    pose (structured_full_abstraction_aux_proof a Q P
      s aq_terminates ap_diverges) as lemma.
    unfold structured_full_abstraction_aux in lemma.
    specialize (lemma WF_s H_shQ H_shP H_QFD H_PFD).
    assert ((exists A : partial_program,
      CONTEXT_SHAPE A ∈∘ s /\ context_fully_defined s A ->
      HIGH_NEQ context_application A Q
      ≁H context_application A P)
        ->
    (exists A : partial_program,
      CONTEXT_SHAPE A ∈∘ s /\ context_fully_defined s A ->
      HIGH_NEQ context_application A P
      ≁H context_application A Q)) as H_assert.
    { intros HA. destruct HA as [A H].
      exists A. intros. apply H in H0.
      apply high_neq_symmetry. apply H0. }
    apply H_assert. apply lemma.
    split.
    + apply H_sha.
    + apply low_neq_symmetry. apply H_low_neq.
Qed.

Definition secure_compartmentalizing_compilation : Prop :=
  admit.

Lemma SCC_isomorphism :
  structured_full_abstraction ->
  secure_compartmentalizing_compilation.
Proof.
Admitted.

Theorem SCCProof :
  secure_compartmentalizing_compilation.
Proof.
  apply SCC_isomorphism.
  apply structured_full_abstraction_proof.
Qed.


Require Export Utf8_core.
Require Import HoTT HoTT.hit.Truncations Connectedness.
Require Import reflective_subuniverse modalities.

Set Universe Polymorphism.
Global Set Primitive Projections.
Set Implicit Arguments.

Local Open Scope path_scope.
Local Open Scope equiv_scope.
Local Open Scope type_scope.

(* Readability *)
Arguments trunc_arrow {H} {A} {B} {n} H0: simpl never.
Arguments trunc_sigma {A} {P} {n} H H0: simpl never.
Arguments istrunc_paths {A} {n} H x y: simpl never.

Section Reflective_Subuniverse_base_case.

  Context `{ua: Univalence}.
  Context `{fs: Funext}.

  Definition j (P:hProp) : hProp := BuildTruncType _ (~ ~P).
  Definition is_classical (P:hProp) : hProp := BuildTruncType _ ((j P) -> P).

  Definition Oj (P:hProp) : {P : hProp & is_classical P}.
    exists (j P). exact (λ X X0, X (λ X1, X1 X0)). Defined.

  Definition Oj_unit (P:hProp) : P -> (Oj P).1 := fun x k => k x.

  Definition Oj_equiv (P : TruncType -1) (Q : {T : TruncType -1 & is_classical T}) :
    (P -> Q.1) -> (Oj P).1 -> Q.1.
  Proof.
    intros f jp. apply (pr2 Q). intro notQ. unfold Oj in jp; simpl in jp.
    apply jp. intro p. exact (notQ (f p)).
  Defined.

  Definition subuniverse_Prop : subuniverse_struct -1.
  Proof.
    simple refine (Build_subuniverse_struct -1 is_classical Oj Oj_unit _).
    intros P Q.
    simple refine (isequiv_iff_hprop _ _).
    exact (Oj_equiv _).
  Defined.

  Definition modality_Prop : Modality -1.
    simple refine (Build_Modality _ subuniverse_Prop _).
    apply subuniverse_sigma. exact ua. exact fs.
    intros A B g; simpl in *.
    simple refine (exist _ _ _).
    intro z. apply (equiv_inv (IsEquiv := O_modal_equiv _ _ _)).
    Transparent O. cbn in *. Opaque O.
    intro nBz.
    apply z; intro a.
    specialize (g a).
    pose (f := Oj_unit ((B (Oj_unit A a))) g).
    unfold Oj in f; simpl in f.
    apply f.
    exact (transport (λ x, ~ (B x)) (path_ishprop (Oj_unit A a) z)^ nBz).

    intro a; simpl.
    simple refine (path_ishprop _ _).
  Defined.

  Definition islex_modality_Prop : IsLex modality_Prop.
    intros A x y [c cc]. simpl in *.
    apply (contr_inhabited_hprop).
    apply hprop_allpath.
    intros p q.
    apply path_forall; intro u.
    destruct (p u).
    Transparent O. cbn in *. Opaque O.
    intro p. apply p. simple refine (path_ishprop x y).
  Defined.

End Reflective_Subuniverse_base_case.

Section Formalization.

  (** In this section is the proof of Proposition 23, base case of the induction *)

  Context `{ua: Univalence}.
  Context `{fs: Funext}.

  Let OP := subuniverse_Prop.

  Let helper_trunc0 : forall (T:hSet), IsHSet (T -> subuniverse_Type OP).
  Proof.
    intro T. simple refine (trunc_arrow _).
    apply subuniverse_Type_is_TruncTypeSn.
    exact ua.
  Qed.

  Let helper_trunc1 : forall (T:hSet) (u: T -> subuniverse_Type OP),
      IsHSet (O OP (BuildhProp (Trunc (-1) {a:T & u = (λ t, O OP (BuildhProp (a = t)))}))).
  Proof.
    intros T u.
    apply trunc_succ. auto with typeclass_instances.
  Qed.

  Definition O0 : hSet -> hSet
    := λ T:hSet, @BuildhSet ({u: T -> subuniverse_Type OP & O OP (BuildhProp (Trunc (-1) {a:T & u = (λ t, O OP (BuildhProp (a = t)))}))}) (trunc_sigma (helper_trunc0 T) (helper_trunc1 T)).

  Definition OP_to_O0 (P:hProp)
    : O OP P -> O0 (BuildhSet P).
  Proof.
    intro nnp. simple refine (exist _ _ _).
    intro p.
    simple refine (Build_subuniverse_Type _ _ (BuildhProp Unit) _).
    revert nnp; apply O_rec; intro p.
    apply O_unit, tr. exists p.
    apply path_forall; intro x. cbn in *.
    apply unique_subuniverse; apply path_trunctype; cbn.
    apply equiv_iff_hprop.
    intro tt; apply O_unit; apply path_ishprop.
    intro t; exact tt.
  Defined.

  Definition O0_to_OP (P:hProp)
    : O0 (BuildhSet P) -> O OP P.
  Proof.
    intros [u p].
    revert p; apply O_rec; apply Trunc_rec.
    intros [a q]. exact (O_unit OP P a).
  Defined.

  Definition equiv_OP_O0 (P:hProp)
    : O OP P <~> O0 (BuildhSet P).
  Proof.
    simple refine (equiv_iff_hprop (@OP_to_O0 P) (@O0_to_OP P)).
    (** Here should be the proof that [O0] defines a modality, combined with [hprop_stability] *)
  Admitted.

End Formalization.


(* ******************************************************************************* *)
(** * Bicategories
    Benedikt Ahrens, Marco Maggesi
    February 2018

 Displayed bicategory of contravariant functors into a fixed category K.
 ********************************************************************************* *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.AdjointUnique.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions.
Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.

Local Open Scope cat.
Local Open Scope bicategory_scope.

Section fix_a_category.
  Local Notation "∁" := bicat_of_univ_cats.

  Variable (K : univalent_category).

  Definition disp_presheaf_cat_ob_mor : disp_cat_ob_mor ∁.
  Proof.
    use tpair.
    + exact (λ c : univalent_category, functor (op_unicat c) K).
    + cbn. intros c d ty ty' f.
      exact (nat_trans ty (functor_composite (functor_opp f) ty')).
  Defined.

  Definition disp_presheaf_cat_data : disp_cat_data ∁.
  Proof.
    exists disp_presheaf_cat_ob_mor.
    use tpair.
    + intros c f.
      set (T:= nat_trans_id (pr1 f) ).
      exact T.
    + intros c d e f g ty ty' ty''.
      intros x y.
      set (T1 := x).
      set (T2 := @pre_whisker
                   (op_unicat c) (op_unicat d) K
                   (functor_opp f) _ _ (y : nat_trans (ty': functor _ _ )  _  )).
      exact (@nat_trans_comp (op_unicat c) K _ _ _ T1 T2 ).
  Defined.

  Definition disp_presheaf_prebicat_1_id_comp_cells : disp_prebicat_1_id_comp_cells bicat_of_univ_cats.
  Proof.
    exists disp_presheaf_cat_data.
    intros c d f g a.
    intros p p'.
    intros x y.
    exact (x = @nat_trans_comp (op_unicat c) K _  _ _ y (post_whisker (op_nt a) p')).
  Defined.

  Definition disp_presheaf_prebicat_ops : disp_prebicat_ops disp_presheaf_prebicat_1_id_comp_cells.
  Proof.
    repeat split; cbn.
    - intros. apply nat_trans_eq; try apply (homset_property K); cbn.
      intro. rewrite (functor_id y). apply pathsinv0, id_right.
    - intros. apply nat_trans_eq; try apply (homset_property K); cbn.
      intro.  rewrite (functor_id y). rewrite id_left, id_right. apply idpath.
    - intros. apply nat_trans_eq; try apply (homset_property K); cbn.
      intro. rewrite (functor_id y). apply idpath.
    - intros. apply nat_trans_eq; try apply (homset_property K); cbn.
      intro. rewrite (functor_id y). rewrite id_left, id_right. apply idpath.
    - intros. apply nat_trans_eq; try apply (homset_property K); cbn.
      intro. rewrite (functor_id y). repeat rewrite id_right. apply idpath.
    - intros. apply nat_trans_eq; try apply (homset_property K); cbn.
      intro. rewrite (functor_id z). rewrite id_right. apply pathsinv0, assoc.
    - intros. apply nat_trans_eq; try apply (homset_property K); cbn.
      intro. rewrite (functor_id z). rewrite id_right. apply assoc.
    - intros. apply nat_trans_eq; try apply (homset_property K).
      intro.
      rewrite X. rewrite X0.
      cbn.
      pose (T:= @functor_comp (op_cat b) _ y).
      rewrite <- assoc.
      rewrite <- T.
      apply idpath.
    - intros. apply nat_trans_eq; try apply (homset_property K); cbn.
      rewrite X.
      intro. apply assoc.
    - intros. apply nat_trans_eq; try apply (homset_property K); cbn.
      rewrite X.
      intros. cbn.
      pose (T:= nat_trans_ax gg).
      cbn in T.
      rewrite <- assoc.
      rewrite T.
      apply assoc.
  Qed.

  Definition disp_presheaf_prebicat_data : disp_prebicat_data ∁
    := _ ,,  disp_presheaf_prebicat_ops.

  Lemma disp_presheaf_prebicat_laws : disp_prebicat_laws disp_presheaf_prebicat_data.
  Proof.
    repeat split; intro;
      intros;
      apply isaset_nat_trans; apply homset_property.
  Qed.

  Definition disp_presheaf_prebicat : disp_prebicat ∁ :=
    (disp_presheaf_prebicat_data,, disp_presheaf_prebicat_laws).

  Lemma has_disp_cellset_disp_presheaf_prebicat
    : has_disp_cellset disp_presheaf_prebicat.
  Proof.
    red. intros.
    unfold disp_2cells.
    cbn.
    apply isasetaprop.
    cbn in *.
    apply isaset_nat_trans.
    apply homset_property.
  Qed.

  Definition disp_presheaf_bicat : disp_bicat ∁
    := (disp_presheaf_prebicat,, has_disp_cellset_disp_presheaf_prebicat).

  Definition disp_presheaves_all_invertible
             {C D : ∁}
             {F G : ∁⟦C, D⟧}
             (α : invertible_2cell F G)
             {CD : disp_presheaf_bicat C}
             {FC : disp_presheaf_bicat D}
             {γF : CD -->[ F] FC}
             {γG : CD -->[ G ] FC}
             (p : disp_2cells α γF γG)
    : is_disp_invertible_2cell α p.
  Proof.
    use tpair.
    - apply nat_trans_eq.
      { apply homset_property. }
      intro x.
      refine (!_).
      refine (maponpaths (λ z, z · _) (nat_trans_eq_pointwise p x) @ _).
      refine (!(assoc _ _ _) @ _).
      refine (maponpaths (λ z, _ · z) (!(functor_comp FC _ _)) @ _).
      etrans.
      {
        do 2 apply maponpaths.
        exact (nat_trans_eq_pointwise (pr222 α) x).
      }
      etrans.
      {
        apply maponpaths.
        apply (functor_id FC).
      }
      apply id_right.
    - split ; apply isaset_nat_trans ; apply homset_property.
  Qed.

  Definition disp_presheaves_is_univalent_2_1
    : disp_univalent_2_1 disp_presheaf_bicat.
  Proof.
    apply fiberwise_local_univalent_is_univalent_2_1.
    intros C D F CD FC α β.
    use isweqimplimpl.
    - intro p ; cbn in *.
      apply nat_trans_eq.
      { apply homset_property. }
      intro x.
      pose (nat_trans_eq_pointwise (pr1 p) x) as q.
      cbn in q.
      rewrite q.
      rewrite (functor_id FC), id_right.
      reflexivity.
    - apply isaset_nat_trans.
      apply homset_property.
    - apply isofhleveltotal2.
      + apply isaset_nat_trans.
        apply homset_property.
      + intro.
        apply isaprop_is_disp_invertible_2cell.
  Qed.

  Definition disp_presheaves_adjequiv
             {C : ∁}
             (FC FC' : disp_presheaf_bicat C)
    : @invertible_2cell bicat_of_univ_cats _ _ FC FC'
      -> disp_adjoint_equivalence (internal_adjoint_equivalence_identity C) FC FC'.
  Proof.
    intros α.
    use tpair.
    - apply α.
    - use tpair.
      + use tpair.
        * apply α.
        * split ; apply nat_trans_eq ; try (apply homset_property) ; intro x ; cbn.
          ** rewrite (functor_id FC), id_right.
             exact (!(nat_trans_eq_pointwise (pr122 α) x)).
          ** rewrite (functor_id FC'), id_left.
             exact (nat_trans_eq_pointwise (pr222 α) x).
      + split ; split.
        * apply isaset_nat_trans.
          apply homset_property.
        * apply isaset_nat_trans.
          apply homset_property.
        * apply disp_presheaves_all_invertible.
        * apply disp_presheaves_all_invertible.
  Defined.

  Definition disp_presheaves_adjequiv_inv
             {C : ∁}
             (FC FC' : disp_presheaf_bicat C)
    : disp_adjoint_equivalence (internal_adjoint_equivalence_identity C) FC FC'
      → @invertible_2cell bicat_of_univ_cats _ _ FC FC'.
  Proof.
    intros α.
    use tpair.
    - apply α.
    - use tpair.
      + apply α.
      + split.
        * apply nat_trans_eq.
          { apply homset_property. }
          intro x ; cbn.
          pose (nat_trans_eq_pointwise (pr1(pr212 α)) x) as p.
          cbn in p.
          rewrite (functor_id FC), id_right in p.
          exact (!p).
        * apply nat_trans_eq.
          { apply homset_property. }
          intro x ; cbn.
          pose (nat_trans_eq_pointwise (pr2(pr212 α)) x) as p.
          cbn in p.
          rewrite (functor_id FC'), id_right in p.
          exact p.
  Defined.

  Definition disp_presheaves_adjequiv_weq
             {C : ∁}
             (FC FC' : disp_presheaf_bicat C)
    : @invertible_2cell bicat_of_univ_cats _ _ FC FC'
      ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity C) FC FC'.
  Proof.
    exists (disp_presheaves_adjequiv FC FC').
    use isweq_iso.
    - exact (disp_presheaves_adjequiv_inv FC FC').
    - intro x.
      apply subtypePath.
      { intro ; apply isaprop_is_invertible_2cell. }
      reflexivity.
    - intro x.
      apply subtypePath.
      {
        intro.
        apply isaprop_disp_left_adjoint_equivalence.
        + apply univalent_cat_is_univalent_2_1.
        + apply disp_presheaves_is_univalent_2_1.
      }
      reflexivity.
  Defined.

  Definition disp_presheaves_idtoiso_2_0
             {C : ∁}
             (FC FC' : disp_presheaf_bicat C)
    : FC = FC' ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity C) FC FC'
    := ((disp_presheaves_adjequiv_weq FC FC')
          ∘ (make_weq (@idtoiso_2_1 bicat_of_univ_cats _ _ FC FC')
                     (univalent_cat_is_univalent_2_1 _ _ _ _)))%weq.

  Definition disp_presheaves_is_univalent_2_0
    : disp_univalent_2_0 disp_presheaf_bicat.
  Proof.
    apply fiberwise_univalent_2_0_to_disp_univalent_2_0.
    intros C FC FC'.
    use weqhomot.
    - exact (disp_presheaves_idtoiso_2_0 FC FC').
    - intro p.
      apply subtypePath.
      {
        intro.
        apply isaprop_disp_left_adjoint_equivalence.
        + apply univalent_cat_is_univalent_2_1.
        + apply disp_presheaves_is_univalent_2_1.
      }
      induction p ; cbn.
      reflexivity.
  Defined.

  Definition disp_presheaves_is_univalent_2
    : disp_univalent_2 disp_presheaf_bicat.
  Proof.
    split.
    - exact disp_presheaves_is_univalent_2_0.
    - exact disp_presheaves_is_univalent_2_1.
  Defined.

  Definition disp_2cells_isaprop_presheaf
    : disp_2cells_isaprop disp_presheaf_bicat.
  Proof.
    intro; intros.
    apply isaset_nat_trans.
    apply homset_property.
  Qed.

  Definition disp_locally_groupoid_presheaf
    : disp_locally_groupoid disp_presheaf_bicat.
  Proof.
    intro; intros.
    apply disp_presheaves_all_invertible.
  Qed.
End fix_a_category.


(** * Modularity in a fibration setting

The main result of this file is described here.

Let D be a fibration (ie, a cleaving in the displayed category setting)
over a category C such that the projection functor is faithful.

Then the projection functor lifts equalizers.

We also prove the dual statement (opfibration and coequalizers)

 *)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.limits.pushouts.
Require Import UniMath.CategoryTheory.limits.initial.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.graphs.equalizers.
Require Import UniMath.CategoryTheory.limits.graphs.coequalizers.

Require Import Modules.Prelims.Opfibration.

Open Scope cat.

Section pr.
  Context {C : category} (D : disp_cat C).

  (** This is a fibration *)
  Context   (cl : cleaving D).
  (** The fibration is faithful
This can be reformulated as [faithful pr1_category) as in [faithful_pr1_category]
   *)
  Hypothesis (faithful_fibration : faithful (pr1_category D)).
  (** Yet another formulation *)
  Lemma faithful_reformulated {x y} (f g : total_category D ⟦ x, y ⟧) : pr1 f = pr1 g -> f = g.
  Proof.
    eapply invmaponpathsincl.
    eapply faithful_fibration.
  Qed.

  Lemma faithful_fibration_equalizer {a b} (f g : total_category D⟦a, b⟧)
        ( eq  : Equalizer _ (# (pr1_category D) f)%cat (# (pr1_category D) g))
        : Equalizer _ f g.
  Proof.
    use make_Equalizer.
    - refine (EqualizerObject _ eq ,, _).
      eapply (cleaving_ob cl ).
      + apply EqualizerArrow.
      + exact (pr2 a).
    - refine (EqualizerArrow _ _ ,, _).
      apply cleaving_mor.
    - apply faithful_reformulated.
      cbn.
      apply EqualizerArrowEq.
    - use make_isEqualizer.
      + intros e h' eqh'.
        assert (h := EqualizerArrowComm _ eq _ _ (base_paths _ _ eqh')).
        set (ar_base := EqualizerIn  _ eq _ _ (base_paths _ _ eqh')) in h.
        use unique_exists.
        * refine (ar_base ,, _).
          cbn.
          eapply cartesian_factorisation.
          -- use cartesian_lift_is_cartesian.
          -- generalize (pr2 h').
             apply transportb.
             exact h.
        * cbn.
          apply subtypePairEquality'.
          --  exact h.
          --  apply invproofirrelevance.
              intros u v.
              apply pair_inj.
              ++ apply homset_property.
              ++ apply faithful_reformulated.
                 apply idpath.
        * cbn -[isaprop].
          intro y.
          apply (homset_property (total_category D)).
        *
          intros h'2 eqh'2.
          apply faithful_reformulated.
          cbn.
          apply EqualizerInUnique.
          apply base_paths in  eqh'2.
          exact eqh'2.
  Defined.
End pr.

Section oppr.
  Context {C : category} (D : disp_cat C).

  (** This is a opfibration *)
  Context   (cl : opcleaving D).
  (** The opfibration is faithful
This can be reformulated as [faithful pr1_category) as in [faithful_pr1_category]
   *)
  Hypothesis (faithful_opfibration : faithful (pr1_category D)).

  Local Notation faithful_reformulated := (faithful_reformulated  D  faithful_opfibration).

  Lemma faithful_opfibration_coequalizer {a b} (f g : total_category D⟦a, b⟧)
        ( eq  : Coequalizer _ (# (pr1_category D) f)%cat (# (pr1_category D) g))
        : Coequalizer _ f g.
  Proof.
    use make_Coequalizer.
    - refine (CoequalizerObject _ eq ,, _).
      eapply (opcleaving_ob cl ).
      + apply CoequalizerArrow.
      + exact (pr2 b).
    - refine (CoequalizerArrow _ _ ,, _).
      apply opcleaving_mor.
    - apply faithful_reformulated.
      cbn.
      apply CoequalizerArrowEq.
    - use make_isCoequalizer.
      + intros e h' eqh'.
        assert (h := CoequalizerArrowComm _ eq _ _ (base_paths _ _ eqh')).
        set (ar_base := CoequalizerOut  _ eq _ _ (base_paths _ _ eqh')) in h.
        use unique_exists.
        * refine (ar_base ,, _).
          cbn.
          eapply cocartesian_factorisation.
          -- use cocartesian_lift_is_cocartesian.
          -- generalize (pr2 h').
             apply transportb.
             exact h.
        * cbn.
          apply subtypePairEquality'.
          --  exact h.
          --  apply invproofirrelevance.
              intros u v.
              apply pair_inj.
              ++ apply homset_property.
              ++ apply faithful_reformulated.
                 apply idpath.
        * cbn -[isaprop].
          intro y.
          apply (homset_property (total_category D)).
        *
          intros h'2 eqh'2.
          apply faithful_reformulated.
          cbn.
          apply CoequalizerOutUnique.
          apply base_paths in  eqh'2.
          exact eqh'2.
  Defined.
End oppr.


(** * Bicolano: Number axiomatisation *)
(* Hendra : added ``not'' *)

Require Export ZArith.
Require Export Bool.

(** Common interface for numerics domains *)
Open Local Scope Z_scope.
(** Taken form CompCert project *)

 Module Type NUMERIC.
  Parameter t : Set.
  Parameter power : nat.
  Parameter toZ : t -> Z.

  Parameter add : t -> t -> t.
  Parameter sub : t -> t -> t.
  Parameter mul : t -> t -> t.
  Parameter div : t -> t -> t.
  Parameter rem : t -> t -> t.
  Parameter shr : t -> t -> t.
  Parameter shl : t -> t -> t.
  Parameter ushr : t -> t -> t.
  Parameter and : t -> t -> t.
  Parameter or : t -> t -> t.
  Parameter xor : t -> t -> t.
  Parameter neg : t -> t.
  Parameter not : t -> t.
  Parameter const : Z -> t.

 End NUMERIC.

 Module Type NUMSIZE.
  Parameter power : nat.
 End NUMSIZE.

 Module Make (S:NUMSIZE) <: NUMERIC.

  Definition modulus : Z := two_power_nat S.power.
  Definition half_modulus : Z := modulus / 2.

  Record t_: Set := mkint { intval: Z; intrange: 0 <= intval < modulus }.
  Definition t : Set := t_.

  Definition power := S.power.

  Definition unsigned (n: t) : Z := intval n.

  Definition signed (n: t) : Z :=
    if Zlt_bool (unsigned n) half_modulus
      then unsigned n
      else unsigned n - modulus.

  Definition toZ : t -> Z := signed.

  Lemma two_power_nat_O : two_power_nat O = 1.
  Proof. reflexivity. Qed.

  Lemma two_power_nat_pos : forall n : nat, two_power_nat n > 0.
  Proof.
    induction n. rewrite two_power_nat_O. omega.
    rewrite two_power_nat_S. omega.
  Qed.

  Lemma mod_in_range:
    forall x, 0 <= Zmod x modulus < modulus.
  Proof.
    intro.
    exact (Z_mod_lt x modulus (two_power_nat_pos power)).
  Qed.

  Definition repr (x: Z) : t :=
    mkint (Zmod x modulus) (mod_in_range x).

  Definition add (x y: t) : t :=
    repr (unsigned x + unsigned y).
  Definition sub (x y: t) : t :=
    repr (unsigned x - unsigned y).
  Definition mul (x y: t) : t :=
    repr (unsigned x * unsigned y).

  Definition Zdiv_round (x y: Z) : Z :=
    if Zlt_bool x 0 then
      if Zlt_bool y 0 then (-x) / (-y) else - ((-x) / y)
      else
        if Zlt_bool y 0 then -(x / (-y)) else x / y.
  Definition Zmod_round (x y: Z) : Z :=
    x - (Zdiv_round x y) * y.

  Definition div (x y: t) : t :=
    repr (Zdiv_round (signed x) (signed y)).
  Definition rem (x y: t) : t :=
    repr (Zmod_round (signed x) (signed y)).

  Definition Z_bin_decomp (x: Z) : bool * Z :=
    match x with
      | Z0 => (false, 0)
      | Zpos p =>
        match p with
          | xI q => (true, Zpos q)
          | xO q => (false, Zpos q)
          | xH => (true, 0)
        end
      | Zneg p =>
        match p with
          | xI q => (true, Zneg q - 1)
          | xO q => (false, Zneg q)
          | xH => (true, -1)
        end
    end.
  Fixpoint bits_of_Z (n: nat) (x: Z) {struct n}: Z -> bool :=
    match n with
      | O =>
        (fun i: Z => false)
      | S m =>
        let (b, y) := Z_bin_decomp x in
          let f := bits_of_Z m y in
            (fun i: Z => if Zeq_bool i 0 then b else f (i - 1))
    end.

  Definition Z_shift_add (b: bool) (x: Z) :=
    if b then 2 * x + 1 else 2 * x.

  Fixpoint Z_of_bits (n: nat) (f: Z -> bool) {struct n}: Z :=
    match n with
      | O => 0
      | S m => Z_shift_add (f 0) (Z_of_bits m (fun i => f (i + 1)))
    end.

  Definition shr (x y: t): t :=
    repr (signed x / two_p (unsigned y)).

  Definition shl (x y: t): t :=
    let fx := bits_of_Z power (unsigned x) in
      let vy := unsigned y in
        repr (Z_of_bits power (fun i => fx (i - vy))).

  Definition ushr (x y: t): t :=
    let fx := bits_of_Z power (unsigned x) in
      let vy := unsigned y in
        repr (Z_of_bits power (fun i => fx (i + vy))).

  Definition bitwise_binop (f: bool -> bool -> bool) (x y: t) :=
    let fx := bits_of_Z power (unsigned x) in
      let fy := bits_of_Z power (unsigned y) in
        repr (Z_of_bits power (fun i => f (fx i) (fy i))).

  Definition and (x y: t): t := bitwise_binop andb x y.
  Definition or (x y: t): t := bitwise_binop orb x y.
  Definition xor (x y: t) : t := bitwise_binop xorb x y.

  Definition neg (x: t) := repr (- unsigned x).
  Definition not (x: t) := repr ((- unsigned x) - 1).
    (* assuming that neg is two's complement and not is one's complement *)

  Definition const : Z -> t := repr.

 End Make.


Require Import michelson.

Require Import List.
Import ListNotations.

Hint Constructors BigStep.

(* Quick math *)
Fact failed_fails : (forall i, (BigStep i (SE_Failed) (SE_Failed))).
Proof. induction i; eauto. Qed.

(* The semantics is not actually total (example: addition with empty stack is not defined).
 * Hence, we wrap the semantics in an inductive giving a "escape hatch value".
 * *)
Inductive BigStep_total :
  code -> stackerr -> option stackerr -> Prop :=
| BigStep_cont :
    forall (i : code) (d d' : stackerr),
      BigStep i d d' ->
      BigStep_total i d (Some d')
| BigStep_stuck :
    forall  (i : code) (d : stackerr),
      BigStep_total i d None.

(* Clearly if we have Some value with wrapped semantics, it is also in underlying *)
Fact BigStep_total_to_BigStep :
  forall i d d',
    BigStep_total i d (Some d') ->
    BigStep i d d'.
Proof. intros i d d' H. now inversion H. Qed.

(* Some convenient tactics *)

(* called when the interpreter is stuck *)
Ltac stuck := exists None; constructor.

(* destruct a as num, if it is not none the interpreter is stuck *)
Ltac as_num v1 :=
  destruct v1 eqn:Hd0;
  match goal with
  | [ Hd0 : v1 = d_Num _ |- _ ] => clear Hd0
  | _ => stuck
  end.

(* To show that the semantics can be executed. This proof of theorem
will then be extracted as an ocaml program *)
Theorem total :
  forall i d,
      { md : _ & BigStep_total i d md }.
Proof.
  intros i.

  intro d. destruct d as [|d].
  eexists. constructor. apply failed_fails.

  Hint Constructors BigStep.
  Hint Resolve BigStep_cont failed_fails BigStep_total_to_BigStep.

  generalize dependent d.
  generalize dependent i.
  induction i; intros d0; eauto.

  (* I here prove for the rules of sequence, addition, subtraction *)

  (* Sequence *)
  3: {
  destruct (IHi1 d0) as [ [[|d'']|] Hi1 ]; [ | | stuck].
  (* Case i1 fails *)
    + eauto.
  (* case it doesn't *)
    + destruct (IHi2 d'') as [ [d'|] Hi2 ]; [ | stuck].
      eauto 10.
  }

  (* Add *)
  (* 30: { *)
  (*   (* execution can only continue if there two values on the stack *) *)
  (*   destruct d0 as [ | v1 [| v2 d0] ]; [ stuck | stuck | ]. *)
  (*   as_num v1. as_num v2. eauto. *)
  (* } *)

  (* (* Sub *) *)
  (* 30: { *)
  (*   destruct d0 as [ | v1 [| v2 d0] ]; [ stuck | stuck | ]. *)
  (*   as_num v1. as_num v2. eauto. *)
  (* } *)

  (* TODO: deal with remaining cases *)
  all : stuck.
Defined.

(* extract the function total to michelson.ml *)
Require Extraction.
Extraction Language OCaml.
Extraction "michelson.ml" total.


(** Coq coding by choukh, Nov 2020 **)

Require Export ZFC.Elements.EX6_3.
Require Import ZFC.Lib.OrdFacts.
Require Import ZFC.Lib.WosetMin.
Import WosetMin.FullVer.

(***
  基数的序与序数的序等价，
  无限基数是极限基数，
  后继基数，
  每个序数都有比它大的基数，
  不存在包括所有基数的集合
***)

(* == implicit AC == *)
(* 基数是序数 *)
Lemma card_is_ord : 𝐂𝐃 ⫃ 𝐎𝐍.
Proof.
  intros 𝜅 [k Hk]. subst. apply card_is_initord.
Qed.
Global Hint Resolve card_is_ord : core.

(* == implicit AC == *)
(* 无限基数是序数 *)
Lemma infcard_is_ord : 𝐂𝐃ⁱⁿᶠ ⫃ 𝐎𝐍.
Proof. intros 𝜅 [H _]. auto. Qed.
Global Hint Immediate infcard_is_ord : core.

(* == implicit AC == *)
(* 基数集是良序集 *)
Lemma cards_woset : ∀ 𝛫, 𝛫 ⪽ 𝐂𝐃 → woset 𝛫 (MemberRel 𝛫).
Proof.
  intros K HK. apply ords_woset.
  intros 𝜅 H𝜅. apply card_is_ord. apply HK. apply H𝜅.
Qed.

(* == implicit AC == *)
Lemma ord_lt_to_cardLt : ∀ 𝜅 𝜆 ⋵ 𝐂𝐃, 𝜅 ∈ 𝜆 → 𝜅 <𝐜 𝜆.
Proof with auto.
  intros 𝜅 H𝜅 𝜆 H𝜆 Hlt.
  apply ord_lt_iff_psub in Hlt as [Hsub Hnq]...
  apply dominate_sub in Hsub. repeat split...
Qed.

(* == implicit AC == *)
Lemma cardLt_to_ord_lt : ∀ 𝜅 𝜆,
  𝜅 <𝐜 𝜆 → 𝜅 ∈ 𝜆.
Proof with auto.
  intros 𝜅 𝜆 [[H𝜅 [H𝜆 Hdom]] Hnq].
  contra. apply Hnq.
  rewrite (card_of_card 𝜅), (card_of_card 𝜆)... apply CardAx1.
  apply ord_le_iff_not_gt in H...
  apply ord_le_iff_sub in H...
  apply dominate_sub in H. apply Schröeder_Bernstein...
Qed.

(* == implicit AC == *)
(* 基数的序与序数的序等价 *)
Fact cardLt_iff_ord_lt : ∀ 𝜅 𝜆,
  𝜅 <𝐜 𝜆 ↔ 𝜅 ⋵ 𝐂𝐃 ∧ 𝜆 ⋵ 𝐂𝐃 ∧ 𝜅 ∈ 𝜆.
Proof with auto.
  split.
  - intros Hlt. split. apply Hlt. split. apply Hlt.
    apply cardLt_to_ord_lt...
  - intros [H𝜅 [H𝜆 Hlt]]. apply ord_lt_to_cardLt...
Qed.

Module AlternativeProofAboutCardConnectivity.

Check EST6_4.card_connected.

(* == implicit AC == *)
(* 基数具有连通性 *)
Fact card_connected : ∀ 𝜅 𝜆 ⋵ 𝐂𝐃, 𝜅 ≠ 𝜆 → 𝜅 <𝐜 𝜆 ∨ 𝜆 <𝐜 𝜅.
Proof.
  intros 𝜅 H𝜅 𝜆 H𝜆 Hnq.
  apply ord_connected in Hnq as [];
  auto; [left|right]; apply cardLt_iff_ord_lt; auto.
Qed.

End AlternativeProofAboutCardConnectivity.

(* == implicit AC == *)
Lemma ord_le_to_cardLe : ∀ 𝜅 𝜆 ⋵ 𝐂𝐃, 𝜅 ⋸ 𝜆 → 𝜅 ≤ 𝜆.
Proof with auto.
  intros 𝜅 H𝜅 𝜆 H𝜆 Hlt.
  rewrite (card_of_card 𝜅), (card_of_card 𝜆)...
  apply cardLe_iff. apply dominate_sub.
  apply ord_le_iff_sub...
Qed.

(* == implicit AC == *)
Lemma cardLe_to_ord_le : ∀ 𝜅 𝜆, 𝜅 ≤ 𝜆 → 𝜅 ⋸ 𝜆.
Proof with auto.
  intros.
  apply cardLe_iff_lt_or_eq in H as [|[_ [_ H]]]...
  left. apply cardLt_to_ord_lt...
Qed.

(* == implicit AC == *)
(* 基数的序与序数的序等价 *)
Fact cardLe_iff_ord_le : ∀ 𝜅 𝜆,
  𝜅 ≤ 𝜆 ↔ 𝜅 ⋵ 𝐂𝐃 ∧ 𝜆 ⋵ 𝐂𝐃 ∧ 𝜅 ⋸ 𝜆.
Proof with auto.
  split.
  - intros Hlt. split. apply Hlt. split. apply Hlt.
    apply cardLe_to_ord_le...
  - intros [H𝜅 [H𝜆 Hlt]]. apply ord_le_to_cardLe...
Qed.

(* == implicit AC == *)
(* 无限基数是极限序数 *)
Lemma infcard_is_limit : 𝐂𝐃ⁱⁿᶠ ⫃ 𝐎𝐍ˡⁱᵐ.
Proof.
  intros 𝜅 [Hcd Hinf].
  apply initial_inford_is_limit; [|split; auto].
  destruct Hcd as [k Hk]. rewrite Hk.
  apply card_is_initord.
Qed.

(* 后继基数 *)
Notation "A ₊" := (HartogsNumber A) (at level 8, format "A ₊") : set_scope.

(* 后继基数是基数 *)
Lemma card_suc_is_card : ∀ A, A₊ ⋵ 𝐂𝐃.
Proof with eauto.
  intros.
  pose proof (hartog_spec_intro A) as [HoA [Hndom Hleast]].
  exists A₊. apply card_iff_initord. split...
  intros β Hβ. intros Hqn.
  assert (Hoβ: β ⋵ 𝐎𝐍). eapply ord_is_ords...
  assert (¬ β ≼ A). {
    intros H. apply Hndom.
    apply (dominate_rewrite_l _ β)... symmetry...
  }
  apply Hleast in H... eapply ord_not_le_gt; revgoals...
Qed.
Global Hint Immediate card_suc_is_card : core.

(* 后继基数是序数 *)
Corollary card_suc_is_ord : ∀ A, A₊ ⋵ 𝐎𝐍.
Proof.
  intros. apply card_is_ord. apply card_suc_is_card.
Qed.
Global Hint Immediate card_suc_is_ord : core.

(* 集合的基数小于其后继 *)
Lemma card_suc_has_card : ∀ A, |A| ∈ A₊.
Proof with auto; try easy.
  intros. unfold card.
  set (Min A₊ (MemberRel A₊)) as min.
  set {ξ ∊ A₊ | ξ ≈ A} as B.
  pose proof (hartog_spec_intro A) as [Hα [Hndom Hleast]].
  pose proof (min_correct A₊ (MemberRel A₊) B) as [Hm Hmin]... {
    apply ords_woset. intros b Hb. eapply ord_is_ords.
    apply hartog_spec_intro. apply Hb.
  } {
    exists (|A|). apply SepI...
    apply ord_lt_iff_not_sub...
    intros H. apply dominate_sub in H...
    apply (dominate_rewrite_r A) in H...
    rewrite <- CardAx0... rewrite <- CardAx0...
  } {
    intros x Hx. apply SepE1 in Hx...
  }
  apply SepE1 in Hm...
Qed.

(* 后继基数是大于该基数的最小基数 *)
Lemma card_suc_correct : ∀ A, ∀𝜅 ⋵ 𝐂𝐃, |A| ∈ 𝜅 → A₊ ⋸ 𝜅.
Proof with eauto.
  intros A 𝜅 Hcd HA𝜅.
  pose proof (hartog_spec_intro A) as [Ho [Hndom Hleast]].
  apply ord_lt_to_cardLt in HA𝜅...
  apply Hleast. apply card_is_ord...
  intros H𝜅A. apply cardLe_iff in H𝜅A.
  rewrite <- card_of_card in H𝜅A...
  eapply cardLe_to_not_gt...
Qed.

(* ex7_23 集合的哈特格斯数是该集合基数的后继基数 *)
Theorem hartogs_is_card_suc : ∀ A,
  (* i   *) A₊ ⋵ 𝐂𝐃 ∧
  (* ii  *) |A| ∈ A₊ ∧
  (* iii *) ∀𝜅 ⋵ 𝐂𝐃, |A| ∈ 𝜅 → A₊ ⋸ 𝜅.
Proof.
  intros. repeat split.
  - apply card_suc_is_card.
  - apply card_suc_has_card.
  - apply card_suc_correct.
Qed.

(* ex7_24 每个序数都有比它大的基数 *)
Theorem all_ord_ex_larger_card : ∀α ⋵ 𝐎𝐍, ∃𝜅 ⋵ 𝐂𝐃, α ∈ 𝜅.
Proof with auto.
  intros α Hα. exists α₊. split.
  apply card_suc_is_card.
  pose proof (card_suc_has_card α) as Hlt.
  apply ord_lt_to_cardLt in Hlt...
  rewrite (card_of_card α₊) in Hlt...
  apply cardLt_iff in Hlt as [Hdom Hnqn].
  apply ord_lt_iff_not_sub...
  intros H. apply dominate_sub in H.
  apply Hnqn. apply Schröeder_Bernstein...
Qed.

(* 不存在一个集合包括所有基数 *)
Corollary no_set_of_all_card : ¬ ∃ A, ∀𝜅 ⋵ 𝐂𝐃, 𝜅 ∈ A.
Proof with auto.
  intros [A H]. apply Burali_Forti.
  exists (⋃ A). intros α Hoα. apply UnionAx.
  apply all_ord_ex_larger_card in Hoα as [𝜅 [Hcd Hα]].
  exists 𝜅. split...
Qed.

(* 不存在一个集合包括所有无限基数 *)
Corollary no_set_of_all_infcard : ¬ ∃ A, ∀𝜅 ⋵ 𝐂𝐃ⁱⁿᶠ, 𝜅 ∈ A.
Proof with eauto.
  intros [A H]. apply Burali_Forti.
  exists (⋃ A). intros α Hoα. apply UnionAx.
  apply all_ord_ex_larger_card in Hoα as [𝜅 [H𝜅 Hα]].
  assert (Hcs: 𝜅 + ℵ₀ ⋵ 𝐂𝐃)...
  assert (Hos: (𝜅 + ℵ₀) ⋵ 𝐎𝐍)...
  apply all_ord_ex_larger_card in Hos as [𝜆 [H𝜆 Hlt]].
  exists 𝜆. split. apply H. split...
  - apply (parent_set_of_infinite_is_infinite (𝜅 + ℵ₀)).
    apply ord_le_iff_sub... apply cardAdd_infinite_iff...
  - eapply ord_trans...
    cut (𝜅 <𝐜 𝜆). apply cardLt_iff_ord_lt.
    eapply cardLe_lt_trans; revgoals.
    apply cardLt_iff_ord_lt... apply cardAdd_enlarge...
Qed.


Require Import compcert.lib.Coqlib.
Require Import List. Import ListNotations.
Require Import VST.floyd.functional_base.
Require Import hmacdrbg.DRBG_functions.

Definition HMAC_DRBG_update (HMAC: list byte -> list byte -> list byte) (provided_data K V: list byte): (list byte * list byte) :=
  let K := HMAC (V ++ [Byte.zero] ++ provided_data) K in
  let V := HMAC V K in
  match provided_data with
    | [] => (K, V)
    | _::_ =>
      let K := HMAC (V ++ [Byte.one] ++ provided_data) K in
      let V := HMAC V K in
      (K, V)
  end.

Definition initial_key: list byte := repeat Byte.zero 32.

Definition initial_value: list byte := repeat Byte.one 32.

Definition HMAC_DRBG_instantiate_algorithm (HMAC: list byte -> list byte -> list byte)
           (entropy_input nonce personalization_string: list byte) (security_strength: Z): DRBG_working_state :=
  let seed_material := entropy_input ++ nonce ++ personalization_string in
  let key := initial_key in
  let value := initial_value in
  let (key, value) := HMAC_DRBG_update HMAC seed_material key value in
  let reseed_counter := 1 in
  (value, key, reseed_counter).

Definition HMAC_DRBG_reseed_algorithm (HMAC: list byte -> list byte -> list byte)
           (working_state: DRBG_working_state) (entropy_input additional_input: list byte): DRBG_working_state :=
  match working_state with (v, key, _) =>
                           let seed_material := entropy_input ++ additional_input in
                           let (key, v) := HMAC_DRBG_update HMAC seed_material key v in
                           let reseed_counter := 1 in
                           (v, key, reseed_counter)
  end.

Function HMAC_DRBG_generate_helper_Z (HMAC: list byte -> list byte -> list byte) (key v: list byte)
          (requested_number_of_bytes: Z) {measure Z.to_nat requested_number_of_bytes}: (list byte * list byte) :=
  if 0 >=? requested_number_of_bytes then (v, [])
  else
    let len := 32%nat in
    let (v, rest) := HMAC_DRBG_generate_helper_Z HMAC key v (requested_number_of_bytes - (Z.of_nat len)) in
    let v := HMAC v key in
    let temp := v in
    (v, rest ++ temp).
Proof.
  intros. rewrite Z2Nat.inj_sub by lia.
  rewrite Nat2Z.id.
  assert ((0 <? requested_number_of_bytes) = true).
  *
    rewrite Z.ltb_antisym.
    rewrite <- Z.geb_leb.
    rewrite teq.
    auto.
  *
  apply Zlt_is_lt_bool in H.
  apply Z2Nat.inj_lt in H; lia.
Defined.

Definition HMAC_DRBG_generate_algorithm (HMAC: list byte -> list byte -> list byte) (reseed_interval: Z)
           (working_state: DRBG_working_state) (requested_number_of_bytes: Z)
           (additional_input: list byte): DRBG_generate_algorithm_result :=
  match working_state with (v, key, reseed_counter) =>
    if reseed_counter >? reseed_interval then generate_algorithm_reseed_required
    else
      let (key, v) := match additional_input with
                        | [] => (key, v)
                        | _::_ => HMAC_DRBG_update HMAC additional_input key v
                      end in
      let (v, temp) := HMAC_DRBG_generate_helper_Z HMAC key v requested_number_of_bytes in
      let returned_bits := firstn (Z.to_nat requested_number_of_bytes) temp in
      let (key, v) := HMAC_DRBG_update HMAC additional_input key v in
      let reseed_counter := reseed_counter + 1 in
      generate_algorithm_success returned_bits (v, key, reseed_counter)
  end.


Require Import lattice.
Require Import Zee.lang.

Section Vals.
  Context {A : Set}.
  Definition Lab := @Lab A.
  Definition Ty := @Ty A.
  Definition LabVar := @LabVar A.
  Definition SecTy := @SecTy A.
  Definition AtomSecTy := @AtomSecTy A.
  Definition Version := nat.

  Inductive SecTyV :=
  | ASTyV: AtomSecTyV -> SecTyV
  | ProdSecTyV: AtomSecTyV -> SecTyV -> SecTyV
  | NilTyV: SecTyV
  with AtomSecTyV :=
       | STyV: TyV -> A -> AtomSecTyV
       | NonSecTyV: AtomSecTyV
  with TyV :=
       | IntTV : TyV
       | PtrTV : A -> SecTyV -> TyV
       | SPtrTV : SecTyV -> SecTyV -> TyV
       | ExTyTV : string -> SecTy -> TyV
       | ExLabTV : string -> SecTy -> TyV
       | RecTyV: string -> SecTy -> TyV.
  Hint Constructors TyV SecTyV.

  Inductive V :=
  | VNum: nat -> V
  | VAddr: nat -> Version -> V
  | ExLab: A -> V -> V
  | ExTy: SecTyV -> V -> V.
  Hint Constructors V.
End Vals.

Coercion VNum : nat >-> V.
Coercion ASTyV : AtomSecTyV >-> SecTyV.


Require Import Ascii String.
Require Import List. Import ListNotations.
Require Import Coq.Program.Basics.
Require Import Extraction.

Require Import OUVerT.dyadic.
Require Import MLCert.axioms.

Open Scope program_scope.

Definition print_nat : nat -> nat := id.
Extract Constant print_nat =>
"fun n ->
  let rec int_of_nat = function
    | O -> 0
    | S n' -> 1 + int_of_nat n'
  in (print_int (int_of_nat n); n)".

Definition print_D : D -> D := id.
Extract Constant print_D =>
"fun d ->
  let rec int_of_positive = function
    | XI p -> 2 * (int_of_positive p) + 1
    | XO p -> 2 * (int_of_positive p)
    | XH -> 1 in
  let int_of_z = function
    | Z0 -> 0
    | Zpos p -> int_of_positive p
    | Zneg p -> - (int_of_positive p) in
  let float_of_d d =
    float_of_int (int_of_z (num d)) /. (2.0 ** float_of_int (int_of_positive (den d))) in
(print_float (float_of_d d); d)".

Definition print_DRed : DRed.t -> DRed.t := id.
Extract Constant print_DRed =>
"fun d ->
  let rec int_of_positive = function
    | XI p -> 2 * (int_of_positive p) + 1
    | XO p -> 2 * (int_of_positive p)
    | XH -> 1 in
  let int_of_z = function
    | Z0 -> 0
    | Zpos p -> int_of_positive p
    | Zneg p -> - (int_of_positive p) in
  let float_of_d d =
    float_of_int (int_of_z (num d)) /. (2.0 ** float_of_int (int_of_positive (den d))) in
(print_float (float_of_d d); d)".

Definition print_newline : forall {X}, X -> X := fun _ x => x.
Extract Constant print_newline =>
"fun x -> print_newline (); x".

Definition print_ascii_nats : forall {X}, list nat -> X -> X := fun _ _ x => x.
Extract Constant print_ascii_nats =>
"fun l x ->
  let rec int_of_nat = function
    | O -> 0
    | S n' -> 1 + int_of_nat n'
  in
  List.iter (fun n -> print_char (Char.chr (int_of_nat n))) l; x".

Fixpoint string_ascii (s : string) : list ascii :=
  match s with
  | EmptyString => []
  | String x s' => x :: string_ascii s'
  end.

Definition print_string {X} : string -> X -> X :=
  print_ascii_nats ∘ (map nat_of_ascii) ∘ string_ascii.

Definition print_space {X} : X -> X := print_string " ".

Definition tuple_fun : forall {A B C}, (A -> B) -> (A -> C) -> A -> B*C :=
  fun _ _ _ f g x => (f x, g x).
(* Force left-to-right evaluation order... *)
Extract Constant tuple_fun =>
"fun f g x -> let a = f x in let b = g x in (a, b)".
Notation " f △ g " :=
  (tuple_fun f g) (at level 50, no associativity) : program_scope.

Definition print_pair {A B} (f : A -> A) (g : B -> B) : A*B -> A*B :=
  f ∘ fst △ g ∘ print_space ∘ snd.

(* Print a vector in machine-readable format. *)
Definition print_vector {A n} (f : A -> A) : AxVec n A -> AxVec n A :=
  AxVec_map (print_space ∘ f).

(* Print a matrix in machine-readable format. *)
Definition print_matrix {A n m} (f : A -> A) : AxMat A n m -> AxMat A n m :=
  AxVec_map (print_newline ∘ print_vector f).