Require Import compcert.lib.Coqlib.
Require Import Bvector.
Require Import List.
Require Import compcert.lib.Integers.
Require Import BinNums.
Require Import msl.Axioms.
Require Import fcf.Blist.

Require Import sha.ByteBitRelations.
Require Import sha.hmac_pure_lemmas.
Require Import sha.general_lemmas.
Require Import sha.HMAC_functional_prog.
Require Import sha.HMAC_common_defs.
Require Import sha.HMAC_spec_abstract.
Require Import sha.HMAC_equivalence.

(*SHA256-specific Modules*)
Require Import sha.common_lemmas.
Require Import sha.HMAC256_functional_prog.
Require Import sha.sha_padding_lemmas.
Require Import sha.ShaInstantiation.
Require Import sha.hmac_common_lemmas.
Require Import sha.HMAC256_spec_pad.
Require Import sha.HMAC256_spec_concat.
Require Import sha.HMAC256_spec_list. (*for toBlocks*)

(*
Lemma of_length_proof_irrel {A:Set} n (l: list A) M:
      Vector.to_list (@of_list_length _ n l M) = l.
Proof. destruct M. apply Vector.to_list_of_list_opp. Qed.
*)
(*Section EQUIV.*)
(*Definition h_v (iv:Bvector c) (blk:Bvector b): Bvector c :=
  of_list_length _
   (sha_h_length _ _ (VectorToList_length _ iv) (VectorToList_length _ blk)).

Lemma h_eq : forall (block_v : Bvector b) (block_l : Blist)
               (HVL: block_l = Vector.to_list block_v)
               ivA ivB (IV: ivA = Vector.to_list ivB),
               sha_h ivA block_l = Vector.to_list (h_v ivB block_v).
Proof. intros. unfold h_v, of_list_length.
  destruct (sha_h_length (Vector.to_list ivB) (Vector.to_list block_v)
      (VectorToList_length c ivB) (VectorToList_length b block_v)).
  symmetry. subst. apply Vector.to_list_of_list_opp.
Qed.
*)

Definition iv_v : Bvector c := Vector.of_list sha_iv.

Lemma iv_eq : sha_iv = Vector.to_list iv_v.
Proof. unfold iv_v.
  rewrite <- Vector.to_list_of_list_opp.
  reflexivity.
Qed.
(*
Lemma opad_length: length (bytesToBits (HP.HMAC_SHA256.sixtyfour
                       (Integers.Byte.unsigned HP.Opad))) = b.
Proof. rewrite bytesToBits_len, length_SF. reflexivity. Qed.

Definition opad_v: Bvector b := of_list_length _ opad_length.

Lemma ipad_length: length (bytesToBits (HP.HMAC_SHA256.sixtyfour
                       (Integers.Byte.unsigned HP.Ipad))) = b.
Proof. rewrite bytesToBits_len, length_SF. reflexivity. Qed.

Definition ipad_v: Bvector b := of_list_length _ ipad_length.
*)
Lemma fpad_length (v:Bvector c): length (fpad (Vector.to_list v)) = p.
Proof. unfold fpad, fpad_inner. rewrite bytesToBits_len.
  repeat rewrite app_length. rewrite length_list_repeat, length_intlist_to_Zlist.
  rewrite (mult_comm 4), plus_comm, Zlength_correct.
  rewrite bitsToBytes_len_gen with (n:=32%nat).
    reflexivity.
    apply VectorToList_length.
Qed.

Definition fpad_v (v:Bvector c): Bvector p := of_list_length _ (fpad_length v).

Lemma fpad_eq : forall (v : Bvector c) (l : Blist),
                  l = Vector.to_list v ->
                  fpad l = Vector.to_list (fpad_v v).
Proof. intros. unfold fpad_v, of_list_length.
  destruct (fpad_length v).
  rewrite Vector.to_list_of_list_opp.
  subst; reflexivity.
Qed.

Fixpoint splitAndPad_aux (m:list Blist) (M: Forall (fun x => length x = 512%nat) m):
           list (Bvector b) :=
(match m as l return (Forall (fun x => length x = 512%nat) l) -> list (Bvector b) with
  nil => fun F => nil
|  cons h t => fun F => cons (of_list_length h (Forall_inv F))
                    (splitAndPad_aux t (Forall_tl _ _ _ _ F))
 end) M.

Lemma splitAndPad_aux_consD h t M:
      splitAndPad_aux (cons h t) M
      = (of_list_length h (Forall_inv M))
         :: (splitAndPad_aux t (Forall_tl _ _ _ _ M)).
Proof. reflexivity. Qed.

Lemma splitAndPad_aux_nil m M: m=nil -> splitAndPad_aux m M= nil.
Proof. intros; subst. reflexivity. Qed.

Lemma length_splitandpad_inner_aux: forall ssm pf,
  Forall2
  (fun (bv : Vector.t bool b) (bl : list bool) => bl = Vector.to_list bv)
  (splitAndPad_aux (toBlocks ssm) pf)
  (toBlocks ssm).
Proof.
  intros ssm. remember (toBlocks ssm). generalize dependent ssm.
  induction l.
  { simpl; intros. constructor. }
  { intros. rewrite toBlocks_equation in Heql.
    destruct ssm. discriminate.
    remember ( Compare_dec.leb (length (b :: ssm)) 511) as d.
    destruct d. exfalso.
           rewrite Heql in pf. apply Forall_inv in pf.  clear Heql.
           rewrite firstn_length in pf.
           symmetry in Heqd. apply leb_complete in Heqd.
           eapply NPeano.Nat.min_l_iff in pf. omega.
    rewrite splitAndPad_aux_consD.
    constructor.
      rewrite of_length_proof_irrel. trivial.
    eapply (IHl (skipn 512 (b :: ssm))).
      remember (firstn 512 (b :: ssm)) as zz.
      remember (toBlocks (skipn 512 (b :: ssm))) as yy.
      clear - Heql. inversion Heql. trivial. }
Qed.

Definition splitAndPad_v (m: Blist): list (Bvector b).
  apply (splitAndPad_aux (sha_splitandpad_blocks m)).
  apply InBlocks_Forall_512. apply sha_splitandpad_inc_InBlocks.
Defined.

Lemma splitAndPad_nil: exists pf,
  splitAndPad_v nil =
  cons (@of_list_length bool 512 (sha_splitandpad_inc nil) pf) nil.
