From iris.algebra Require Import frac.
From iris.proofmode Require Import proofmode.
Require Import Eqdep_dec List.
From cap_machine Require Import rules logrel fundamental.
From cap_machine.examples Require Import template_adequacy macros_new.
From cap_machine Require Import proofmode.
Open Scope Z_scope.

Section counter.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ} {sealg:sealStoreG Σ}
          {nainv: logrel_na_invs Σ}
          `{MP: MachineParameters}.

  Definition N : namespace := nroot .@ "mincounter".

  (* In this example, we avoid computing offsets by hand, and instead define the
     code in two steps, computing the labels automatically (mimicking the steps
     a proper assembler would do). *)

  Definition counter_init0 (init code data end_: Z) : list Word :=
    (* init: *)
    encodeInstrsW [
      Mov r_t1 PC;
      Lea r_t1 (data-init)%Z;
      Mov r_t2 r_t1;
      Lea r_t2 1;
      Store r_t1 r_t2;
      Lea r_t1 (code-data)%Z;
      Subseg r_t1 code end_;
      Restrict r_t1 (encodePerm E);
      Mov r_t2 0;
      Jmp r_t0
    ].
  Definition counter_code0 (code data: Z) : list Word :=
    (* code: *)
    encodeInstrsW [
      Mov r_t1 PC;
      Lea r_t1 (data-code)%Z;
      Load r_t1 r_t1;
      Load r_t2 r_t1;
      Add r_t2 r_t2 1;
      Store r_t1 r_t2;
      Mov r_t1 0;
      Jmp r_t0
    ].
  Definition counter_data : list Word :=
    (* data: *)
    map WInt [7777 (* placeholder *); 0 (* current value of the counter *)]
    (* end: *).

  Definition code_off := Eval compute in length (counter_init0 0 0 0 0).
  Definition data_off := Eval compute in length (counter_code0 0 0).
  Definition end_off := Eval compute in length counter_data.

  Definition counter_init (init: Z) : list Word :=
    counter_init0 init (init + code_off) (init + code_off + data_off)
                  (init + code_off + data_off + end_off).

  Definition counter_code (code: Z) : list Word :=
    counter_code0 code (code + data_off).

  (* Specification for the init routine *)

  Local Ltac solve_addr' :=
    repeat match goal with x := _ |- _ => subst x end;
    unfold code_off, data_off, end_off in *; solve_addr.

  Lemma counter_init_spec (a_init: Addr) wadv w1 w2 wdat φ :
    let a_code := (a_init ^+ code_off)%a in
    let a_data := (a_init ^+ (code_off + data_off))%a in
    let a_end := (a_init ^+ (code_off + data_off + end_off))%a in
    ContiguousRegion a_init (code_off + data_off + end_off) →

   ⊢ (( PC ↦ᵣ WCap RWX a_init a_end a_init
      ∗ r_t0 ↦ᵣ wadv
      ∗ r_t1 ↦ᵣ w1
      ∗ r_t2 ↦ᵣ w2
      ∗ a_data ↦ₐ wdat
      ∗ codefrag a_init (counter_init a_init)
      ∗ ▷ (  PC ↦ᵣ updatePcPerm wadv
           ∗ r_t0 ↦ᵣ wadv
           ∗ r_t1 ↦ᵣ WCap E a_code a_end a_code
           ∗ r_t2 ↦ᵣ WInt 0
           ∗ a_data ↦ₐ WCap RWX a_init a_end (a_data ^+ 1)%a
           ∗ codefrag a_init (counter_init a_init)
           -∗ WP Seq (Instr Executable) {{ φ }}))
      -∗ WP Seq (Instr Executable) {{ φ }})%I.
  Proof.
    intros a_code a_data a_end.
    iIntros (Hcont) "(HPC & Hr0 & Hr1 & Hr2 & Hdat & Hprog & Hφ)".
    iGo "Hprog".
    { transitivity (Some a_data); auto. solve_addr'. }
    iGo "Hprog".
    { transitivity (Some a_code); auto. solve_addr'. }
    iGo "Hprog".
    { transitivity (Some a_code); auto. solve_addr'. }
    { transitivity (Some a_end); auto. solve_addr'. }
    solve_addr'.
    iGo "Hprog"; rewrite decode_encode_perm_inv //.
    iGo "Hprog". iApply "Hφ". iFrame.
    rewrite (_: (a_init ^+ 19) = a_data ^+ 1)%a //. solve_addr'.
  Qed.

  Lemma counter_code_spec (a_init: Addr) wcont w1 w2 φ :
    let a_code := (a_init ^+ code_off)%a in
    let a_data := (a_code ^+ data_off)%a in
    let a_end := (a_code ^+ (data_off + end_off))%a in
    ContiguousRegion a_code (data_off + end_off) →

  ⊢ (( inv (N.@"cap") (a_data ↦ₐ WCap RWX a_init a_end (a_data ^+ 1)%a)
     ∗ inv with_adv.invN (∃ n, (a_data ^+ 1)%a ↦ₐ WInt n ∗ ⌜0 ≤ n⌝)
     ∗ na_inv logrel_nais (N.@"code") (codefrag a_code (counter_code a_code))
     ∗ PC ↦ᵣ WCap RX a_code a_end a_code
     ∗ r_t0 ↦ᵣ wcont
     ∗ r_t1 ↦ᵣ w1
     ∗ r_t2 ↦ᵣ w2
     ∗ na_own logrel_nais ⊤
     ∗ ▷ (∀ (n: Z),
            PC ↦ᵣ updatePcPerm wcont
          ∗ r_t0 ↦ᵣ wcont
          ∗ r_t1 ↦ᵣ WInt 0
          ∗ r_t2 ↦ᵣ WInt n
          ∗ na_own logrel_nais ⊤
          -∗ WP Seq (Instr Executable) {{ φ }}))
     -∗ WP Seq (Instr Executable) {{ φ }})%I.
  Proof.
    intros a_code a_data a_end.
    iIntros (Hcont) "(#HIcap & #HIv & #HIcode & HPC & Hr0 & Hr1 & Hr2 & Hna & Hφ)".
    assert (Ha_code: a_code = (a_init ^+ code_off)%a) by done. clearbody a_code.
    (* open the invariant containing the code *)
    iMod (na_inv_acc logrel_nais with "HIcode Hna") as "(>Hcode & Hna & Hclose_code)".
    done. done.

    iGo "Hcode".
    { transitivity (Some a_data); auto. solve_addr'. }
    (* load from a_data *)
    wp_instr.
    iMod (inv_acc with "HIcap") as "[>Hcap Hclose]"; auto.
    iInstr "Hcode".
    iMod ("Hclose" with "Hcap") as "_". iModIntro. wp_pure.
    (* load from a_data+1 *)
    wp_instr.
    iMod (inv_acc with "HIv") as "[>Hv Hclose]"; auto.
    iDestruct "Hv" as (n) "(Hn & %Hn)".
    iInstr "Hcode".
    { split. solve_pure. solve_addr'. }
    iMod ("Hclose" with "[Hn]") as "_". { iNext. iExists _. by iFrame. }
    iModIntro. wp_pure.
    (* add *)
    iInstr "Hcode".
    (* store to a_data+1 *)
    wp_instr.
    iMod (inv_acc with "HIv") as "[>Hv Hclose]"; auto.
    iDestruct "Hv" as (n') "(Hn' & %Hn')".
    iInstr "Hcode". solve_addr'.
    iMod ("Hclose" with "[Hn']") as "_".
    { iNext. iExists _. iFrame. iPureIntro. lia. }
    iModIntro. wp_pure.
    (* cont *)
    iGo "Hcode".

    (* close the invariant with the code *)
    iMod ("Hclose_code" with "[$Hcode $Hna]") as "Hna".
    iApply "Hφ". iFrame.
  Qed.

  Lemma counter_full_run_spec (a_init: Addr) b_adv e_adv w1 w2 wdat rmap adv :
    let a_code := (a_init ^+ code_off)%a in
    let a_data := (a_code ^+ data_off)%a in
    let a_end := (a_code ^+ (data_off + end_off))%a in
    ContiguousRegion a_init (code_off + data_off + end_off) →
    dom rmap = all_registers_s ∖ {[ PC; r_t0; r_t1; r_t2 ]} →
    Forall (λ w, is_z w = true) adv →
    (b_adv + length adv)%a = Some e_adv →

  ⊢ (   inv with_adv.invN (∃ n : Z, (a_data ^+ 1)%a ↦ₐ WInt n ∗ ⌜0 ≤ n⌝)
      ∗ PC ↦ᵣ WCap RWX a_init a_end a_init
      ∗ r_t0 ↦ᵣ WCap RWX b_adv e_adv b_adv
      ∗ r_t1 ↦ᵣ w1
      ∗ r_t2 ↦ᵣ w2
      ∗ ([∗ map] r↦w ∈ rmap, r ↦ᵣ w ∗ ⌜is_z w = true⌝)
      ∗ codefrag a_init (counter_init a_init)
      ∗ codefrag a_code (counter_code a_code)
      ∗ a_data ↦ₐ wdat
      ∗ ([∗ map] a↦w ∈ mkregion b_adv e_adv adv, a ↦ₐ w)
      ∗ na_own logrel_nais ⊤
      -∗ WP Seq (Instr Executable) {{ λ _, True }})%I.
  Proof.
    iIntros (? ? ? ? Hrdom ? ?) "(#HI & HPC & Hr0 & Hr1 & Hr2 & Hrmap & Hinit & Hcode & Hdat & Hadv & Hna)".

    (* The capability to the adversary is safe and we can also jmp to it *)
    iDestruct (mkregion_sepM_to_sepL2 with "Hadv") as "Hadv". done.
    iDestruct (region_integers_alloc' _ _ _ b_adv _ RWX with "Hadv") as ">#Hadv". done.
    iDestruct (jmp_to_unknown with "Hadv") as "#Hcont".

    iApply (counter_init_spec a_init with "[-]"). solve_addr'. iFrame.
    simpl. rewrite (_: a_init ^+ (_ + _ + _) = a_end)%a. 2: solve_addr'. iFrame.
    rewrite (_: a_init ^+ (_ + _) = a_data)%a. 2: solve_addr'. iFrame.
    iNext. iIntros "(HPC & Hr0 & Hr1 & Hr2 & Hdat & _)".

    (* Allocate an invariant for the points-to at a_data containing the capability to a_data+1 *)
    iMod (inv_alloc (N.@"cap") _ (a_data ↦ₐ WCap RWX a_init a_end (a_data ^+ 1)%a)
            with "Hdat") as "#HIcap".

    (* Allocate a non-atomic invariant for the code of the code routine *)
    iMod (na_inv_alloc logrel_nais _ (N.@"code") (codefrag a_code (counter_code a_code))
           with "Hcode") as "#HIcode".

    (* Show that the E-capability to the code: routine is safe *)
    iAssert (interp (WCap E a_code a_end a_code)) as "#Hcode_safe".
    { rewrite /interp /= (fixpoint_interp1_eq (WCap E _ _ _)) /=. iIntros (rr).
      iIntros "!> !> ([%Hrfull #Hrsafe] & Hrr & Hna)". rewrite /interp_conf.

      (* unpack the registers *)
      destruct (Hrfull r_t0) as [w0' Hr0'].
      destruct (Hrfull r_t1) as [w1' Hr1'].
      destruct (Hrfull r_t2) as [w2' Hr2'].
      unfold registers_mapsto.
      rewrite -insert_delete_insert.
      iDestruct (big_sepM_insert with "Hrr") as "[HPC Hrr]".
        by rewrite lookup_delete.
      iDestruct (big_sepM_delete _ _ r_t0 with "Hrr") as "[Hr0 Hrr]".
        by rewrite lookup_delete_ne //.
      iDestruct (big_sepM_delete _ _ r_t1 with "Hrr") as "[Hr1 Hrr]".
        by rewrite !lookup_delete_ne //.
      iDestruct (big_sepM_delete _ _ r_t2 with "Hrr") as "[Hr2 Hrr]".
        by rewrite !lookup_delete_ne //.

      (* the continuation is safe, and we can jump to it *)
      iAssert (interp w0') as "Hv0". by iApply "Hrsafe"; eauto; done.
      iDestruct (jmp_to_unknown with "[$Hv0]") as "#Hcont_prog".

      (* apply the spec *)
      iApply (counter_code_spec a_init with "[-]"). solve_addr'.
      rewrite (_: (a_init ^+ _) ^+ _ = a_data)%a. 2: solve_addr'.
      rewrite (_: (a_init ^+ _) ^+ (_ + _) = a_end)%a. 2: solve_addr'.
      iFrame. iFrame "HIcap HIcode HI".
      iIntros "!>" (n) "(HPC & Hr0 & Hr1 & Hr2 & Hcode)".

      (* put the registers back together *)
      iDestruct (big_sepM_sep _ (λ k v, interp v)%I with "[Hrr]") as "Hrr".
      { iSplitL. by iApply "Hrr". iApply big_sepM_intro. iModIntro.
        iIntros (r' ? HH). repeat eapply lookup_delete_Some in HH as [? HH].
        iApply ("Hrsafe" $! r'); auto. }
      iDestruct (big_sepM_insert with "[$Hrr $Hr2]") as "Hrr". by rewrite lookup_delete.
        by iApply interp_int. rewrite insert_delete_insert.
      iDestruct (big_sepM_insert with "[$Hrr $Hr1]") as "Hrr".
        by rewrite lookup_insert_ne // lookup_delete.
        by iApply interp_int. rewrite insert_commute // insert_delete_insert.
      iDestruct (big_sepM_insert with "[$Hrr $Hr0]") as "Hrr".
        by rewrite !lookup_insert_ne // lookup_delete.
        by iApply "Hv0". do 2 rewrite (insert_commute _ r_t0) //;[]. rewrite insert_delete_insert.

      (* jmp to continuation *)
      iApply "Hcont_prog". 2: iFrame. iPureIntro.
      rewrite !dom_insert_L dom_delete_L regmap_full_dom //. set_solver+. }

    (* put the registers back together *)
    iDestruct (big_sepM_mono _ (λ k v, k ↦ᵣ v ∗ interp v)%I with "Hrmap") as "Hrmap".
    { intros ? w ?. cbn. iIntros "[? %Hw]". iFrame. destruct w; try inversion Hw.
      iApply interp_int. }
    iDestruct (big_sepM_insert _ _ r_t2 with "[$Hrmap $Hr2]") as "Hrmap".
      by rewrite -not_elem_of_dom Hrdom; set_solver+.
      by iApply interp_int.
    iDestruct (big_sepM_insert _ _ r_t1 with "[$Hrmap $Hr1]") as "Hrmap".
      by rewrite lookup_insert_ne // -not_elem_of_dom Hrdom; set_solver+.
      by iApply "Hcode_safe".
    iDestruct (big_sepM_insert _ _ r_t0 with "[$Hrmap $Hr0]") as "Hrmap".
      by rewrite !lookup_insert_ne // -not_elem_of_dom Hrdom; set_solver+.
      by iApply "Hadv".

    iApply (wp_wand with "[-]").
    { iApply "Hcont". 2: iFrame. iPureIntro.
      rewrite !dom_insert_L Hrdom !singleton_union_difference_L !all_registers_union_l. set_solver+. }
    eauto.
  Qed.

End counter.

Local Ltac solve_addr' :=
  repeat match goal with x := _ |- _ => subst x end;
  unfold code_off, data_off, end_off in *; solve_addr.

Program Definition counter_inv (a_init: Addr) : memory_inv :=
  MkMemoryInv
    (λ m, ∃ n, m !! (a_init ^+ (code_off + data_off + 1))%a = Some (WInt n) ∧ 0 ≤ n)
    {[ (a_init ^+ (code_off + data_off + 1))%a ]}
    _.
Next Obligation.
  intros a_init m m' H. cbn in *.
  specialize (H (a_init ^+ (code_off + data_off + 1))%a). feed specialize H. by set_solver.
  destruct H as [w [? ?] ]. by simplify_map_eq.
Qed.

Definition counterN : namespace := nroot .@ "counter".

Lemma adequacy `{MachineParameters} (P Adv: prog) (m m': Mem) (reg reg': Reg) es:
  prog_instrs P =
    counter_init (prog_start P) ++
    counter_code (prog_start P ^+ code_off)%a ++
    counter_data →
  with_adv.is_initial_memory P Adv m →
  with_adv.is_initial_registers P Adv reg r_t0 →
  Forall (λ w, is_z w = true) (prog_instrs Adv) →

  rtc erased_step ([Seq (Instr Executable)], (reg, m)) (es, (reg', m')) →
  ∃ n, m' !! (prog_start P ^+ (code_off + data_off + 1))%a = Some (WInt n) ∧ 0 ≤ n.
