From stdpp Require Import gmap base relations.
From iris Require Import prelude.
From semantics.lib Require Export debruijn.
From semantics.ts.systemf Require Import lang notation parallel_subst types bigstep tactics.
From semantics.ts.systemf Require logrel binary_logrel.
From Equations Require Import Equations.

(** * Existential types and invariants *)
Implicit Types
  (Δ : nat)
  (Γ : typing_context)
  (v : val)
  (α : var)
  (e : expr)
  (A : type).

(** Here, we take the approach of encoding [assert],
  instead of adding it as a primitive to the language.
  This saves us from adding it to all of the existing proofs.
  But clearly it has the same reduction behavior.
 *)

Definition assert (e : expr) : expr :=
  if: e then #LitUnit else (#0 #0).
Lemma assert_true : rtc contextual_step (assert #true) #().
Proof.
  econstructor.
  { eapply base_contextual_step. constructor. }
  constructor.
Qed.
Lemma assert_false : rtc contextual_step (assert #false) (#0 #0).
Proof.
  econstructor. { eapply base_contextual_step. econstructor. }
  constructor.
Qed.

Definition Or (e1 e2 : expr) : expr :=
  if: e1 then #true else e2.
Definition And (e1 e2 : expr) : expr :=
  if: e1 then e2 else #false.
Notation "e1 '||' e2" := (Or e1 e2) : expr_scope.
Notation "e1 '&&' e2" := (And e1 e2) : expr_scope.

(** *** BIT *)
(* ∃ α, { bit : α, flip : α → α, get : α → bool } *)
Definition BIT : type := ∃: (#0 × (#0 → #0)) × (#0 → Bool).

Definition MyBit : val :=
  pack (#0,                  (* bit *)
        λ: "x", #1 - "x",    (* flip *)
        λ: "x", #0 < "x").   (* get *)

Lemma MyBit_typed n Γ :
  TY n; Γ ⊢ MyBit : BIT.
Proof. eapply (typed_pack _ _ _ Int); solve_typing. Qed.

Definition MyBit_instrumented : val :=
  pack (#0,                                                     (* bit *)
        λ: "x", assert (("x" = #0) || ("x" = #1));; #1 - "x",   (* flip *)
        λ: "x", assert (("x" = #0) || ("x" = #1));; #0 < "x").  (* get *)

Definition MyBoolBit : val :=
  pack (#false,                  (* bit *)
        λ: "x", UnOp NegOp "x",    (* flip *)
        λ: "x", "x").   (* get *)

Lemma MyBoolBit_typed n Γ :
  TY n; Γ ⊢ MyBoolBit : BIT.
Proof.
  eapply (typed_pack _ _ _ Bool); solve_typing.
  simpl. econstructor.
Qed.



Section unary_mybit.
  Import logrel.

  Lemma MyBit_instrumented_sem_typed δ :
    𝒱 BIT δ MyBit_instrumented.
  Proof.
    unfold BIT. simp type_interp.
    eexists. split; first done.
    pose_sem_type (λ x, x = #0 ∨ x = #1) as τ.
    { intros v [-> | ->]; done. }
    exists τ.
    simp type_interp.
    eexists _, _. split; first done.
    split.
    - simp type_interp. eexists _, _. split; first done. split.
      + simp type_interp. simpl. by left.
      + simp type_interp. eexists _, _. split; first done. split; first done.
        intros v'. simp type_interp; simpl.
        (* Note: this part of the proof is a bit different from the paper version, as we directly do a case split. *)
        intros [-> | ->].
        * exists #1. split; last simp type_interp; simpl; eauto.
          bs_steps_det. eapply bs_if_true; bs_steps_det.
          eapply bs_if_true; bs_steps_det.
        * exists #0. split; last simp type_interp; simpl; eauto.
          bs_steps_det. eapply bs_if_true; bs_steps_det.
          eapply bs_if_false; bs_steps_det.
    - simp type_interp. eexists _, _. split; first done. split; first done.
      intros v'. simp type_interp; simpl. intros [-> | ->].
      * exists #false. split; last simp type_interp; simpl; eauto.
        bs_steps_det. eapply bs_if_true; bs_steps_det. eapply bs_if_true; bs_steps_det.
      * exists #true. split; last simp type_interp; simpl; eauto.
        bs_steps_det. eapply bs_if_true; bs_steps_det. eapply bs_if_false; bs_steps_det.
  Qed.

End unary_mybit.


Section binary_mybit.
  Import binary_logrel.

  Lemma MyBit_MyBoolBit_sem_typed δ :
    𝒱 BIT δ MyBit MyBoolBit.
  Proof.
    unfold BIT. simp type_interp.
    eexists _, _. split_and!; try done.
    pose_sem_type (λ v w, (v = #0 ∧ w = #false) ∨ (v = #1 ∧ w = #true)) as τ.
    { intros v w [[-> ->] | [-> ->]]; done. }
    exists τ.
    simp type_interp.
    eexists _, _, _, _. split_and!; try done.
    simp type_interp.
    eexists _, _, _, _. split_and!; try done.
    - simp type_interp. simpl. naive_solver.
    - simp type_interp. eexists _, _, _, _. split_and!; try done.
      intros v w. simp type_interp. simpl.
      intros [[-> ->]|[-> ->]]; simpl; eexists _, _; split_and!; eauto; simpl.
      all: simp type_interp; simpl; naive_solver.
    - simp type_interp. eexists _, _, _, _. split_and!; try done.
      intros v w. simp type_interp. simpl.
      intros [[-> ->]|[-> ->]]; simpl.
      all: eexists _, _; split_and!; eauto; simpl.
      all: simp type_interp; eauto.
  Qed.

End binary_mybit.