Proof. unfold splitAndPad_v, sha_splitandpad_blocks.
  remember (InBlocks_Forall_512 _ (sha_splitandpad_inc_InBlocks nil)). clear Heqf.
  remember (toBlocks (sha_splitandpad_inc nil)).
  rewrite toBlocks_equation in Heql.
  remember (sha_splitandpad_inc nil) as m.
  destruct m. exfalso. clear Heql f l.
    unfold sha_splitandpad_inc in Heqm.
    assert (@length bool nil = length (bytesToBits (pad_inc (bitsToBytes nil)))).
      rewrite <- Heqm; trivial.
    simpl in H; clear Heqm. omega.
  rewrite leb_correct_conv in Heql.
    2: rewrite Heqm; simpl; omega.
  rewrite sublist.firstn_same in Heql.
    2: rewrite Heqm; simpl; omega.
  rewrite skipn_short in Heql.
    2: rewrite Heqm; simpl; omega.
  rewrite toBlocks_equation in Heql. subst l.
  simpl. eexists. reflexivity.
Qed.

Lemma length_splitandpad_inner m :
   Forall2
     (fun (bv : Vector.t bool b) (bl : list bool) => bl = Vector.to_list bv)
     (splitAndPad_v m) (sha_splitandpad_blocks m).
Proof. apply length_splitandpad_inner_aux. Qed.

Lemma C: NPeano.Nat.divide 8 c.
  exists 32%nat. reflexivity.
Qed.

Module EQ256 <: EQUIV_Inst SHA256.
  Definition c := c.
  Definition C := C.
  Definition p := p.
  Definition b := b.
  Definition B := B.
  Definition BS: (SHA256.BlockSize * 8)%nat = b. reflexivity. Qed.
  Definition h := sha_h.
  Definition h_length := sha_h_length.
(*  Definition h_v := h_v.
  Definition h_eq := h_eq.*)
  Definition ir: list int := SHA256.init_registers.
(*  Definition iv:= sha_iv.*)
  Lemma iv_length: length (HMAC_spec_pad.convert ir) = c.
     apply sha_iv_length. Qed.
  (*Definition iv_length := sha_iv_length.*)
  Definition iv_v: Bvector c := iv_v. (*of_list_length _ iv_length.*)
  Lemma iv_eq: HMAC_spec_pad.convert ir  = Vector.to_list iv_v.
  Proof. reflexivity. Qed.
  (*
  Definition ipd:Z := 54.
  Definition opd:Z:=92.
  Lemma isbyteZ_Ipad: isbyteZ ipd.
    unfold ipd. split; omega. Qed.
  Lemma isbyteZ_Opad: isbyteZ opd.
    unfold opd. split; omega. Qed.*)
  Definition fpad_v := fpad_v.
  Definition fpad := fpad.
  Definition fpad_length msg: length msg = c -> length (fpad msg) = p.
  Proof. apply ShaInstantiation.fpad_length. Qed.
  Definition fpad_eq := fpad_eq.
  Definition splitAndPad := sha_splitandpad.
  Definition splitAndPad_v := splitAndPad_v.
  Definition splitandpad_blocks := sha_splitandpad_blocks.
  Definition sap_fpad:=sha_splitandpad_fpad.
  Definition shasplitandpad_blocks_b:= sha_splitandpad_blocks_512.
  Definition sap' m := concat (splitandpad_blocks m).
  Definition sap_app:forall (l m : Blist),
                         length l = b ->
                         splitAndPad (l ++ m) = l ++ sap' m.
  Proof. intros. rewrite sha_splitandpad_app; trivial.
    f_equal. unfold sap', splitandpad_blocks, sha_splitandpad_blocks.
    rewrite concat_toBlocks_id; trivial.
    apply sha_splitandpad_inc_InBlocks.
  Qed.
  Lemma sap'_InBlocks m: InBlocks b (sap' m).
    apply concat_InBlocks. apply sha_splitandpad_blocks_512. Qed.
  Definition hashblock : list int -> list int -> list int := SHA256.hash_block.
  Lemma HHB : h =
      (fun rgs bl : Blist =>
       intsToBits (hashblock (bitsToInts rgs) (bitsToInts bl))).
    reflexivity. Qed.

  Definition hashblocks: list int -> list int -> list int:= SHA256.hash_blocks.
  Definition d := 16%nat.

  Definition HBS_eq : forall r msg : list int,
         hashblocks r msg =
         match msg with
         | List.nil => r
         | _ :: _ => hashblocks (hashblock r (firstn d msg)) (skipn d msg)
         end := SHA256.hash_blocks_equation.
  Lemma D: (d * 32)%nat = b. reflexivity. Qed.

  Definition gap:list Z -> list int := SHA256.generate_and_pad.
  Lemma GAP: forall bits, NPeano.Nat.divide d (length (gap (bitsToBytes bits))).
    intros. rewrite <- pad_compose_equal. apply gap_divide16. Qed.

  Lemma sap_gap: splitAndPad = fun bits => bytesToBits (intlist_to_Zlist (gap (bitsToBytes bits))).
  Proof. apply extensionality. intros l. unfold splitAndPad, sha_splitandpad.
    f_equal. rewrite <- pad_compose_equal. unfold generate_and_pad'.
    rewrite pure_lemmas.Zlist_to_intlist_to_Zlist. trivial.
    destruct (pad_len_64_nat (bitsToBytes l)). rewrite Zlength_correct, H. exists (Z.of_nat(x*16)). do 2 rewrite Nat2Z.inj_mul. rewrite Z.mul_comm, <- Z.mul_assoc. reflexivity.
    apply pad_isbyteZ. eapply bitsToBytes_isbyteZ. reflexivity.
  Qed.

  Lemma HASH m: SHA256.Hash m = intlist_to_Zlist (hashblocks ir (gap m)).
     unfold SHA256.Hash.
     rewrite functional_prog.SHA_256'_eq; reflexivity.
  Qed.

  Lemma FOLD_HB_eq: forall l ls, length l = (c + p)%nat ->
     Forall (fun x => length x = (c + p)%nat) ls ->
     fold_left h (l :: ls) (Vector.to_list iv_v) =
          hash_blocks_bits (HMAC_spec_concat.HMAC_Concat.b c p) B h
          (Vector.to_list iv_v) (l ++ concat ls).
  Proof. intros.
     assert (SH: sha_iv = Vector.to_list iv_v). rewrite <- iv_eq; trivial.
     rewrite <- SH; apply (fold_hash_blocks_eq _ _ H H0).
  Qed.

  Lemma length_splitandpad_inner m:
    Forall2
     (fun (bv : Vector.t bool b) (bl : list bool) => bl = Vector.to_list bv)
     (splitAndPad_v m) (splitandpad_blocks m).
  Proof. apply length_splitandpad_inner. Qed.