Proof.
  intros HP Hm Hr HAdv Hstep.
  generalize (prog_size P). rewrite HP /=. intros.

  (* Prove the side-conditions over the memory invariant *)
  eapply (with_adv.template_adequacy P Adv (counter_inv (prog_start P)) r_t0 m m' reg reg' es); auto.
  { cbn. unfold with_adv.is_initial_memory in Hm. destruct Hm as (Hm & _ & _).
    exists 0; split; [| done]. eapply lookup_weaken; [| apply Hm]. rewrite /prog_region mkregion_lookup.
    { exists (Z.to_nat (code_off + data_off + 1)). split. done. rewrite HP; done. }
    { apply prog_size. } }
  { cbn. apply elem_of_subseteq_singleton, elem_of_list_to_set, elem_of_finz_seq_between. solve_addr'. }

  intros * Hss * Hrdom. iIntros "(#HI & Hna & HPC & Hr0 & Hrmap & Hadv & Hprog)".
  set (a_init := prog_start P) in *.
  set (a_code := (a_init ^+ code_off)%a) in *.
  set (a_data := (a_code ^+ data_off)%a) in *.

  (* Extract the code & data regions from the program resources *)
  iAssert (codefrag a_init (counter_init a_init) ∗
           codefrag a_code (counter_code a_code) ∗
           (∃ w, a_data ↦ₐ w))%I
    with "[Hprog]" as "(Hinit & Hcode & Hdat)".
  { rewrite /codefrag /region_mapsto.
    set M := filter _ _.
    set Minit := mkregion a_init a_code (counter_init a_init).
    set Mcode := mkregion a_code a_data (counter_code a_code).
    set Mdat := mkregion a_data (a_data ^+ 1)%a [WInt 7777].

    assert (Mcode ##ₘ Mdat).
    { apply map_disjoint_spec.
      intros ? ? ? [? [? ?%lookup_lt_Some] ]%mkregion_lookup [? [? ?%lookup_lt_Some] ]%mkregion_lookup.
      all: solve_addr'. }

    assert (Minit ##ₘ (Mcode ∪ Mdat)).
    { apply map_disjoint_spec.
      intros ? ? ? [? [? ?%lookup_lt_Some] ]%mkregion_lookup.
      2: solve_addr'. intros [HH|HH]%lookup_union_Some; auto.
      all: apply mkregion_lookup in HH as [? [? ?%lookup_lt_Some] ]; solve_addr'. }

    assert (Minit ∪ (Mcode ∪ Mdat) ⊆ M) as HM.
    { apply map_subseteq_spec. intros a w. intros [Ha| [Ha|Ha]%lookup_union_Some]%lookup_union_Some.
      4,5: assumption.
      all: apply mkregion_lookup in Ha as [i [? HH] ]; [| solve_addr'].
      all: apply map_filter_lookup_Some_2;
        [| cbn; apply not_elem_of_singleton; apply lookup_lt_Some in HH; solve_addr'].
      all: subst; rewrite mkregion_lookup; [| rewrite HP; solve_addr'].
      { eexists. split; eauto. rewrite HP. by apply lookup_app_l_Some. }
      { exists (Z.to_nat (i+code_off)). split. solve_addr'. rewrite HP.
        apply lookup_app_Some. right. split. solve_addr'. apply lookup_app_l_Some.
        rewrite (_: _ - _ = i)%nat //. solve_addr'. }
      { exists (Z.to_nat (code_off + data_off)). destruct i; [| by inversion HH]. split. solve_addr'.
        rewrite HP. apply lookup_app_Some. right. split. solve_addr'.
        apply lookup_app_Some. right. split. solve_addr'. done. } }

    iDestruct (big_sepM_subseteq with "Hprog") as "Hprog". apply HM.
    iDestruct (big_sepM_union with "Hprog") as "[Hinit Hprog]". assumption.
    iDestruct (big_sepM_union with "Hprog") as "[Hcode Hdat]". assumption.
    iDestruct (mkregion_sepM_to_sepL2 with "Hinit") as "Hinit". solve_addr'.
    iDestruct (mkregion_sepM_to_sepL2 with "Hcode") as "Hcode". solve_addr'.
    iDestruct (mkregion_sepM_to_sepL2 with "Hdat") as "Hdat". solve_addr'.
    iFrame. iExists _. rewrite finz_seq_between_cons. cbn. by iDestruct "Hdat" as "[? ?]".
    solve_addr'. }
  iDestruct "Hdat" as (wdat) "Hdat".

  assert (is_Some (rmap !! r_t1)) as [w1 Hr1].
  { rewrite -elem_of_dom Hrdom. set_solver+. }
  assert (is_Some (rmap !! r_t2)) as [w2 Hr2].
  { rewrite -elem_of_dom Hrdom. set_solver+. }
  iDestruct (big_sepM_delete _ _ r_t1 with "Hrmap") as "[[Hr1 _] Hrmap]"; eauto.
  iDestruct (big_sepM_delete _ _ r_t2 with "Hrmap") as "[[Hr2 _] Hrmap]".
    by rewrite lookup_delete_ne //.

  iApply (counter_full_run_spec with "[$Hadv $Hr0 $Hr1 $Hr2 $Hinit $Hrmap $Hna $Hdat $Hcode HPC]"); auto.
  solve_addr'. by rewrite !dom_delete_L Hrdom; set_solver+. by apply prog_size.
  rewrite (_: _ ^+ (_ + _) = prog_end P)%a. 2: solve_addr'. iFrame.

  (* Show the invariant for the counter value using the invariant from the adequacy theorem *)
  iApply (inv_alter with "HI").
  iIntros "!> !> H". rewrite /minv_sep. iDestruct "H" as (mι) "(Hm & %Hmιdom & %Hι)".
  cbn in Hι. destruct Hι as (n & Hι & Hn).
  rewrite (_: a_init ^+ _ = (a_data ^+ 1))%a in Hι. 2: solve_addr'.
  iDestruct (big_sepM_delete _ _ (a_data ^+ 1)%a (WInt n) with "Hm") as "[Hn Hm]". done.
  iSplitL "Hn". by eauto. iIntros "Hn'". iDestruct "Hn'" as (n') "(Hn' & %)".
  iExists (<[ (a_data ^+ 1)%a := WInt n' ]> mι). iSplitL "Hm Hn'".
  { iDestruct (big_sepM_insert with "[$Hm $Hn']") as "Hm". by apply lookup_delete.
    rewrite insert_delete_insert //. }
  iPureIntro. split. rewrite dom_insert_L Hmιdom /Hmιdom /=. 2: exists n'.
  all: rewrite (_: a_init ^+ _ = (a_data ^+ 1))%a; [| solve_addr']. set_solver+.
  rewrite lookup_insert //.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Asymmetric Patterns.
Set Implicit Arguments.
Unset Strict Implicit.

Require Import Transitions.
Require Import LList.

Section Trace_DEF.

Variable L : LTS.

Let state := LTS_State L.
Definition trace := LList state.

Variable init : state.

CoInductive exec : state -> Type :=
  | exec_init : exec init
  | exec_trans :
      forall (s s' : state) (a : LTS_Act L),
      exec s -> LTS_Trans s a s' -> exec s'.

CoFixpoint LList_of_exec  : forall s : state, exec s -> trace :=
  fun s e =>
  match e with
  | exec_init => LNil state
  | exec_trans s s' a e' _ => LCons s' (LList_of_exec e')
  end.

CoInductive is_trace : trace -> state -> Prop :=
  | is_trace_LNil : is_trace (LNil state) init
  | is_trace_LCons :
      forall (l : trace) (s s' : state) (a : LTS_Act L),
      is_trace l s -> LTS_Trans s a s' -> is_trace (LCons s' l) s'.

End Trace_DEF.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Import type_sys_useful.
Require Import dest_close.

Lemma eq_term_equals_per_tunion_eq_if {p} :
  forall (eqa1 eqa2 : per(p)) (eqb1 : per-fam(eqa1)) (eqb2 : per-fam(eqa2)),
    eqa1 <=2=> eqa2
    -> (forall (a1 a2 : CTerm) (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
          (eqb1 a1 a2 e1) <=2=> (eqb2 a1 a2 e2))
    -> (per_tunion_eq eqa1 eqb1) <=2=> (per_tunion_eq eqa2 eqb2).
Proof.
  introv eqt1 eqt2.
  introv; split; intro k; induction k.

  - apply @tunion_eq_cl with (t := t); sp.

  - dup e as e'; apply eqt1 in e'.
    apply @tunion_eq_eq with (a1 := a1) (a2 := a2) (e := e'); sp; spcast.
    apply (eqt2 a1 a2 e e'); auto.

  - apply @tunion_eq_cl with (t := t); sp.

  - dup e as e'; apply eqt1 in e'.
    apply @tunion_eq_eq with (a1 := a1) (a2 := a2) (e := e'); sp; spcast.
    apply (eqt2 a1 a2 e' e); auto.
Qed.

Lemma per_tunion_eq_sym {p} :
  forall (eqa : per(p)) eqb t1 t2,
    (forall (a1 a2 : CTerm) (e : eqa a1 a2),
       term_equality_symmetric (eqb a1 a2 e))
    -> per_tunion_eq eqa eqb t1 t2
    -> per_tunion_eq eqa eqb t2 t1.
Proof.
  introv tesb per.
  induction per.
  apply @tunion_eq_cl with (t := t); sp.
  apply @tunion_eq_eq with (a1 := a1) (a2 := a2) (e := e); sp.
  apply tesb; auto.
Qed.

Lemma per_tunion_eq_trans {p} :
  forall (eqa : per(p)) eqb t1 t2 t3,
    per_tunion_eq eqa eqb t1 t2
    -> per_tunion_eq eqa eqb t2 t3
    -> per_tunion_eq eqa eqb t1 t3.
Proof.
  introv per1 per2.
  apply tunion_eq_cl with (t := t2); sp.
Qed.

Lemma per_tunion_eq_cequiv {p} :
  forall lib (eqa : per(p)) eqb t t',
    (forall (a1 a2 : CTerm) (e : eqa a1 a2),
       term_equality_symmetric (eqb a1 a2 e))
    -> (forall (a1 a2 : CTerm) (e : eqa a1 a2),
       term_equality_transitive (eqb a1 a2 e))
    -> (forall (a1 a2 : CTerm) (e : eqa a1 a2),
          term_equality_respecting lib (eqb a1 a2 e))
    -> t ~=~(lib) t'
    -> per_tunion_eq eqa eqb t t
    -> per_tunion_eq eqa eqb t t'.
Proof.
  introv tes tet ter ceq per.
  revert_dependents t'.
  induction per; introv ceq.
  apply IHper2; auto.
  apply @tunion_eq_eq with (a1 := a1) (a2 := a2) (e := e); sp.
  apply (ter a1 a2 e t2 t'); auto.
  apply tet with (t2 := t1); auto.
  apply tes; auto.
Qed.

Lemma close_type_system_tunion {p} :
  forall lib (ts : cts(p))
         T T'
         (eq : per)
         A A' v v' B B' eqa eqb,
    type_system lib ts
    -> defines_only_universes lib ts
    -> computes_to_valc lib T (mkc_tunion A v B)
    -> computes_to_valc lib T' (mkc_tunion A' v' B')
    -> close lib ts A A' eqa
    -> (forall (a a' : CTerm) (e : eqa a a'),
          close lib ts (substc a v B) (substc a' v' B') (eqb a a' e))
    -> (forall (a a' : CTerm) (e : eqa a a'),
          type_system lib ts ->
          defines_only_universes lib ts ->
          type_sys_props lib (close lib ts) (substc a v B) (substc a' v' B')
                         (eqb a a' e))
    -> (forall t t' : CTerm,
          eq t t' <=> per_tunion_eq eqa eqb t t')
    -> per_tunion lib (close lib ts) T T' eq
    -> type_sys_props lib (close lib ts) A A' eqa
    -> type_sys_props lib (close lib ts) T T' eq.
Proof.
  introv X X0 c1 c2 X1 clb recb eqiff per IHX1.

  rw @type_sys_props_iff_type_sys_props3.
  prove_type_sys_props3 SCase; intros.

  + SCase "uniquely_valued".
    dclose_lr;
    try (complete (apply defines_only_universes_tunion_L with (T2 := T3) (eq2 := eq') in per; sp));
    try (complete (apply defines_only_universes_tunion_R with (T2 := T3) (eq2 := eq') in per; sp)).

    SSCase "CL_tunion".
    allunfold @per_tunion; exrepd.
    generalize (eq_term_equals_type_family lib T T3 eqa0 eqa eqb0 eqb (close lib ts) A v B A' v' B' mkc_tunion); intro i.
    repeat (autodimp i hyp; try (complete (introv ee; eqconstr ee; sp))); repnd.

    generalize (eq_term_equals_type_family lib T T' eqa1 eqa eqb1 eqb (close lib ts) A v B A' v' B' mkc_tunion); intro j.
    repeat (autodimp j hyp; try (complete (introv ee; eqconstr ee; sp))); repnd.

    apply eq_term_equals_trans with (eq2 := per_tunion_eq eqa1 eqb1); auto.
    apply eq_term_equals_trans with (eq2 := per_tunion_eq eqa0 eqb0); auto;
    try (complete (apply eq_term_equals_sym; auto)).

    apply eq_term_equals_per_tunion_eq_if; auto.

    apply eq_term_equals_trans with (eq2 := eqa); auto.
    apply eq_term_equals_sym; auto.

    introv.
    dup e2 as e3.
    rw <- i0 in e3.
    apply eq_term_equals_trans with (eq2 := eqb a1 a2 e3); auto.
    apply eq_term_equals_sym; auto.

  + SCase "type_symmetric"; repdors; subst; dclose_lr;
    apply CL_tunion;
    clear per;
    allunfold @per_tunion; exrepd;
    unfold per_tunion;
    exists eqa0 eqb0; sp;
    allrw <-; sp.
    apply eq_term_equals_trans with (eq2 := eq); auto.
    apply eq_term_equals_sym; auto.

  + SCase "type_value_respecting"; repdors; subst;
    apply CL_tunion; unfold per_tunion; exists eqa eqb; sp.

    duplicate c1 as ct.
    apply @cequivc_mkc_tunion with (T' := T3) in ct; sp.

    apply @type_family_cequivc
          with
          (A1 := A)
          (v1 := v)
          (B1 := B)
          (A2 := A'0)
          (v2 := v'0)
          (B2 := B'0)
          (A := A')
          (v := v')
          (B := B'); sp.

    duplicate c2 as ct.
    apply @cequivc_mkc_tunion with (T' := T3) in ct; sp.

    apply @type_family_cequivc2
          with
          (A1 := A')
          (v1 := v')
          (B1 := B')
          (A2 := A'0)
          (v2 := v'0)
          (B2 := B'0)
          (A := A)
          (v := v)
          (B := B); sp.

  + SCase "term_symmetric".
    unfold term_equality_symmetric; introv eqts.
    onedtsp e pp p0 p1 c t t0 t3 tygs tygt dum.
    apply eqiff; apply eqiff in eqts; exrepnd.
    apply per_tunion_eq_sym; auto.
    introv.
    pose proof (recb a1 a2 e0) as h; repeat (autodimp h hyp).
    onedtsp x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11; auto.

  + SCase "term_transitive".
    unfold term_equality_transitive; sp.
    apply eqiff; sp.
    assert (eq t1 t2) as eq12 by auto.
    assert (eq t2 t3) as eq23 by auto.
    rw eqiff in eq12; rw eqiff in eq23; exrepnd.
    apply (per_tunion_eq_trans eqa eqb t1 t2 t3); auto.

  + SCase "term_value_respecting".
    unfold term_equality_respecting; sp.
    apply eqiff; sp.
    assert (eq t t) as eqtt by auto.
    apply eqiff in eqtt; exrepnd.
    apply (per_tunion_eq_cequiv lib eqa eqb t t'); auto;
    introv;
    pose proof (recb a1 a2 e) as h; repeat (autodimp h hyp);
    onedtsp x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11; auto.

  + SCase "type_gsymmetric"; repdors; subst; split; sp; dclose_lr;
    apply CL_tunion;
    clear per;
    allunfold @per_tunion; exrepd.

    (* 1 *)
    generalize (eq_term_equals_type_family
                  lib T T3 eqa0 eqa eqb0 eqb (close lib ts)
                  A v B A' v' B' mkc_tunion); intro i.
    repeat (autodimp i hyp; try (complete (introv ee; eqconstr ee; sp))).
    repnd.

    exists eqa eqb; sp.

    apply eq_term_equals_trans with (eq2 := per_tunion_eq eqa0 eqb0); auto.
    apply eq_term_equals_per_tunion_eq_if; auto.
    apply eq_term_equals_sym; auto.

    (* 2 *)
    generalize (eq_term_equals_type_family2
                  lib T3 T eqa0 eqa eqb0 eqb (close lib ts)
                  A v B A' v' B' mkc_tunion); intro i;
    repeat (autodimp i hyp; try (complete (introv ee; eqconstr ee; sp)));
    repnd.

    exists eqa eqb; sp.

    apply eq_term_equals_trans with (eq2 := per_tunion_eq eqa0 eqb0); auto.
    apply eq_term_equals_per_tunion_eq_if; auto.
    apply eq_term_equals_sym; auto.

  + SCase "type_gtransitive"; sp.

  + SCase "type_mtransitive".
    repdors; subst; dclose_lr;
    try (move_term_to_top (per_tunion lib (close lib ts) T T4 eq2));
    try (move_term_to_top (per_tunion lib (close lib ts) T' T4 eq2)).

    (* 1 *)
    clear per.
    allunfold @per_tunion; exrepd.

    generalize (eq_term_equals_type_family2
                  lib T3 T eqa1 eqa eqb1 eqb (close lib ts)
                  A v B A' v' B' mkc_tunion); intro i.
    repeat (autodimp i hyp; try (complete (introv ee; eqconstr ee; sp))).
    repnd.

    generalize (type_family_trans2
                  lib mkc_tunion (close lib ts) T3 T T4 eqa eqb eqa0 eqb0 A v B A' v' B'); intro j.
    repeat (autodimp j hyp; try (complete (introv ee; eqconstr ee; sp))).
    repnd.

    dands; apply CL_tunion; unfold per_tunion; exists eqa eqb; sp; allrw.

    eapply eq_term_equals_trans; eauto.
    apply eq_term_equals_per_tunion_eq_if; auto.
    apply eq_term_equals_sym; auto.

    eapply eq_term_equals_trans; eauto.
    apply eq_term_equals_per_tunion_eq_if; auto.
    apply eq_term_equals_sym; auto.
    introv.
    apply eq_term_equals_sym; auto.

    (* 2 *)
    clear per.
    allunfold @per_tunion; exrepd.

    generalize (eq_term_equals_type_family2
                  lib T3 T' eqa1 eqa eqb1 eqb (close lib ts)
                  A' v' B' A v B mkc_tunion); intro i.
    repeat (autodimp i hyp;
            try (complete (introv ee; eqconstr ee; sp));
            try (complete (apply type_sys_props_sym; sp))).
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
    intros.
    apply type_sys_props_sym.
    apply type_sys_props_eqb_comm; sp.
    apply tet with (t2 := a'); sp.
    apply tet with (t2 := a); sp.
    repnd.

    generalize (type_family_trans2
                  lib mkc_tunion (close lib ts) T3 T' T4 eqa eqb eqa0 eqb0 A' v' B' A v B); intro j.
    repeat (autodimp j hyp;
            try (complete (introv ee; eqconstr ee; sp));
            try (complete (apply type_sys_props_sym; sp))).
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
    intros.
    apply type_sys_props_sym.
    apply type_sys_props_eqb_comm; sp.
    apply tet with (t2 := a'); sp.
    apply tet with (t2 := a); sp.
    repnd.

    dands; apply CL_tunion; unfold per_tunion; exists eqa eqb; sp; allrw.

    eapply eq_term_equals_trans; eauto.
    apply eq_term_equals_per_tunion_eq_if; auto.
    apply eq_term_equals_sym; auto.

    eapply eq_term_equals_trans; eauto.
    apply eq_term_equals_per_tunion_eq_if; auto.
    apply eq_term_equals_sym; auto.
    introv.
    apply eq_term_equals_sym; auto.
Qed.


(* Distributed under the terms of the MIT license. *)
From MetaCoq.Utils Require Import utils.
From MetaCoq.Common Require Import config Universes.
From MetaCoq.Template Require Import Loader.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTyping PCUICSN PCUICLiftSubst.
From MetaCoq.SafeChecker Require Import PCUICErrors PCUICWfEnv PCUICWfEnvImpl PCUICTypeChecker PCUICSafeChecker.
From Equations Require Import Equations.

Import MCMonadNotation.
Global Existing Instance default_checker_flags.
Global Existing Instance default_normalizing.

(* ********************************************************* *)
(* In this file we define a small plugin which proves        *)
(* the identity theorem for any sort using the safe checker. *)
(* ********************************************************* *)

Definition bAnon := {| binder_name := nAnon; binder_relevance := Relevant |}.
Definition bNamed s := {| binder_name := nNamed s; binder_relevance := Relevant |}.

Definition tImpl X Y := tProd bAnon X (lift0 1 Y).

Definition univ := Level.Level "s".

(* TODO move to SafeChecker *)

Definition gctx : global_env_ext :=
  ({| universes := (LS.union (LevelSet.singleton Level.lzero) (LevelSet.singleton univ), ConstraintSet.empty);
      declarations := []; retroknowledge := Retroknowledge.empty |}, Monomorphic_ctx).

(** We use the environment checker to produce the proof that gctx, which is a singleton with only
    universe "s" declared is well-formed. *)

Definition kername_of_string (s : string) : kername :=
  (MPfile [], s).

Global Program Instance fake_guard_impl : abstract_guard_impl :=
{| guard_impl := fake_guard_impl |}.
Next Obligation. Admitted.

Global Existing Instance normalization. (* to convert from Normalization to NormalizationIn *)
Global Instance assume_normalization : Normalization.
Admitted.

Definition make_wf_env_ext (Σ : global_env_ext) : EnvCheck wf_env_ext wf_env_ext :=
  '(exist Σ' pf) <- check_wf_ext optimized_abstract_env_impl Σ ;;
  ret Σ'.

Definition gctx_wf_env : wf_env_ext.
Proof.
  let wf_proof := eval hnf in (make_wf_env_ext gctx) in
  match wf_proof with
  | CorrectDecl _ ?x => exact x
  | _ => fail "Couldn't prove the global environment is well-formed"
  end.
Defined.

(** There is always a proof of `forall x : Sort s, x -> x` *)

Definition inh (Σ : wf_env_ext) Γ T := (∑ t, forall Σ0 : global_env_ext, abstract_env_ext_rel Σ Σ0 -> ∥ typing Σ0 Γ t T ∥).

Definition check_inh (Σ : wf_env_ext) Γ
  (wfΓ : forall Σ0 : global_env_ext, abstract_env_ext_rel Σ Σ0 -> ∥ wf_local Σ0 Γ ∥) t {T} : typing_result (inh Σ Γ T) :=
  prf <- check_type_wf_env_fast optimized_abstract_env_impl Σ Γ wfΓ t (T := T) ;;
  ret (t; prf).

Ltac fill_inh t :=
  lazymatch goal with
  [ wfΓ : forall _ _ , ∥ wf_local _ ?Γ ∥ |- inh ?Σ ?Γ ?T ] =>
    let t := uconstr:(check_inh Σ Γ wfΓ t (T:=T)) in
    let proof := eval cbn in t in
    match proof with
    | Checked ?d => exact_no_check d
    | TypeError ?e =>
        let str := eval cbn in (string_of_type_error Σ e) in
        fail "Failed to inhabit " T " : " str
    | _ => fail "Anomaly: unexpected return value: " proof
    end
  | [ |- inh _ ?Γ _ ] => fail "Missing local wellformedness assumption for" Γ
  end.


Require Import Lists.List Lists.ListSet Vector Arith.PeanoNat AbstractRelation Tribool Common Util.

Module Type SQL.
  Import Db.

  (* I will probably need to declare a canonical structure/type class for Names *)

  Inductive pretm : Type :=
  | tmconst : BaseConst -> pretm
  | tmnull  : pretm
  | tmvar   : FullVar -> pretm    (* refers to FROM tables *)
  .

  Lemma pretm_dec : forall (x y: pretm), { x = y } + { x <> y }.
  Proof.
    decide equality. apply Db.BaseConst_dec. decide equality. apply Db.Name_dec. apply Nat.eq_dec.
  Qed.

  Inductive prequery : Type :=
  | select  : bool -> list (pretm * Name) -> list (list (pretb * Scm)) -> precond -> prequery
  | selstar : bool -> list (list (pretb * Scm)) -> precond -> prequery
  | qunion  : bool -> prequery -> prequery -> prequery
  | qinters : bool -> prequery -> prequery -> prequery
  | qexcept : bool -> prequery -> prequery -> prequery

  with precond : Type :=
  | cndtrue   : precond
  | cndfalse  : precond
  | cndnull   : bool -> pretm -> precond
  | cndistrue : precond -> precond
  | cndpred   : forall n, (forall l : list BaseConst, length l = n -> bool) -> list pretm -> precond
  | cndmemb   : bool -> list pretm -> prequery -> precond
  | cndex     : prequery -> precond
  | cndand    : precond -> precond -> precond
  | cndor     : precond -> precond -> precond
  | cndnot    : precond -> precond

  with pretb: Type :=
  | tbbase  : Name -> pretb
  | tbquery : prequery -> pretb.

  Notation "'NULL'" := (tmnull) (at level 45).

  Notation "'SELECT' btm 'FROM' btb 'WHERE' c" := (select false btm btb c) (at level 45).
  Notation "'SELECT' 'DISTINCT' btm 'FROM' btb 'WHERE' c" := (select true btm btb c) (at level 45).
  Notation "'SELECT' '*' 'FROM' btb 'WHERE' c" := (selstar false btb c) (at level 45).
  Notation "'SELECT' 'DISTINCT' '*' 'FROM' btb 'WHERE' c" := (selstar true btb c) (at level 45).
  Notation "Q1 'UNION' Q2" := (qunion false Q1 Q2) (at level 45).
  Notation "Q1 'INTERSECT' Q2" := (qinters false Q1 Q2) (at level 45).
  Notation "Q1 'EXCEPT' Q2" := (qexcept false Q1 Q2) (at level 45).
  Notation "Q1 'UNION' 'ALL' Q2" := (qunion true Q1 Q2) (at level 45).
  Notation "Q1 'INTERSECT' 'ALL' Q2" := (qinters true Q1 Q2) (at level 45).
  Notation "Q1 'EXCEPT' 'ALL' Q2" := (qexcept true Q1 Q2) (at level 45).

  Notation "'FALSE'" := cndfalse (at level 45).
  Notation "'TRUE'" := cndtrue (at level 45).
  Notation "t 'IS' 'NULL'" := (cndnull true t) (at level 45).
  Notation "t 'IS' 'NOT' 'NULL'" := (cndnull false t) (at level 45).
  Notation "tl 'IN' Q" := (cndmemb true tl Q) (at level 45).
  Notation "tl 'NOT' 'IN' Q" := (cndmemb false tl Q) (at level 45).
  Notation "'EXISTS' Q" := (cndex Q) (at level 45).
  Notation "e1 'AND' e2" := (cndand e1 e2) (at level 45).
  Notation "e1 'OR' e2" := (cndor e1 e2) (at level 45).
  Notation "'NOT' e" := (cndnot e) (at level 45).

  Definition mapi {A B: Type} (f : nat -> A -> B) (l : list A) : list B :=
    (fix aux l0 i : list B :=
      match l0 with
      | List.nil => List.nil
      | a::tl => f i a::aux tl (S i)
      end) l 0.

  Definition btm_of_ctx (G: Ctx) : list (pretm * Name) :=
    List.concat (mapi (fun i => List.map (fun x => (tmvar (i,x), x))) G).

  Definition tmlist_of_ctx (G: Ctx) : list pretm :=
    List.concat (mapi (fun i => List.map (fun x => tmvar (i,x))) G).

  Lemma length_tmlist c0 : length (tmlist_of_ctx c0) = length (concat c0).
  Proof.
    unfold tmlist_of_ctx. unfold mapi. generalize 0.
    elim c0; intuition.
    simpl. do 2 rewrite app_length. rewrite cmap_length.
    f_equal. apply H.
  Qed.

  Inductive j_var (a : Name) : Scm -> Prop :=
  | j_varhd   : forall s, ~ List.In a s -> j_var a (a::s)
  | j_varcons : forall b s, a <> b -> j_var a s -> j_var a (b::s).

  Inductive j_tm  (g : Ctx) : pretm -> Prop :=
  | j_const : forall c, j_tm g (tmconst c)
  | j_null  : j_tm g tmnull
  | j_tmvar : forall n a s, List.nth_error g n = Some s -> j_var a s -> j_tm g (tmvar (n,a)).

  (* this was put into place to allow for well-formedness conditions on the DB,
     but we don't have any *)
  Inductive j_db (d : Db.D) : Prop := jd_intro : j_db d.

  Definition j_tml (g : Ctx) (tl : list pretm) : Type := forall t, List.In t tl -> j_tm g t.

  Definition dflist : forall A, list A -> Prop := List.NoDup.

  Inductive j_query (d : Db.D) : Ctx -> prequery -> Scm -> Prop :=
  | j_select :
      forall s c b btm btbl g g1,
      j_btbl d g btbl g1 ->     (* btbl is wellformed under Ctx g, producing a context extension g1 *)
      j_cond d (g1 ++ g) c ->   (* c is defined under Ctx (g1 ++ g) *)
      j_tml (g1 ++ g) (List.map fst btm) -> (* the attr names given don't matter *)
      (* j_tm/j_cond needs all of the references to be unambiguous, i.e. if (g1 ++ g) contains duplicate entries,
          they cannot be used by the terms *)
      s = List.map snd btm ->   (* the schema is given by the second components of btm *)
      j_query d g (select b btm btbl c) s
  | j_selstar :
      forall g btbl g1 c s b,
      j_btbl d g btbl g1 ->       (* btb is wellformed under Ctx g, producing a context extension g1 *)
      j_cond d (g1 ++ g) c ->   (* c is defined under Ctx (g1 ++ g) *)
      s = List.concat g1 ->     (* merges the schemas in g1 *)
      j_tml (g1 ++ g) (tmlist_of_ctx g1) ->
      (* the line above forces the attributes in g1 to be unambiguous *)
      j_query d g (selstar b btbl c) s
  (* union etc. allow different schemas for subqueries, and return the schema of the first query *)
  | j_union   : forall g b q1 q2 s s', length s = length s' -> j_query d g q1 s -> j_query d g q2 s' -> j_query d g (qunion b q1 q2) s
  | j_inters  : forall g b q1 q2 s s', length s = length s' -> j_query d g q1 s -> j_query d g q2 s' -> j_query d g (qinters b q1 q2) s
  | j_except  : forall g b q1 q2 s s', length s = length s' -> j_query d g q1 s -> j_query d g q2 s' -> j_query d g (qexcept b q1 q2) s

  with j_tb (d : Db.D) : Ctx -> pretb -> Scm -> Prop :=
  | j_tbbase  : forall x s g, j_db d -> Db.db_schema d x = Some s -> j_tb d g (tbbase x) s
  | j_tbquery : forall g q s, j_query d g q s -> j_tb d g (tbquery q) s

  with j_cond (d : Db.D) : Ctx -> precond -> Prop :=
  | j_cndtrue   : forall g, j_db d -> j_cond d g cndtrue
  | j_cndfalse  : forall g, j_db d -> j_cond d g cndfalse
  | j_cndnull   : forall g t b, j_db d -> j_tm g t -> j_cond d g (cndnull b t)
  | j_cndistrue : forall g c, j_cond d g c -> j_cond d g (cndistrue c)
  | j_cndpred   : forall g n p tml, j_db d -> j_tml g tml -> length tml = n -> j_cond d g (cndpred n p tml)
  | j_cndmemb   : forall g q sq tl b,
                  j_tml g tl -> j_query d g q sq ->
                  List.length sq = List.length tl -> j_cond d g (cndmemb b tl q)
  | j_cndex     : forall g q, j_inquery d g q -> j_cond d g (cndex q)
  | j_cndand    : forall g c1 c2, j_cond d g c1 -> j_cond d g c2 -> j_cond d g (cndand c1 c2)
  | j_cndor     : forall g c1 c2, j_cond d g c1 -> j_cond d g c2 -> j_cond d g (cndor c1 c2)
  | j_cndnot    : forall g c, j_cond d g c -> j_cond d g (cndnot c)

  (* the output of j_btb can use any choice of names, avoiding collision *)
  with j_btb  (d : Db.D) : Ctx -> list (pretb * Scm) -> Ctx -> Prop :=
  | j_btbnil  : forall g, j_db d -> j_btb d g List.nil List.nil
  | j_btbcons : forall g T s s' btb g1, length s = length s' -> List.NoDup s' ->
                j_tb d g T s -> j_btb d g btb g1 -> j_btb d g ((T,s')::btb) (s'::g1)

  with j_btbl (d : Db.D) : Ctx -> list (list (pretb * Scm)) -> Ctx -> Prop :=
  | j_btblnil : forall g, j_db d -> j_btbl d g List.nil List.nil
  | j_btblcons : forall g B Bl g1 g2, j_btbl d g Bl g1 -> j_btb d (g1++g) B g2 -> j_btbl d g (B::Bl) (g2++g1)

  with j_inquery (d : Db.D) : Ctx -> prequery -> Prop :=
  | j_inselect :
      forall c b btm btbl g g1,
      j_btbl d g btbl g1 ->       (* btb is wellformed under Ctx g, producing a context extension g1 *)
      j_cond d (g1 ++ g) c ->  (* c is defined under Ctx (g (+) g1) *)
      j_tml (g1 ++ g) (List.map fst btm) -> (* btm is wellformed under Ctx (g (+) g1) *)
      j_inquery d g (select b btm btbl c)
  | j_inselstar :
      forall g btbl g1 c b,
      j_btbl d g btbl g1 ->       (* btb is wellformed under Ctx g, producing a context extension g1 *)
      j_cond d (g1 ++ g) c ->  (* c is defined under Ctx (g (+) g1) *)
      (* the different behaviour, compared with j_query, is achieved by omitting the j_tml premise *)
      j_inquery d g (selstar b btbl c)
  (* union etc. allow different schemas for subqueries, and return the schema of the first query *)
  | j_inunion   : forall g b q1 q2 s s', length s = length s' -> j_query d g q1 s -> j_query d g q2 s' -> j_inquery d g (qunion b q1 q2)
  | j_ininters  : forall g b q1 q2 s s', length s = length s' -> j_query d g q1 s -> j_query d g q2 s' -> j_inquery d g (qinters b q1 q2)
  | j_inexcept  : forall g b q1 q2 s s', length s = length s' -> j_query d g q1 s -> j_query d g q2 s' -> j_inquery d g (qexcept b q1 q2)
  .

  Scheme jq_ind_mut := Induction for j_query Sort Prop
  with jT_ind_mut := Induction for j_tb Sort Prop
  with jc_ind_mut := Induction for j_cond Sort Prop
  with jbT_ind_mut := Induction for j_btb Sort Prop
  with jbTl_ind_mut := Induction for j_btbl Sort Prop
  with jiq_ind_mut := Induction for j_inquery Sort Prop.

  Combined Scheme j_ind_mut from jq_ind_mut, jT_ind_mut, jc_ind_mut, jbT_ind_mut, jiq_ind_mut.

  Definition tm := fun G => { t : pretm & j_tm G t }.
  Definition query := fun d G s => { Q : prequery & j_query d G Q s }.
  Definition tb := fun d G s => { T : pretb & j_tb d G T s }.
  Definition cond := fun d G => { c : precond & j_cond d G c }.
  Definition inquery := fun d G => { Q : prequery & j_inquery d G Q }.

  (* a recursive definition of schemas *)

  (* XXX: not entirely sure of the rationale for propagating or erasing the boolean b *)
  Fixpoint q_schema (d : Db.D) (q : prequery) (b : bool) {struct q} : list Name :=
    match q with
    | select _ btm _ _  => List.map snd btm (* XXX: no duplicate-freedom check *)
    | selstar _ btb _   =>
        if b then List.nil
        else List.concat (List.concat ((List.map (List.map snd) btb)))
     (* bind (monadic_map (tb_schema d) btb) (fun G0 => ret (List.concat G0)) *)
    | qunion _ q1 _ => q_schema d q1 false
    | qinters _ q1 q2   => q_schema d q1 false
    | qexcept _ q1 q2   => q_schema d q1 false
    end.

  Definition tb_schema (d : Db.D) (T : pretb) : option (list Name) :=
    match T with
    | tbbase x  => Db.db_schema d x
    | tbquery q0 => ret (q_schema d q0 false)
    end.

(*
  Fixpoint pred_safe (d : Db.D) (c : precond) {struct c} : bool :=
    match c with
    | cndmemb _ tl q0 => List.length (q_schema d q0 false) =? List.length tl
    | cndex q0 => match q_schema d q0 true with None => false | _ => true end
    | cndand c1 c2 => pred_safe d c1 && pred_safe d c2
    | cndor c1 c2 => pred_safe d c1 && pred_safe d c2
    | cndnot c0 => pred_safe d c0
    | cndpred n p tml => length tml =? n
    | _ => true
    end.
*)

  Definition btb_schema (d : Db.D) : list (pretb * Scm) -> Ctx :=
    (* bind (monadic_map (tb_schema d) btb) ret *)
    List.map snd.

  Definition btbl_schema (d : Db.D) (btbl : list (list (pretb * Scm))) : Ctx :=
    List.concat (List.map (btb_schema d) btbl).

(* TODO we stop here because we still have to do btbl_schema *)

  Theorem jq_q_schema : forall d G Q s,
    forall j : j_query d G Q s, q_schema d Q false = s.
  intros d G Q s HWF.
  eapply (jq_ind_mut _
          (fun G0 Q0 s0 H0 => q_schema d Q0 false = s0)
          (fun G0 T0 s0 H0 => (* tb_schema d T0 = Some s0 *) True)
          (fun G0 c0 H0 => (* pred_safe d c0 = true *) True)
          (fun G0 btb G1 H0 => btb_schema d btb = G1)
          (fun G0 btbl G1 H0 => btbl_schema d btbl = G1)
          (fun G0 Q0 H0 => exists s0, q_schema d Q0 true = s0)
          _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ HWF).
  Unshelve.
  + intros s0 c b btm btb G0 G1 Hbtb IHbtb Hc IHc Html. simpl. intro. rewrite e. reflexivity.
  + intros G0 btbl G1 c s0 b Hbtbl IHbtbl Hc IHc e Html. simpl.
    simpl in IHbtbl. unfold btbl_schema, btb_schema in IHbtbl.
    rewrite e. rewrite <- IHbtbl. reflexivity.
  + intros G0 b Q1 Q2 s0 s1 Hlen HQ1 IHQ1 HQ2 IHQ2; simpl; simpl in IHQ1; exact IHQ1.
  + intros G0 b Q1 Q2 s0 s1 Hlen HQ1 IHQ1 HQ2 IHQ2; simpl; simpl in IHQ1; exact IHQ1.
  + intros G0 b Q1 Q2 s0 s1 Hlen HQ1 IHQ1 HQ2 IHQ2; simpl; simpl in IHQ1; exact IHQ1.
  + intros x s0 G0 Hdb e. simpl. constructor.
  + intros x s0 G0 Hdb e. simpl. constructor.
  + intros G0 Hdb. reflexivity.
  + intros G0 Hdb. reflexivity.
  + intros G0 t b Hdb Ht. reflexivity.
  + intros; constructor.
  + intros; constructor.
  + intros; constructor.
  + intros; constructor.
  + intros; constructor.
  + intros; constructor.
  + intros; constructor.
  + intros; constructor.
  + intros G0 T s0 s' btb G1 Hlen Hnodup HT IHT Hbtb IHbtb. simpl. unfold btb_schema.
    simpl in IHbtb. unfold btb_schema, ret in IHbtb.
    rewrite IHbtb. reflexivity.
  + intros; reflexivity.
  + intros G1 btb btbl G2 G3 Hbtbl IHbtbl Hbtb IHbtb. simpl.
    simpl in IHbtbl, IHbtb. rewrite <- IHbtbl, <- IHbtb. reflexivity.
  + intros c b btm btb G0 G1 Hbtb IHbtb Hc IHc Html. simpl. eexists. all:auto.
  + intros G0 btb G1 c b Hbtb IHbtb Hc IHc. simpl. eexists. all:eauto.
  + intros G0 b Q1 Q2 s0 s1 Hlen HQ1 IHQ1 HQ2 IHQ2; simpl. rewrite IHQ1. exists s0; auto.
  + intros G0 b Q1 Q2 s0 s1 Hlen HQ1 IHQ1 HQ2 IHQ2; simpl. rewrite IHQ1. exists s0; auto.
  + intros G0 b Q1 Q2 s0 s1 Hlen HQ1 IHQ1 HQ2 IHQ2; simpl. rewrite IHQ1. exists s0; auto.
  Qed.

  Definition tm_lift (t : pretm) k :=
    match t with
    | tmvar x => let (n,a) := x in tmvar (k+n,a)
    | _ => t
    end.

  Lemma j_tm_weak G G' t : j_tm G t -> j_tm (G' ++ G) (tm_lift t (length G')).
  Proof.
    intro H. elim H; try (intros; constructor).
    simpl. intros n a s HG Has. eapply (j_tmvar _ _ _ s); auto.
    elim G'; auto.
  Qed.

End SQL.


From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path.
From Coq Require Import Eqdep Relation_Operators.
From pcm Require Import pred prelude ordtype finmap pcm unionmap heap.
From DiSeL Require Import Freshness State EqTypeX DepMaps.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section NewSoupPredicates.

(*****************************************************)
(*        More elaborated message predicates         *)
(*****************************************************)

Definition msg_in_soup' from to t (cond : seq nat -> bool) (d : soup) :=
  (exists! i, exists c,
        find i d = Some (Msg (TMsg t c) from to true)) /\
  forall i c, find i d = Some (Msg (TMsg t c) from to true) -> cond c.

Definition msg_spec' from to tg cnt :=
  msg_in_soup' from to tg (fun y => (y == cnt)).

Definition no_msg_from_to' from to
           (criterion : nat -> seq nat -> bool) (d : soup) :=
  forall i t c,
    find i d = Some (Msg (TMsg t c) from to true) -> ~~criterion t c.

Lemma no_msg_from_to_consume' from to cond s i:
  valid s ->
  no_msg_from_to' from to cond s ->
  no_msg_from_to' from to cond (consume_msg s i).
Proof.
move=>V H m t c .
rewrite /consume_msg; case: (find i s); last by move=>F; apply: (H m t c F).
move=>ms; case B: (m == i).
- by move/eqP: B=>B; subst m; rewrite findU eqxx/= V.
by rewrite findU B/==>/(H m t c).
Qed.

Lemma no_msg_spec_consume s from to tg cnt cond i :
  valid s ->
  find i s = Some {| content := TMsg tg cnt;
                     from := from; to := to; active := true |} ->
  msg_in_soup' from to tg cond s ->
  no_msg_from_to' from to (fun x y => (x == tg)) (consume_msg s i).
Proof.
move=>V F[][j][[c]]F' H1 H2.
move=>m t' c'; rewrite /consume_msg; move: (find_some F).
case: dom_find=>// msg->_ _; case B: (m == i).
- by move/eqP: B=>B; subst m; rewrite findU eqxx/= V.
have X: j = i by apply: (H1 i); exists cnt.
subst j; rewrite findU B/==>H.
case X: (t' == tg)=>//=.
move/eqP: X=>X; subst t'.
suff X: i = m by subst i; rewrite eqxx in B.
by apply: (H1 m); exists c'.
Qed.

Lemma msg_spec_consumeE i d from to from' to' t c' t' cond:
  valid d ->
  find  i d = Some (Msg (TMsg t' c') from' to' true) ->
  msg_in_soup' from to t cond d ->
  [|| (from != from'), (to != to') | (t != t')] ->
  msg_in_soup' from to t cond (consume_msg d i).
Proof.
move=>V E S N.
case: S=>[][j][[c]F]H1 H2.
have Nij: i != j.
- case H: (i == j)=>//.
  move/eqP in H; subst i; move: E; rewrite F=>[][???]; subst.
  move: N=>/orP []/eqP; first by congruence.
  move/eqP/orP; case; first by move=>X Z; subst to'; rewrite eqxx in X.
  by rewrite eqxx.
split.
- exists j; split; first by exists c; rewrite mark_other// eq_sym; apply/negbTE.
  move=> x [c1] E'.
  case H: (x == i).
  + by move/eqP in H; subst x; rewrite (find_consume _ E) in E'.
  by apply: H1; exists c1; rewrite mark_other in E'.
move=>k c1.
case H: (k == i); first by move/eqP in H; subst k; rewrite (find_consume _ E).
by rewrite mark_other//; apply: H2.
Qed.

End NewSoupPredicates.


(*! Circuits | Lemmas used in the compiler-correctness proof !*)
Require Export Koika.CircuitGeneration Koika.CircuitOptimization.
Require Import Koika.Common Koika.Environments Koika.Types Koika.Lowering.

Section Bools.
  Definition bool_le b1 b2 :=
    b2 = false ->
    b1 = false.

  Lemma bool_le_impl b1 b2 :
    bool_le b1 b2 <-> (orb (negb b1) b2) = true.
  Proof.
    destruct b1, b2; unfold bool_le; cbn; intuition.
  Qed.

  Lemma bool_le_and :
    forall b1 b1' b2 b2',
      bool_le b1 b1' ->
      bool_le b2 b2' ->
      bool_le (andb b1 b2) (andb b1' b2').
  Proof.
    unfold bool_le; intros.
    destruct b1, b2, b1', b2'; cbn;
      intuition discriminate.
  Qed.

  Lemma bool_le_and_l :
    forall b1 b1' b2,
      bool_le b1 b1' ->
      bool_le (andb b1 b2) b1'.
  Proof.
    unfold bool_le; intros.
    destruct b1, b2, b1'; cbn;
      intuition discriminate.
  Qed.

  Lemma bool_le_or :
    forall b1 b1' b2 b2',
      bool_le b1 b1' ->
      bool_le b2 b2' ->
      bool_le (orb b1 b2) (orb b1' b2').
  Proof.
    unfold bool_le; intros.
    destruct b1, b2, b1', b2'; cbn;
      intuition discriminate.
  Qed.

  Lemma bool_le_mux :
    forall (s: bool) b1 b1' b2 b2',
      bool_le b1 b1' ->
      bool_le b2 b2' ->
      bool_le (if s then b1 else b2) (if s then b1' else b2').
  Proof.
    unfold bool_le; intros.
    destruct s; cbn;
      intuition discriminate.
  Qed.

  Lemma bool_le_not :
    forall b1 b2,
      bool_le b1 b2 ->
      bool_le (negb b2) (negb b1).
  Proof.
    unfold bool_le; intros.
    destruct b1, b2; cbn;
      intuition discriminate.
  Qed.

  Lemma bool_le_true :
    forall b, bool_le b true.
  Proof.
    unfold bool_le; intros;
      destruct b; intuition discriminate.
  Qed.

  Lemma bool_le_false :
    forall b, bool_le false b.
  Proof.
    unfold bool_le; intros;
      destruct b; intuition discriminate.
  Qed.
End Bools.

Section Circuits.
  Context {pos_t var_t rule_name_t reg_t ext_fn_t: Type}.

  Context {CR: reg_t -> nat}.
  Context {CSigma: ext_fn_t -> CExternalSignature}.

  Context {REnv: Env reg_t}.
  Context (cr: REnv.(env_t) (fun idx => bits (CR idx))).

  Context {Show_rule_name_t : Show rule_name_t}.

  Context (csigma: forall f, CSig_denote (CSigma f)).
  Context (lco: (@local_circuit_optimizer
                   rule_name_t reg_t ext_fn_t CR CSigma
                   (rwdata (rule_name_t := rule_name_t) CR CSigma)
                   csigma)).

  Notation circuit := (circuit (rule_name_t := rule_name_t)
                              (rwdata := rwdata (rule_name_t := rule_name_t) CR CSigma)
                              CR CSigma).
  Notation interp_circuit := (interp_circuit cr csigma).

  Definition circuit_le (c1 c2: circuit 1) :=
    bool_le (Bits.single (interp_circuit c1)) (Bits.single (interp_circuit c2)).

  Lemma interp_circuit_circuit_le_helper_false :
    forall c1 c2,
      circuit_le c1 c2 ->
      interp_circuit c2 = Ob~0 ->
      interp_circuit c1 = Ob~0.
  Proof.
    unfold circuit_le; intros * Hlt Heq;
      destruct (interp_circuit c1) as (? & [ ]), (interp_circuit c2) as (? & []).
    inversion Heq; cbv; f_equal; apply Hlt; cbn; congruence.
  Qed.

  Lemma interp_circuit_circuit_le_helper_true :
    forall c1 c2,
      circuit_le c1 c2 ->
      interp_circuit c1 = Ob~1 ->
      interp_circuit c2 = Ob~1.
  Proof.
    unfold circuit_le; intros * Hlt Heq;
      destruct (interp_circuit c1) as (? & [ ]), (interp_circuit c2) as ([ | ] & []);
      inversion Heq; subst; cbv; f_equal; symmetry; apply Hlt; cbn; congruence.
  Qed.

  Lemma circuit_le_CAnnot :
    forall s c1 c2,
      circuit_le c1 c2 ->
      circuit_le (CAnnot s c1) (CAnnot s c2).
  Proof. firstorder. Qed.

  Lemma circuit_le_CAnnot_l :
    forall s c1 c2,
      circuit_le c1 c2 ->
      circuit_le (CAnnot s c1) c2.
  Proof. firstorder. Qed.

  Lemma circuit_le_CAnnot_r :
    forall s c1 c2,
      circuit_le c1 c2 ->
      circuit_le c1 (CAnnot s c2).
  Proof. firstorder. Qed.

  Lemma circuit_le_CBundleRef :
    forall rl1 rl2 rs1 rs2 b1 b2 field1 field2 c1 c2,
      circuit_le c1 c2 ->
      circuit_le (CBundleRef rl1 rs1 b1 field1 c1) (CBundleRef rl2 rs2 b2 field2 c2).
  Proof. firstorder. Qed.

  Lemma circuit_le_CBundleRef_l :
    forall rl1 rs1 b1 field1 c1 c2,
      circuit_le c1 c2 ->
      circuit_le (CBundleRef rl1 rs1 b1 field1 c1) c2.
  Proof. firstorder. Qed.

  Lemma circuit_le_CBundleRef_r :
    forall rl2 rs2 b2 field2 c1 c2,
      circuit_le c1 c2 ->
      circuit_le c1 (CBundleRef rl2 rs2 b2 field2 c2).
  Proof. firstorder. Qed.

  Lemma circuit_le_CAnd :
    forall c1 c1' c2 c2',
      circuit_le c1 c1' ->
      circuit_le c2 c2' ->
      circuit_le (CAnd c1 c2) (CAnd c1' c2').
  Proof. unfold circuit_le; cbn; eauto using bool_le_and. Qed.

  Lemma circuit_le_CAnd_l :
    forall c1 c1' c2,
      circuit_le c1 c1' ->
      circuit_le (CAnd c1 c2) c1'.
  Proof. unfold circuit_le; cbn; eauto using bool_le_and_l. Qed.

  Lemma circuit_le_CAnd_r :
    forall c1 c1' c2',
      circuit_le c1 c1' ->
      interp_circuit c2' = Ob~1 ->
      circuit_le c1 (CAnd c1' c2').
  Proof. unfold circuit_le; cbn. intros * ? ->.
     cbn; rewrite Bool.andb_true_r; eauto. Qed.

  Lemma circuit_le_COr :
    forall c1 c1' c2 c2',
      circuit_le c1 c1' ->
      circuit_le c2 c2' ->
      circuit_le (COr c1 c2) (COr c1' c2').
  Proof. unfold circuit_le; cbn; eauto using bool_le_or. Qed.

  Lemma circuit_le_CMux :
    forall s c1 c1' c2 c2',
      circuit_le c1 c1' ->
      circuit_le c2 c2' ->
      circuit_le (CMux s c1 c2) (CMux s c1' c2').
  Proof.
    unfold circuit_le; cbn;
      intros; destruct (Bits.single (interp_circuit s)); eauto.
  Qed.

  Lemma circuit_le_CMux_l :
    forall s c1 c2 c3,
      (interp_circuit s = Ob~1 -> circuit_le c1 c3) ->
      (interp_circuit s = Ob~0 -> circuit_le c2 c3) ->
      circuit_le (CMux s c1 c2) c3.
  Proof.
    unfold circuit_le; cbn;
      intros * Heq1 Heq2; destruct (interp_circuit s) as [ b [] ]; cbn.
    destruct b; eauto.
  Qed.

  Lemma circuit_le_CMux_r :
    forall s c1 c2 c3,
      (interp_circuit s = Ob~1 -> circuit_le c1 c2) ->
      (interp_circuit s = Ob~0 -> circuit_le c1 c3) ->
      circuit_le c1 (CMux s c2 c3).
  Proof.
    unfold circuit_le; cbn;
      intros * Heq1 Heq2; destruct (interp_circuit s) as [ b [] ]; cbn.
    destruct b; eauto.
  Qed.

  Lemma circuit_le_CNot :
    forall c1 c2,
      circuit_le c1 c2 ->
      circuit_le (CNot c2) (CNot c1).
  Proof. unfold circuit_le; cbn; eauto using bool_le_not. Qed.

  Lemma circuit_le_true :
    forall c, circuit_le c (CConst Ob~1).
  Proof. unfold circuit_le; cbn; eauto using bool_le_true. Qed.

  Lemma circuit_le_false :
    forall c, circuit_le (CConst Ob~0) c.
  Proof. unfold circuit_le; cbn; eauto using bool_le_false. Qed.

  Lemma circuit_le_fold_right {X} :
    forall (xs: list X) f0 f1 c0 c1,
      circuit_le c1 c0 ->
      (forall x acc1 acc0, circuit_le acc1 acc0 -> circuit_le (f1 x acc1) (f0 x acc0)) ->
      circuit_le (List.fold_right f1 c1 xs) (List.fold_right f0 c0 xs).
  Proof.
    induction xs; cbn; intros * Hlt Hxlt; eauto.
  Qed.

  Lemma circuit_le_refl :
    forall c, circuit_le c c.
  Proof. firstorder. Qed.

  Lemma circuit_le_trans :
    forall c1 c2 c3,
      circuit_le c1 c2 ->
      circuit_le c2 c3 ->
      circuit_le c1 c3.
  Proof. firstorder. Qed.

  Lemma circuit_le_opt_l :
    forall c1 c2,
      circuit_le c1 c2 ->
      circuit_le (lco.(lco_fn) c1) c2.
  Proof.
    unfold circuit_le; intros; rewrite lco.(lco_proof); assumption.
  Qed.

  Lemma circuit_le_opt_r :
    forall c1 c2,
      circuit_le c1 c2 ->
      circuit_le c1 (lco.(lco_fn) c2).
  Proof.
    unfold circuit_le; intros; rewrite lco.(lco_proof); assumption.
  Qed.

  Lemma circuit_le_willFire_of_canFire_canFire :
    forall rl_name c1 (cLog: scheduler_circuit (rule_name_t := rule_name_t) CR CSigma REnv) rws,
      circuit_le (willFire_of_canFire lco rl_name {| canFire := c1; regs := rws |} cLog) c1.
  Proof.
    unfold willFire_of_canFire; intros.
    eapply circuit_le_trans.
    - eapply circuit_le_fold_right.
      + apply circuit_le_refl.
      + intros; rewrite !getenv_zip.
        eapply circuit_le_opt_l, circuit_le_CAnd.
        * eassumption.
        * apply circuit_le_true.
    - cbn.
      induction finite_elements; cbn.
      + apply circuit_le_CAnnot_l, circuit_le_refl.
      + apply circuit_le_CAnd_l; eassumption.
  Qed.
End Circuits.

Ltac circuit_le_f_equal :=
  repeat (apply circuit_le_CAnnot_l ||
          apply circuit_le_CAnnot_r ||
          apply circuit_le_opt_l ||
          apply circuit_le_opt_r ||
          apply circuit_le_CBundleRef_l ||
          apply circuit_le_CBundleRef_r ||
          apply circuit_le_CAnd ||
          apply circuit_le_COr ||
          apply circuit_le_CNot ||
          apply circuit_le_true ||
          apply circuit_le_false ||
          apply circuit_le_refl).


From ExtLib Require Export
     Extras
     RelDec.
From Ceres Require Export
     Ceres.
From ITree Require Export
     Exception
     Nondeterminism
     ITree.
From Coq Require Export
     String.
Export
  FunNotation
  Monads
  SumNotations
  ITreeNotations.
Open Scope itree_scope.
Open Scope string_scope.
Open Scope sum_scope.

Section Server.

Variables Q A S : Type.

Hypothesis RelDec__A   : RelDec (@eq A).
Hypothesis Serialize__A: Serialize A.
Hypothesis Serialize__Q: Serialize Q.

Variant serverE : Type -> Type :=
  Server__Recv : S -> serverE Q
| Server__Exec : Q -> A -> serverE unit.

Definition serverOf {E} `{serverE -< E} (step: Q -> state S A) : S -> itree E void :=
  rec (fun s =>
         q <- embed Server__Recv s;;
         let (s', a) := step q s in
         embed Server__Exec q a;;
         call s').

Class Is__sE E `{serverE -< E} `{nondetE -< E}.

Definition serverOfT {E} `{serverE -< E} `{nondetE -< E}
           (stept: forall {F} `{nondetE -< F}, Q -> stateT S (itree F) A)
  : S -> itree E void :=
  rec (fun s =>
         q <- embed Server__Recv s;;
         '(s', a) <- stept q s;;
         embed Server__Exec q a;;
         call s').

Variant observeE : Type -> Type :=
  Observe__FromServer : Q -> observeE A
| Observe__FromClient : S -> observeE Q.

Class Is__oE E `{observeE -< E} `{nondetE -< E} `{exceptE string -< E}.

Definition observe {E} `{Is__oE E} (m: itree (serverE +' nondetE) void) : itree E void :=
  interp
    (fun _ e =>
       match e with
       | (se|) =>
           match se in serverE Y return _ Y with
           | Server__Recv s => embed Observe__FromClient s
           | Server__Exec q a =>
               a' <- embed Observe__FromServer q;;
               if a' ?[ eq ] a
               then Ret tt
               else throw $ "Upon " ++ to_string q ++
                          ", expect " ++ to_string a ++
                          ", but observed " ++ to_string a'
           end
       | (|ne) =>
           match ne in nondetE Y return _ Y with
           | Or => trigger Or
           end
       end) m.

End Server.

Arguments serverOf {_ _ _ _ _}.
Arguments observe  {_ _ _ _ _ _ _ _ _ _ _}.
Arguments serverOfT {_ _ _ _ _ _}.

Notation failureE := (exceptE string).
Notation sE Q A S := (serverE Q A S +' nondetE).
Notation oE Q A S := (observeE Q A S +' nondetE +' failureE).
#[global]
Instance oE_Is__oE Q A S : Is__oE Q A S (oE Q A S). Defined.
#[global]
Instance sE_Is__sE Q A S : Is__sE Q A S (sE Q A S). Defined.