End EQ256.

Module EQ := HMAC_Equiv SHA256 EQ256.

(* Note we're comparing to HP.HMAC_SHA256.HmacCore, not HMAC. *)
Lemma Equivalence (P : Blist -> Prop) (HP: forall msg, P msg -> NPeano.Nat.divide 8 (length msg))
      (kv : Bvector b) (m : HMAC_Abstract.Message P):
      Vector.to_list (HMAC_spec.HMAC EQ.h_v iv_v (HMAC_Abstract.wrappedSAP _ _ splitAndPad_v)
                      fpad_v EQ.opad_v EQ.ipad_v kv m) =
      bytesToBits (HMAC_SHA256.HmacCore (Byte.repr EQ.ipd) (Byte.repr EQ.opd)
                              (bitsToBytes (HMAC_Abstract.Message2Blist m))
                              (map Integers.Byte.repr (bitsToBytes (Vector.to_list kv)))).
Proof.
  specialize (EQ.Equivalence _ HP kv m); intros.
  unfold EQ.h_v in H.
  unfold EQ256.c, EQ256.p, EQ256.splitAndPad_v in H.
  unfold EQ256.fpad_v in H.
  unfold EQ256.b in H. apply H.
Qed.

(* Earlier explicit proof:
Lemma Equivalence (P : Blist -> Prop) (HP: forall msg, P msg -> NPeano.divide 8 (length msg))
      (kv : Bvector b) (m : HMAC_Abstract.Message P):
      Vector.to_list (HMAC_spec.HMAC h_v iv_v (HMAC_Abstract.wrappedSAP _ _ splitAndPad_v)
                      fpad_v opad_v ipad_v kv m) =
      bytesToBits (HP.HMAC_SHA256.HmacCore (Integers.Byte.repr 54) (Integers.Byte.repr 92)
                              (bitsToBytes (HMAC_Abstract.Message2Blist m))
                              (map Integers.Byte.repr (bitsToBytes (Vector.to_list kv)))).
Proof.
  assert (LK : length (Vector.to_list kv) = b).
    { apply VectorToList_length. }
  erewrite <- HMAC_Abstract.HMAC_abstract_list; try reflexivity.
  2: apply h_eq.
  2: apply fpad_eq.
  2: apply length_splitandpad_inner.
  erewrite HMAC256_spec_list.HMAC_list_concat_sap_instantiated. (*; trivial.*)
SearchAbout sha_splitandpad_inc.
(*sap' to be instantiated to sha_splitandpad_inc*)
  2: apply sha_h_length.
  2: apply VectorToList_length.
  2: apply VectorToList_length.
  2: apply VectorToList_length.
  2: apply fold_hash_blocks_eq.
  2: apply LK.
(*  rewrite <- sha_splitandpad_inc_eq.*)
  rewrite <- HMAC256_spec_concat.HMAC_concat_pad_sap_instantiated; trivial.
  2: apply sha_h_length.
  2: apply VectorToList_length.
  2: apply VectorToList_length.
  eapply HMAC256_spec_pad.HMAC_pad_concrete'.

  split; omega.
  split; omega.

  (* key length *)
  { rewrite map_length, bitsToBytes_len_gen with (n:=64%nat).
    reflexivity.
    rewrite LK; reflexivity. }

  (* key length *)
  { rewrite Zlength_map, bitsToBytes_len. reflexivity. apply LK. }

  (* TODO: maybe replace bytes_bits_lists with bytesToBits? Since bytes_bits_comp_ind
     is used a lot *)

  (* key *)
  { rewrite map_unsigned_Brepr_isbyte.
      apply bytes_bits_comp_ind.
      eapply bitsToBytes_isbyteZ; reflexivity.
      rewrite  bits_bytes_bits_id; trivial.
      apply block_8. assumption.
      eapply bitsToBytes_isbyteZ. reflexivity. }

  (* uses fact that message is in blocks of 8 *)
  { apply bytes_bits_comp_ind.
    eapply bitsToBytes_isbyteZ; reflexivity.
    rewrite bits_bytes_bits_id; trivial.
    apply InBlocks_len.
    apply HP. destruct m. simpl; trivial. }

  (* opad *)
  { apply bytes_bits_comp_ind.
    apply Forall_list_repeat. unfold HP.Opad. omega.
    apply of_length_proof_irrel. }

  (* ipad *)
  { apply bytes_bits_comp_ind.
    apply Forall_list_repeat. unfold HP.Ipad. omega.
    apply of_length_proof_irrel. }

Qed.
End EQUIV. *)


Inductive t :=
| C0 : t
| C1 : bool -> t
| C2 : t -> nat -> t
.


(* The input for this one is assumed to be sorted (e.g., using
   the [sort] command). *)

Set Warnings "-extraction-opaque-accessed".

From Coq Require Import
     List Arith NArith ZArith Ascii String
     OrderedTypeEx FSetAVL FMapAVL
     extraction.ExtrOcamlIntConv
     Lia.
Import ListNotations.

From SimpleIO Require SimpleIO.

From ExtLib Require Import
     Structures.Monads.
Import MonadNotation.
Local Open Scope monad.

From advent Require Import lib.

(* Sets indexed by natural numbers. *)
Module NMap := FMapAVL.Make N_as_OT.

(* Minutes since midnight. *)
Definition time : Type := N.

(* We assume shifts happen around midnight. *)
Variant event : Type :=
| Shift (guard : N)
| FallsAsleep
| WakesUp
.

(* A list of 1 in the interval [[n1; n2-1]] *)
Definition interval (n1 n2 : N) : list nat :=
  N.iter n1 (cons 0) (N.iter (n2 - n1) (cons 1) []).

Fixpoint union {A : Type}
         (merge : A -> A -> A) (xs ys : list A) : list A :=
  match xs, ys with
  | [], _ => ys
  | _, [] => xs
  | x :: xs, y :: ys => merge x y :: union merge xs ys
  end.

Definition union1 : list nat -> list nat -> list nat := union plus.

Parameter err : forall {A}, A.
Extract Inlined Constant err => "assert false".

Fixpoint record_sleeps_aux (r : NMap.t (list nat))
         (guard0 : N) (es : list (time * event)) : NMap.t (list nat) :=
  match es with
  | (_, Shift guard) :: es => record_sleeps_aux r guard es
  | (i, FallsAsleep) :: (j, WakesUp) :: es =>
    let gz := match NMap.find guard0 r with
              | None => []
              | Some gz => gz
              end in
    let r' := NMap.add guard0 (union1 (interval i j) gz) r in
    record_sleeps_aux r' guard0 es
  | [] => r
  | _ => err
  end.

Definition record_sleeps
           (es : list (time * event)) : NMap.t (list nat) :=
  record_sleeps_aux (NMap.empty _) 0 es.

Definition sum : list nat -> nat :=
  fun ns => fold_left plus ns 0.

Definition NMap_argmax {A : Type} (f : A -> nat)
           (r : NMap.t A) : nat * list (N * A) :=
  NMap.fold (fun i x best =>
    let y := f x in
    if y <? fst best then
      best
    else if y =? fst best then
      (fst best, (i, x) :: snd best)
    else
      (y, [(i, x)])) r (0, []).

(* Find the maximum of a list and all indices where it is reached. *)

Fixpoint arg_max_aux (best : nat) (arg : list nat) (i : nat)
         (xs : list nat) : nat * list nat :=
  match xs with
  | [] => (best, arg)
  | x :: xs =>
    if x <? best then
      arg_max_aux best arg (S i) xs
    else if x =? best then
      arg_max_aux best (i :: arg) (S i) xs
    else
      arg_max_aux x [i] (S i) xs
  end.

Definition arg_max : list nat -> nat * list nat :=
  arg_max_aux 0 [] 0.

(* Find the laziest guards (there should be only one in the AoC
   input), together with the total time they slept. *)
Definition laziest1 :
  NMap.t (list nat) -> nat * list (N * list nat) :=
  NMap_argmax sum.

Definition laziest2 :
  NMap.t (list nat) -> nat * list (N * (nat * list nat)) :=
  fun r => NMap_argmax (fun '(max_slept, _) => max_slept)
                       (NMap.map arg_max r).

Definition all_laziest1 (es : list (time * event)) :
  nat * list (N * nat * list nat) :=
  let r := record_sleeps es in
  let '(max_sleep, offenders) := laziest1 r in
  let most_slept_minutes := fun '(guard, slept) =>
    let '(m, mns) := arg_max slept in
    (guard, m, mns) in
  (max_sleep, map most_slept_minutes offenders).

Definition all_laziest2 (es : list (time * event)) :
  nat * list (N * list nat) :=
  let r := record_sleeps es in
  let '(max_slept, offenders) := laziest2 r in
  let most_slept_minutes := fun '(guard, (_, mns)) =>
    (guard, mns) in
  (max_slept, map most_slept_minutes offenders).

Section main.

Import SimpleIO.

Context {m : Type -> Type} `{Monad m} `{MonadFix m}
        `{MonadI (time * event) m}
        `{MonadO ocaml_string m}.

Infix "+++" := ostring_app (at level 30).

Definition print_all_laziest1 (a : nat * list (N * nat * list nat)) :=
  let '(max_sleep, offenders) := a in
  print (to_ostring "Total slept:");;
  print (ostring_of_int (int_of_nat max_sleep));;
  let of_n n := ostring_of_int (int_of_n n) in
  let of_nat n := ostring_of_int (int_of_nat n) in
  for' offenders (fun '(guard, max_slept, mns) =>
    print (OString.concat (to_ostring "; ") ([
      of_n guard;
      of_nat max_slept;
      OString.concat (to_ostring ",")
        (map (fun n => OString.concat (to_ostring ":") [
                of_nat n;
                of_n (guard * N.of_nat n)%N])
             mns)]
      ))
  ).

Definition print_all_laziest2 (a : nat * list (N * list nat)) :=
  let '(max_sleep, offenders) := a in
  print (to_ostring "Max slept:");;
  print (ostring_of_int (int_of_nat max_sleep));;
  let of_n n := ostring_of_int (int_of_n n) in
  let of_nat n := ostring_of_int (int_of_nat n) in
  for' offenders (fun '(guard, mns) =>
    print (OString.concat (to_ostring "; ") ([
      of_n guard;
      OString.concat (to_ostring ",")
        (map (fun n => OString.concat (to_ostring ":") [
                of_nat n;
                of_n (guard * N.of_nat n)%N])
             mns)]
      ))
  ).

Definition main1 : m unit :=
  es <- read_all;;
  let a := all_laziest1 es in
  print_all_laziest1 a.

Definition main2 : m unit :=
  es <- read_all;;
  let a := all_laziest2 es in
  print_all_laziest2 a.

End main.

Module io.

Import SimpleIO.
Import IO.Notations.

(* Partial function!? *)
Parameter parse_event : forall {TIME EVENT : Type},
    (int -> TIME) ->
    (int -> EVENT) -> EVENT -> EVENT ->
    ocaml_string -> TIME * EVENT.

Extract Constant parse_event =>
  "fun mk_time mk_shift sleep wakeup s ->
   try
     Scanf.sscanf s ""[1518-%_d-%_d %_d:%d] %[^\n]""
       (fun mn e ->
          (mk_time mn, match e with
               | ""falls asleep"" -> sleep
               | ""wakes up"" -> wakeup
               | _ -> Scanf.sscanf e ""Guard #%d"" mk_shift)
       )
   with End_of_file ->
    failwith (Printf.sprintf ""Parse error: %S"" s)".

Instance MonadI_event_IO : MonadI (time * event) IO := {
  read := catch_eof (
    s <- read_line';;
    ret (parse_event
           n_of_int
           (fun g => Shift (n_of_int g)) FallsAsleep WakesUp
           s));
}.

End io.

Import SimpleIO.

Definition exec1 : io_unit := IO.unsafe_run main1.
Extraction "day04_1.ml" exec1.

Definition exec2 : io_unit := IO.unsafe_run main2.
Extraction "day04_2.ml" exec2.


Require Import List Common
        ADT.ADTSig ADT.Core
        ADTNotation.BuildADTSig ADTNotation.BuildADT
        Common.ilist ADTNotation.StringBound
        ADTRefinement.Core ADTRefinement.SetoidMorphisms
        ADTRefinement.GeneralRefinements
        ADTRefinement.Refinements.HoneRepresentation
        ADTRefinement.BuildADTSetoidMorphisms
        ADTRefinement.Refinements.SimplifyRep.

Section SimplifyRep.

  (* If a representation has extraneous information (perhaps intermediate
     data introduced during refinement), simplifying the representation
     is a valid refinement. *)

  Variable oldRep : Type. (* The old representation type. *)
  Variable newRep : Type. (* The new representation type. *)

  Variable simplifyf : oldRep -> newRep. (* The simplification function. *)
  Variable concretize : newRep -> oldRep. (* A map to the enriched representation. *)

  (* The abstraction relation between old and new representations. *)
  Variable AbsR : oldRep -> newRep -> Prop.
  Notation "ro ≃ rn" := (AbsR ro rn) (at level 70).

  Definition simplifyMethDef
             (Sig : methSig)
             (oldMeth : @methDef oldRep Sig)
  : @methDef newRep Sig :=
    {| methBody := simplifyMethod simplifyf concretize (methBody oldMeth) |}.

  Definition simplifyConstrDef
             (Sig : consSig)
             (oldConstr : @consDef oldRep Sig)
  : @consDef newRep Sig :=
    {| consBody := simplifyConstructor simplifyf (consBody oldConstr) |}.

  Lemma refineADT_BuildADT_Simplify
            (constrSigs : list consSig)
            (methSigs : list methSig)
            (constrDefs : ilist (@consDef oldRep) constrSigs)
            (methDefs : ilist (@methDef oldRep) methSigs) :
    (forall r_o, r_o ≃ simplifyf r_o) ->
    (forall r_n r_o,
       (r_o ≃ r_n) ->
       forall idx n,
         refineEquiv (r_o'' <- getMethDef methDefs idx r_o n;
                      r_n' <- {r_n' | fst r_o'' ≃ r_n'};
                      ret (r_n', snd r_o''))
                     (r_o'' <- getMethDef methDefs idx (concretize r_n) n;
                      ret (simplifyf (fst r_o''), snd r_o''))) ->
    refineADT
      (BuildADT constrDefs methDefs)
      (BuildADT (imap _ simplifyConstrDef constrDefs)
                (imap _ simplifyMethDef methDefs)).
  Proof.
    econstructor 1 with (AbsR := AbsR); simpl in *; eauto; intros.
    - rewrite <- ith_Bounded_imap.
      unfold simplifyConstrDef, simplifyConstructor; simpl.
      intros v Comp_v; inversion_by computes_to_inv;
      repeat econstructor; subst; eauto.
    - rewrite <- ith_Bounded_imap.
      rewrite H0; eauto; reflexivity.
  Qed.

End SimplifyRep.


Require Import HOASLib.
Require Import Denotation.
Require Import TypeChecking.

Open Scope matrix_scope.

(***************************)
(* Approximate Slide Lemma *)
(***************************)

(* How did this get here?
Lemma slide : forall (p q : Pat Qubit) (Γ0 Γ : Ctx) (U V : Unitary Qubit),
  denote_circuit true (let_ p' ← U $ p; let_ q' ← V $ q; (p',q')) Γ0 Γ =
  denote_circuit true (let_ q' ← V $ q; let_ p' ← U $ p; (p',q')) Γ0 Γ.
Proof.
  intros p q Γ0 Γ U V. simpl.
  unfold denote_circuit.
  simpl.
  dependent destruction p.
  dependent destruction q.
  simpl.
  autounfold with den_db. simpl.

  *)

(* ---------------------------------------*)
(*--------- Boxed Circuit Specs ----------*)
(* ---------------------------------------*)

(* TODO: add lemmas to proof_db *)
Lemma id_circ_spec : forall W ρ safe, WF_Matrix ρ ->
  denote_box safe  (@id_circ W) ρ = ρ.
Proof.
  intros W ρ safe H.
  simpl. unfold denote_box. simpl.
  autorewrite with proof_db.
  rewrite add_fresh_split.
  simpl.
  unfold pad.
  simpl.
  rewrite Nat.sub_diag.
  rewrite kron_1_r.
  rewrite subst_pat_fresh_empty.
  rewrite denote_pat_fresh_id.
  rewrite super_I; auto.
Qed.

Lemma X_spec : forall (b safe : bool), denote_box safe (boxed_gate _X) (bool_to_matrix b) =
                               bool_to_matrix (¬ b).
Proof. intros. vector_denote. destruct b; solve_matrix. Qed.

Lemma init0_spec : forall safe, denote_box safe init0 (I (2^0)) = ∣0⟩⟨0∣.
Proof. intros. matrix_denote. Msimpl. reflexivity. Qed.

Lemma init1_spec : forall safe, denote_box safe init1 (I (2^0)) = ∣1⟩⟨1∣.
Proof. intros. matrix_denote. Msimpl. reflexivity. Qed.

Lemma assert0_spec : forall safe, denote_box safe assert0 ∣0⟩⟨0∣ = I 1.
Proof.
  destruct safe.
  - matrix_denote.
    Msimpl.
    solve_matrix.
  - matrix_denote.
    Msimpl.
    solve_matrix.
Qed.

Lemma assert1_spec : forall safe, denote_box safe assert1 ∣1⟩⟨1∣ = I 1.
Proof.
  destruct safe.
  - matrix_denote.
    Msimpl.
    solve_matrix.
  - matrix_denote.
    Msimpl.
    solve_matrix.
Qed.

Lemma init_spec : forall b safe, denote_box safe (init b) (I (2^0)) = bool_to_matrix b.
Proof. destruct b; [apply init1_spec | apply init0_spec]. Qed.

Lemma assert_spec : forall b safe, denote_box safe (assert b) (bool_to_matrix b) = I 1.
Proof. destruct b; [apply assert1_spec | apply assert0_spec]. Qed.

Lemma SWAP_spec : forall ρ safe, denote_box safe SWAP ρ = swap × ρ × swap.
Proof. intros. matrix_denote. Msimpl. setoid_rewrite swap_sa. reflexivity. Qed.

Lemma SWAP_spec_sep : forall (ρ1 ρ2 : Density 2) safe,
  WF_Matrix ρ1 -> WF_Matrix ρ2 ->
  denote_box safe SWAP (ρ1 ⊗ ρ2) = ρ2 ⊗ ρ1.
Proof. intros. rewrite SWAP_spec. solve_matrix. Qed.

(* MOVE THIS! *)
Lemma fresh_wtype : forall (w : WType) (Γ : Ctx), add_fresh_state w Γ = Γ ++ (add_fresh_state w []).
Proof.
  intros. generalize dependent Γ.
  induction w; unfold add_fresh_state; simpl; try reflexivity; intros.
  - induction Γ; simpl; try reflexivity.
    rewrite <- IHΓ. reflexivity.
  - repeat rewrite add_fresh_split. simpl.
    replace (add_fresh_state w2 (add_fresh_state w1 [])) with ((add_fresh_state w1 []) ++ (add_fresh_state w2 [])) by (rewrite <- IHw2; reflexivity).
    rewrite IHw2. rewrite IHw1. rewrite app_assoc. reflexivity.
Qed.

Lemma SWAP_GEN_spec_same_sep : forall W (ρ1 ρ2 : Density (2^⟦W⟧)) safe,
    denote_box safe (@SWAP_GEN W W) (ρ1 ⊗ ρ2) = ρ2 ⊗ ρ1.
Proof.
  matrix_denote.
  repeat rewrite add_fresh_split.
  unfold hoas_to_db. simpl.
  Search subst_pat.
  rewrite subst_pat_fresh.
  rewrite pad_nothing.
  unfold denote_pat. simpl.
  rewrite subst_pat_no_gaps.

  2:{ rewrite fresh_wtype. rewrite app_length.
      Search Bounded_Pat.
      apply bounded_pat_le with (length (add_fresh_state W [])).
      lia.
      rewrite length_fresh_state with (w := W) (Γ' := add_fresh_state W []) (Γ := []) by easy.
      apply add_fresh_pat_bounded.
      constructor.
  }

  all: repeat apply add_fresh_state_no_gaps; try constructor.
  Search pat_to_list add_fresh_pat.
  repeat rewrite swap_fresh_seq. simpl.
  Search length add_fresh_state.
  erewrite length_fresh_state by reflexivity. simpl.
Abort.

(* -----------------------------------------*)
(*--------- Reversible Circuit Specs -------*)
(* -----------------------------------------*)

Lemma CNOT_spec : forall (b1 b2 safe : bool),
  denote_box safe CNOT (bool_to_matrix b1 ⊗ bool_to_matrix b2)
  = (bool_to_matrix b1 ⊗ bool_to_matrix (b1 ⊕ b2)).
Proof.
  vector_denote. destruct b1, b2; unfold bool_to_ket; simpl; Msimpl; solve_matrix.
Qed.

Lemma TRUE_spec : forall z safe,
  denote_box safe TRUE (bool_to_matrix z) = bool_to_matrix (true ⊕ z).
Proof. vector_denote. destruct z; solve_matrix. Qed.

Lemma FALSE_spec : forall z safe,
    denote_box safe FALSE (bool_to_matrix z) = bool_to_matrix (false ⊕ z).
Proof. vector_denote. destruct z; solve_matrix. Qed.

Lemma NOT_spec : forall (x z : bool),
  forall safe, denote_box safe NOT (bool_to_matrix x ⊗ bool_to_matrix z) =
  bool_to_matrix x ⊗ bool_to_matrix ((¬ x) ⊕ z).
Proof.
  vector_denote.
  destruct x, z; unfold bool_to_ket; simpl; Msimpl; solve_matrix.
Qed.

Lemma XOR_spec : forall (x y z safe : bool),
    denote_box safe XOR (bool_to_matrix x ⊗ bool_to_matrix y ⊗ bool_to_matrix z)  =
    bool_to_matrix x ⊗ bool_to_matrix y ⊗ bool_to_matrix (x ⊕ y ⊕ z).
Proof.
  vector_denote. Msimpl.
  destruct x, y, z; simpl; solve_matrix.
Qed.

Lemma AND_spec : forall (x y z safe : bool),
    denote_box safe AND (bool_to_matrix x ⊗ bool_to_matrix y ⊗ bool_to_matrix z)  =
    bool_to_matrix x ⊗ bool_to_matrix y ⊗ bool_to_matrix ((x && y) ⊕ z).
Proof.
  vector_denote. Msimpl.
  destruct x, y, z; simpl; Msimpl; solve_matrix.
Qed.


Require Import IntuitionisticLogic.base.
Import LogicNotation.
Local Open Scope IPC_scope.

Section KripkeSemantic.

Context {venv: Var_env}.

Class Frame : Type := {
  Worlds: Type;
  access: Worlds -> Worlds -> Prop;
  access_refl: forall w, access w w;
  access_trans: forall u v w, access u v -> access v w -> access u w
}.

Class Model: Type := {
  F: Frame;
  eval: Worlds -> Var -> bool;
  hereditary: forall w v: Worlds, access w v -> (forall x: Var, eval w x = true -> eval v x = true)
}.

Existing Instance F.

Class KripkeSem : Type := {
  M: Model;
  Kripke_Sat : Worlds -> Term -> Prop;
  satisfy_ind: forall (w: Worlds) (t: Term),
    Kripke_Sat w t <->
    match t with
    | andp t1 t2 => Kripke_Sat w t1 /\ Kripke_Sat w t2
    | orp t1 t2 => Kripke_Sat w t1 \/ Kripke_Sat w t2
    | impp t1 t2 => forall v, access w v -> Kripke_Sat v t1 -> Kripke_Sat v t2
    | falsep => False
    | varp x => eval w x = true
    end
}.

Lemma Kripke_Sat_mono: forall `{KripkeSem} w v t, access w v -> Kripke_Sat w t -> Kripke_Sat v t.
Proof.
  intros.
  induction t; apply satisfy_ind in H1; apply satisfy_ind.
  + tauto.
  + tauto.
  + intros.
    specialize (H1 v0 (access_trans _ _ _ H0 H2)).
    tauto.
  + tauto.
  + eapply hereditary; eauto.
Qed.

Existing Instance M.

Class PointModel: Type := {
  KS: KripkeSem;
  w: Worlds
}.

Existing Instance KS.

Instance Kripke_sem : Semantic := mk_sem PointModel (fun KM t => Kripke_Sat w t).

End KripkeSemantic.

Lemma sound_Kripke_IPC: sound Kripke_sem IPC.
Proof.
  unfold sound.
  intros.
  induction H; intros M CONTEXT.
  + apply CONTEXT.
    auto.
  + specialize (IHIPC_derive M CONTEXT).
    simpl in IHIPC_derive |- *.
    apply satisfy_ind in IHIPC_derive.
    tauto.
  + specialize (IHIPC_derive M CONTEXT).
    simpl in IHIPC_derive |- *.
    apply satisfy_ind in IHIPC_derive.
    tauto.
  + specialize (IHIPC_derive1 M CONTEXT).
    specialize (IHIPC_derive2 M CONTEXT).
    simpl in IHIPC_derive1, IHIPC_derive2 |- *.
    apply satisfy_ind.
    tauto.
  + specialize (IHIPC_derive1 M CONTEXT).
    simpl in IHIPC_derive1; apply satisfy_ind in IHIPC_derive1.
    destruct IHIPC_derive1.
    - assert (CONTEXT_a: forall t0 : Term, (ctx;; a) t0 = true -> M |= t0).
      Focus 1. {
        intros.
        unfold ExtendContext in H3.
        destruct (term_eq t0 a).
        + subst; exact H2.
        + apply CONTEXT; auto.
      } Unfocus.
      exact (IHIPC_derive2 M CONTEXT_a).
    - assert (CONTEXT_b: forall t0 : Term, (ctx;; b) t0 = true -> M |= t0).
      Focus 1. {
        intros.
        unfold ExtendContext in H3.
        destruct (term_eq t0 b).
        + subst; exact H2.
        + apply CONTEXT; auto.
      } Unfocus.
      exact (IHIPC_derive3 M CONTEXT_b).
  + specialize (IHIPC_derive M CONTEXT).
    simpl in IHIPC_derive |- *.
    apply satisfy_ind.
    tauto.
  + specialize (IHIPC_derive M CONTEXT).
    simpl in IHIPC_derive |- *.
    apply satisfy_ind.
    tauto.
  + specialize (IHIPC_derive1 M CONTEXT).
    specialize (IHIPC_derive2 M CONTEXT).
    simpl in IHIPC_derive1, IHIPC_derive2 |- *.
    apply satisfy_ind in IHIPC_derive2.
    specialize (IHIPC_derive2 w (access_refl _)).
    tauto.
  + simpl.
    apply satisfy_ind.
    intros.
    rename M into M0.
    pose (Build_PointModel KS v) as M1.
    assert (CONTEXT_a: forall t0 : Term, (ctx;; a) t0 = true -> M1 |= t0).
    Focus 1. {
      intros.
      unfold ExtendContext in H2.
      destruct (term_eq t0 a).
      + subst; exact H1.
      + specialize (CONTEXT t0 H2).
        simpl.
        apply Kripke_Sat_mono with w; auto.
    } Unfocus.
    specialize (IHIPC_derive M1 CONTEXT_a).
    exact IHIPC_derive.
  + specialize (IHIPC_derive M CONTEXT).
    simpl in IHIPC_derive |- *.
    apply satisfy_ind in IHIPC_derive.
    tauto.
Qed.

End IPC.

Module IPC_Notation.
Notation "x && y" := (andp x y) (at level 40, left associativity) : IPC_scope.
Notation "x || y" := (orp x y) (at level 50, left associativity) : IPC_scope.
Notation "x --> y" := (impp x y) (at level 55, right associativity) : IPC_scope.
Notation "'FF'" := falsep : IPC_scope.
Notation "ctx ;; t" := (ExtendContext ctx t) (at level 65, left associativity) : IPC_scope.
Notation "M  |=  t" := (satisfy M t) (at level 60, no associativity) : IPC_scope.
Notation "|==  t" := (valid t) (at level 61, no associativity) : IPC_scope.
Notation "ctx  |==  t" := (sem_conseq ctx t) (at level 60, no associativity) : IPC_scope.
Notation "ctx  |--  t" := (derivable ctx t) (at level 60, no associativity) : IPC_scope.
Notation "|--  t" := (provable t) (at level 61, no associativity) : IPC_scope.
End IPC_Notation.

Module CanonicalModel.

Context {venv: Var_env}.

Existing Instance IPC.
Import IPC_Notation.
Local Open Scope IPC_scope.

Context (IPC_classic: forall ctx t, {ctx |-- t} + {~ ctx |-- t}).

Definition W := {w: Context &
                   (forall t, w |-- t -> w t = true) /\
                   (forall t1 t2, w (t1 || t2) = true -> w t1 = true \/ w t2 = true)}.

Definition R (w v: W) := match w, v with existT w _, existT v _ => forall t, w t = true -> v t = true end.

Definition gen (ctx: Context) : Context := fun t => if IPC_classic ctx t then true else false.

Lemma gen_derive: forall ctx t, ctx |-- t <-> gen ctx |-- t.
Proof.
  intros; split; intros.
  + apply assum.
    unfold gen.
    destruct (IPC_classic ctx t); tauto.
  + apply IPC_substitution with (gen ctx); auto.
    clear; intros.
    unfold gen in H.
    destruct (IPC_classic ctx t0); congruence.
Qed.

Definition Gen (ctx: Context) : W.
  exists (gen ctx).
  split.
  + intros.
    apply gen_derive in H.
    unfold gen.
    destruct (IPC_classic ctx t); congruence.
  +

Definition F: Frame.
  apply (Build_Frame W R).
  + intros.
    unfold R.
    destruct w0; simpl.
    intros; auto.
  + unfold R.
    intros u v w.
    destruct u, v, w.
    intros.
    specialize (H t).
    specialize (H0 t).
    tauto.
Defined.

Definition V (w: W) (v: Var) : bool := let (w, _) := w in (w (varp v)).

Definition M: Model.
  apply (Build_Model F V).
  intros w v ? x.
  simpl in H.
  unfold R in H; unfold V; destruct w, v.
  apply H.
Defined.

Instance CanonicalModel: KripkeSem.
  apply (Build_KripkeSem M (fun w t => let (w, _) := w in w t = true)).
  intros w t; revert w; induction t; intros [w Hw].
  + split; intros; [split |]; apply (proj1 Hw).
    - apply and_elim_l with t2.
      apply assum; auto.
    - apply and_elim_r with t1.
      apply assum; auto.
    - apply and_intro; apply assum; tauto.
  + split; [intro | intros [? | ?]].
    - exact (proj2 Hw t1 t2 H).
    - apply (proj1 Hw).
      apply or_intro_l.
      apply assum; auto.
    - apply (proj1 Hw).
      apply or_intro_r.
      apply assum; auto.
  + split; intros.
    - simpl in H0.
      destruct v as [v Hv].
      assert (IPC_derive (w;; t1) t2).
      Focus 1. {
        apply imp_elim with t1.
        + apply assum.
          unfold ExtendContext.
          destruct (term_eq t1 t1); congruence.
        + apply IPC_weakening with w.
          - clear.
            intros.
            unfold ExtendContext.
            destruct (term_eq t0 t1); congruence.
          - apply assum; auto.
      } Unfocus.
      apply (proj1 Hv).
      apply IPC_weakening with (w;; t1); auto.
      clear - H1 H0.
      unfold ExtendContext.
      intros.
      destruct (term_eq t0 t1).
      * subst. auto.
      * apply H0; auto.
    - apply (proj1 Hw).
      simpl in H.
      specialize (

Lemma complete_Kripke_IPC: strong_complete Kripke_sem IPC.
Proof.
  unfold strong_complete.
  intros.
  pose ( (fun w v => match w, v with existT w _, existT v _ => forall t, w t = true -> v t = true end)).  : Type := {
  Worlds: Type;
  access: Worlds -> Worlds -> bool;
  access_refl: forall w, access w w = true;
  access_trans: forall u v w, access u v = true -> access v w = true -> access u w = true
}.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.
Require Import VerdiRaft.RefinementCommonDefinitions.

Section EveryEntryWasCreatedHostLogInterface.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition every_entry_was_created_host_log (net : network) : Prop :=
    forall e h,
      In e (log (snd (nwState net h))) ->
      term_was_created net (eTerm e).

  Class every_entry_was_created_host_log_interface : Prop :=
    {
      every_entry_was_created_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          every_entry_was_created_host_log net
    }.
End EveryEntryWasCreatedHostLogInterface.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


Require Import propInv3.
Require Import verif_cond_5.
Require Import extra5.
Require Import ind_scheme.
Local Open Scope Z.

Theorem proof3_5: (startnewloop hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1) /\ cond5 ->
 (inv hands1 dryer1 ctrlState2 ctrlTimer2 timer1).

Proof.
intros.
split.
unfold propInv3.
inversion_clear H.
inversion_clear H1.
inversion_clear H2.
inversion_clear H3.
inversion_clear H4.
inversion_clear H5.
intros.
(*analysis of cases i<timer1 and i=timer1*)
elim Zle_lt_or_eq with i (timer1-(11-1)).
intros.
assert (Hstartnewloop : (startnewloop hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1)).
assumption.
apply startnewloop_to_propInv in H0.
elim H0 with i.
intros.
exists x.
split.
apply H8.
split.
apply H8.
split.
intros.
apply H8.
assumption.
apply H8.
split.
apply H5.
split.
inversion_clear Hstartnewloop.
auto with zarith.
apply H5.
(*case i=timer1-(11-1)*)
intros.
(*inductive proof*)
assert (Hdryer_hands : (forall k, (i<=k /\ k<i -> dryer1.[of_Z k]=ON /\ hands1.[of_Z k]=OFF))).
intros.
elimtype False.
auto with zarith.
assert (Hi_in_interval : (i<=i<=i+(11-1))).
auto with zarith.
generalize Hdryer_hands.
generalize Hi_in_interval.
apply generalize_i.

(*induction base *)
assert (Hbase : (ind_prove_pred dryer1 i (i+(11-1)) (i+(11-1)))).
unfold ind_prove_pred.
intros.
exists (i+(11-1)).
split.
auto with zarith.
split.
auto with zarith.
split.
assumption.
apply Zeq_plus_swap in H7.
rewrite H7.
right.
assumption.
(*apply inductive scheme*)
intro.
intro.
apply natlike_down_bound_ind with (fun z=> (ind_prove_pred dryer1 i (i+(11-1)) z)) (i+(11-1)) i l in Hbase.
apply Hbase.
(*inductive step*)
intros.
unfold ind_prove_pred.
intros.
assert (true_or_false : forall b : bool, b=true \/ b=false).
induction b.
left.
reflexivity.
right.
reflexivity.
(*induction on hands*)
elim true_or_false with hands1.[of_Z (Z.pred y)].
intro.
exists (Z.pred y).
split.
auto with zarith.
split.
auto with zarith.
split.
assumption.
right.
assumption.
intros.
(*induction on dryer*)
elim true_or_false with dryer1.[of_Z (Z.pred y)].
(*hands=OFF /\ dryer=ON*)
intros.
assert (Hpremise_y : (forall k, (i<=k /\ k<y -> dryer1.[of_Z k]=ON /\ hands1.[of_Z k]=OFF))).
intros.
elim Zle_lt_or_eq with k (Z.pred y).
intros.
apply H11.
split.
apply H14.
assumption.
intros.
rewrite H15.
split; assumption.
auto with zarith.
apply H10 in Hpremise_y.
elim Hpremise_y.
intros.
exists x.
split.
auto with zarith.
apply H14.
(*hands=OFF /\ dryer=OFF*)
intros.
exists (Z.pred y).
split.
auto with zarith.
split.
auto with zarith.
split.
assumption.
left.
assumption.
assumption.
apply H5.

apply extra5.
split.
inversion_clear H.
inversion_clear H0.
split.
apply H.
assumption.
apply H.
Qed.


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.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable s_ : Universe -> Universe -> Prop.
Variable notplus_ : Universe -> Universe -> Universe -> Prop.
Variable nat_ : Universe -> Prop.
Variable my_plus_ : Universe -> Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable dom_ : Universe -> Prop.

Variable x_ : Universe.
Variable num_0_ : Universe.

Variable initial_model_1 : (dom_ num_0_ /\ (dom_ x_ /\ (nat_ num_0_ /\ nat_ x_))).
Variable notplus_2 : (forall X Y Z : Universe, ((my_plus_ X Y Z /\ notplus_ X Y Z) -> goal_)).
Variable plusnull_3 : (forall X : Universe, (nat_ X -> my_plus_ X num_0_ X)).
Variable nullplus_4 : (forall X : Universe, (nat_ X -> my_plus_ num_0_ X X)).
Variable plussucc_5 : (forall X Y Z Y1 Z1 : Universe, ((my_plus_ X Y Z /\ (s_ Y Y1 /\ s_ Z Z1)) -> my_plus_ X Y1 Z1)).
Variable induction_instance_6 : (forall X : Universe, ((nat_ X /\ my_plus_ num_0_ num_0_ num_0_) -> (exists Y : Universe, (my_plus_ num_0_ X X \/ (dom_ X /\ (dom_ Y /\ (my_plus_ num_0_ X X /\ (s_ X Y /\ notplus_ num_0_ Y Y)))))))).
Variable succ_7 : (forall X : Universe, (nat_ X -> (exists Y : Universe, (dom_ Y /\ (nat_ Y /\ s_ X Y))))).

Theorem pa2_8 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


(* ******************************************************************************* *)
(** * 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.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


Require Import AutoDB.

Definition bedrock_test :=
  (ret (@Word.wmult 32
                    (Word.wplus  (IL.natToW 3) (IL.natToW 4))
                    (Word.wminus (IL.natToW 5) (IL.natToW 6)))).

Definition facade_test :=
  ret (SyntaxExpr.Binop
         IL.Times
         (SyntaxExpr.Var "$1")
         (SyntaxExpr.Var "$2")).

Eval compute in (eval (StringMap.StringMap.empty (Value nat)) (SyntaxExpr.Binop IL.Plus (SyntaxExpr.Const (IL.natToW 3)) (SyntaxExpr.Const (IL.natToW 3)))).