(** Datatypes used in the binary parser. **)
(* (C) J. Pichon - see LICENSE.txt *)

Require Import common.
Require Export numerics datatypes.
From mathcomp Require Import ssreflect ssrfun ssrnat ssrbool eqtype seq.
Require Import Ascii.

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

Definition expr := list basic_instruction.

Inductive labelidx : Type :=
| Mk_labelidx : nat -> labelidx.

Inductive funcidx : Type :=
| Mk_funcidx : nat -> funcidx.
Inductive typeidx : Type :=
| Mk_typeidx : nat -> typeidx.

Inductive localidx : Type :=
| Mk_localidx : nat -> localidx.

Inductive globalidx : Type :=
| Mk_globalidx : nat -> globalidx.

Record limits := Mk_limits { lim_min : nat; lim_max : option nat; }.

Inductive elem_type : Type :=
| elem_type_tt : elem_type (* TODO: am I interpreting the spec correctly? *).

Record table_type : Type := Mk_table_type {
  tt_limits : limits;
  tt_elem_type : elem_type;
}.

Record mem_type : Type := Mk_mem_type { mem_type_lims : limits }.

Inductive import_desc : Type :=
| ID_func : nat -> import_desc
| ID_table : table_type -> import_desc
| ID_mem : mem_type -> import_desc
| ID_global : global_type -> import_desc.

Definition name := list ascii.

Record import : Type := Mk_import {
  imp_module : name;
  imp_name : name;
  imp_desc : import_desc;
}.

Record table := Mk_table { t_type : table_type }.

Definition mem := limits.

Record global2 : Type := {
  g_type : global_type;
  g_init : expr;
}.

Record start := { start_func : nat; }.

Record element : Type := {
  elem_table : nat;
  elem_offset : expr;
  elem_init : list nat;
}.

Record func : Type := {
  fc_locals : list value_type;
  fc_expr : expr;
}.

Record data : Type := {
  dt_data : nat;
  dt_offset : expr;
  dt_init : list ascii;
}.

Inductive export_desc : Type :=
| ED_func : nat -> export_desc
| ED_table : nat -> export_desc
| ED_mem : nat -> export_desc
| ED_global : nat -> export_desc.

Record export : Type := {
  exp_name : name;
  exp_desc : export_desc;
}.

Inductive section : Type :=
| Sec_custom : list ascii -> section
| Sec_type : list function_type -> section
| Sec_import : list import -> section
| Sec_function : list typeidx -> section
| Sec_table : list table -> section
| Sec_memory : list mem -> section
| Sec_global : list global2 -> section
| Sec_export : list export -> section
| Sec_start : start -> section
| Sec_element : list element -> section
| Sec_code : list func -> section
| Sec_data : list data -> section.

Record func2 : Type := {
  fc2_type : typeidx;
  fc2_locals : list value_type;
  fc2_body : expr;
}.

Record module : Type := {
  mod_types : list function_type;
  mod_funcs : list func2;
  mod_tables : list table;
  mod_mems : list mem;
  mod_globals : list global2;
  mod_elements : list element;
  mod_data : list data;
  mod_start : option start;
  mod_imports : list import;
  mod_exports : list export;
}.


(*
 * Module: SVAOS
 *
 * Description:
 *  Prove that a simple CFI policy is maintained for the semantics of our
 *  language.
 *)

(* Load Coq Standard Library modules *)
Require Import Arith.
Require Import List.
Require Import Coq.Logic.Classical_Prop.

(* Load SVAOS specific modules *)
Require Import Semantics.
Require Import ICProofs.

(*
 * Theorem: threadIsValid
 *
 * Description:
 *   This theorem proves that if a thread list is valid, then any thread
 *   fetched from the list is valid.
 *)
Theorem threadIsValid: forall (cfg : list nat) (mmu : MMU) (ds : store) (tl : ThreadList) (n : nat),
validThreadList tl cfg mmu ds -> validThread (getThread n tl) cfg mmu ds.
Proof.
intros cfg mmu ds tl.
induction tl.

(* Case 1 *)
intros.
unfold getThread.
destruct n.

(* Case 1a *)
auto.

(* Case 1b *)
auto.

(* Case 2 *)
auto.

(* Case 3 *)
intros.
inversion H.
destruct n.

(* Case 3a *)
unfold getThread.
simpl.
auto.

(* Case 3b *)
fold validThreadList in H1.
assert (validThreadList (a :: tl) cfg mmu ds).
unfold validThreadList.
split.
auto.
fold validThreadList.
auto.
apply IHtl.
auto.
Qed.

(*
 * Theorem: cfisafe
 *
 * Description:
 *  Prove that the program counter always moves to the next instruction
 *  or is changed to a value that is within the list of acceptable
 *  targets.
 *)
Theorem cfisafe : forall c1 c2 : config,
  c1 ==> c2 /\
  (validThreadList (getThreadList c1) (getCFG c1) (getCMMU c1) (getStore c1)) /\
  (In (getTH c1) (getCFG c1))
  ->
  (getPC c2) = (getPC c1 + 1) \/
  (In (getPC c2) (getCFG c1)) \/
  ((vlookup (minus (getPC c2) 1) c2) = svaSwap) \/
  ((getPC c2) = (getICPC (itop (getThreadICList (getCurrThread c1) (getThreadList c1))))).
Proof.
intros c1 c2.
intro H.
destruct H.
destruct H.
destruct c.

(* First induction case *)
left.
simpl.
rewrite -> plus_comm.
simpl.
reflexivity.

(* Second induction case *)
left.
simpl.
rewrite -> plus_comm.
simpl.
reflexivity.

(* Third induction case *)
left.
simpl.
rewrite -> plus_comm.
simpl.
reflexivity.

(* Fourth induction case *)
left.
simpl.
rewrite -> plus_comm.
simpl.
reflexivity.

(* Subtraction case *)
left.
simpl.
rewrite -> plus_comm.
simpl.
reflexivity.

(* Fifth induction case *)
right.
left.
simpl.
destruct H as [H1 H2].
apply H2.

(* Sixth induction case *)
left.
simpl.
rewrite -> plus_comm.
simpl.
reflexivity.

(* Seventh induction case *)
left.
simpl.
rewrite -> plus_comm.
simpl.
reflexivity.

(* Eighth induction case *)
right.
left.
simpl.
destruct H as [H1 H2].
apply H2.

(* Addition to case 8: jeq fallthrough *)
simpl.
left.
rewrite -> plus_comm.
auto.

(* Ninth induction case *)
right.
left.
simpl.
destruct H as [H1 H2].
apply H2.

(* Addition to case 9: jne fallthrough *)
simpl.
left.
rewrite -> plus_comm.
auto.

(* Tenth induction case *)
left.
simpl.
rewrite -> plus_comm.
simpl.
auto.

(* Case 11 *)
left.
simpl.
rewrite -> plus_comm.
simpl.
auto.

(* Case 12 *)
simpl.
simpl in H0.
right.
unfold vlookup.
unfold vLookup.
simpl.
destruct H0 as [H0 TH].
assert (validThread (getThread vr tl) CFG MMU DS).
apply threadIsValid.
auto.

destruct H.
destruct H2.
destruct getThread.
unfold validThread in H1.
unfold canThreadSwap in H3.
destruct H3 as [H3 H4].
rewrite -> H3 in H1.
simpl.
unfold vLookup in H1.
destruct H1.
left.
auto.
right.
auto.

(* Case 13 *)
simpl.
right.
left.
simpl in H0.
apply H0.

(* Case 14 *)
simpl.
right.
right.
simpl in H0.
right.
destruct H as [H1 H2].
destruct H2 as [H2 H3].
destruct H3 as [H3 H4].
auto.

(* Case 15 *)
simpl.
left.
rewrite -> plus_comm.
auto.

(* Case 16 *)
simpl.
left.
rewrite -> plus_comm.
auto.

(* Case 17 *)
simpl.
left.
rewrite -> plus_comm.
auto.

(* Case 18 *)
simpl.
left.
rewrite -> plus_comm.
auto.
Qed.

(*
 * Theorem: cfisafe2
 *
 * Description:
 *  Prove that the program counter always moves to the next instruction
 *  or is changed to a value that is within the list of acceptable
 *  targets.
 *)
Theorem cfisafe2 : forall c1 c2 : config,
  c1 ==> c2 /\
  (validThreadList (getThreadList c1) (getCFG c1) (getCMMU c1) (getStore c1)) /\
  (In (getTH c1) (getCFG c1)) /\
  (pcInText c1) /\
  (validThreadIDs c1) /\
  (validCFG c1 (getCFG c1)) /\
  (In (getThread (getCurrThread c1) (getThreadList c1)) (getThreadList c1)) /\
  (textMappedLinear c1) /\
  (AreAllThreadICsInText (getThreadList c1) (c1)) /\
  (AreAllThreadSICsInText (getThreadList c1) (c1)) /\
  (validConfig c1) /\
  (textNotWriteable c1) /\
  (textMappedOnce c1) /\
  (threadListInText (getThreadList c1) (getCFG c1) (getCMMU c1)
  (getTextStart c1) (getTextEnd c1)) /\
  (goodPCInConfigIC c1) /\
  (goodPCInConfigSIC c1)
  ->
  (getPC c2) = (getPC c1 + 1) \/
  (In (getPC c2) (getCFG c1)) \/
  ((vlookup (minus (getPC c2) 1) c2) = svaSwap) \/
  ((vlookup (minus (getPC c2) 1) c2) = trap) \/
  ((getPC c2) = 0).
Proof.
intros c1 c2.
intro H.
destruct H as [H I].
destruct I as [I1 I].
destruct I as [I2 I].
destruct I as [I3 I].
destruct I as [I4 I].
destruct I as [I5 I].
destruct I as [I6 I].
destruct I as [I7 I].
destruct I as [I8 I].
destruct I as [I9 I].
destruct I as [I10 I].
destruct I as [I11 I].
destruct I as [I12 I].
destruct I as [I13 I].
destruct I as [I14 I].

assert (goodPCInConfigIC c2).
apply pcInIC with (c1 := c1).
repeat (split ; auto).
apply areAllIffAll.
auto.
auto.
apply getNWTLPC.
repeat (split ; auto).

destruct H.
destruct c.

(* First induction case *)
left.
simpl.
rewrite -> plus_comm.
simpl.
reflexivity.

(* Second induction case *)
left.
simpl.
rewrite -> plus_comm.
simpl.
reflexivity.

(* Third induction case *)
left.
simpl.
rewrite -> plus_comm.
simpl.
reflexivity.

(* Fourth induction case *)
left.
simpl.
rewrite -> plus_comm.
simpl.
reflexivity.

(* Subtraction case *)
left.
simpl.
rewrite -> plus_comm.
simpl.
reflexivity.

(* Fifth induction case *)
right.
left.
simpl.
destruct H as [HA HB].
apply HB.

(* Sixth induction case *)
left.
simpl.
rewrite -> plus_comm.
simpl.
reflexivity.

(* Seventh induction case *)
left.
simpl.
rewrite -> plus_comm.
simpl.
reflexivity.

(* Eighth induction case *)
right.
left.
simpl.
apply H.

(* Addition to case 8: jeq fallthrough *)
simpl.
left.
rewrite -> plus_comm.
auto.

(* Ninth induction case *)
right.
left.
simpl.
apply H.

(* Addition to case 9: jne fallthrough *)
simpl.
left.
rewrite -> plus_comm.
auto.

(* Tenth induction case *)
left.
simpl.
rewrite -> plus_comm.
simpl.
auto.

(* Case 11 *)
left.
simpl.
rewrite -> plus_comm.
simpl.
auto.

(* Case 12: svaSwap *)
simpl.
simpl in H0.
right.
unfold vlookup.
unfold vLookup.
simpl.
assert (validThread (getThread vr tl) CFG MMU DS).
apply threadIsValid.
auto.

destruct H.
destruct H2.
destruct getThread.
unfold validThread in H1.
unfold canThreadSwap in H3.
destruct H3 as [H3 H4].
rewrite -> H3 in H1.
simpl.
unfold vLookup in H1.
destruct H1.
left.
auto.
right.
auto.

(* Case 13 *)
simpl.
right.
left.
apply I2.

(* Case 14 *)
simpl.
right.
assert (goodPCICL (getThreadICList tid tl) CFG MMU DS).
apply GoodPCICL.
auto.
destruct H as [H20 H].
destruct H as [H21 H].
destruct H as [H22 H].
rewrite -> H22.
simpl.
unfold vlookup.
simpl.
apply goodPCInItop in H1.
unfold goodPCIC in H1.
destruct H1.
left.
auto.
destruct H1.
right.
right.
left.
auto.
right.
right.
right.
auto.

(* Case 15 *)
simpl.
left.
rewrite -> plus_comm.
auto.

(* Case 16 *)
simpl.
left.
rewrite -> plus_comm.
auto.

(* Case 17 *)
simpl.
left.
rewrite -> plus_comm.
auto.

(* Case 18 *)
simpl.
left.
rewrite -> plus_comm.
auto.
Qed.

(*
 * Theorem: NXText
 *
 * Description:
 *   Prove that fetching an instruction through a virtual address never changes
 *   even though stores can modify physical memory and the MMU can remap pages.
 *)
Theorem NXText : forall (c1 c2     : config)
                        (v         : nat),
(getTextStart c1) <= (getPhysical (getTLB v (getCMMU c1))) <= (getTextEnd c1) /\
(validConfig c1) /\
(textNotWriteable c1) /\
(textMappedOnce c1) /\
c1 ==> c2
-> (vLookup v (getCMMU c1) (getStore c1)) =
   (vLookup v (getCMMU c2) (getStore c2)).
Proof.
intros.
destruct H as [h1 H].
destruct H as [h2 H].
destruct H as [h3 H].
destruct H as [h4 H].

(* Prove that several properties hold on the final configuration *)
(*
assert (validConfig c2).
apply alwaysValid with c1.
auto.
assert (textNotWriteable c2).
apply neverWriteText with c1.
auto.
assert (textMappedOnce c2).
apply neverMapTextTwice with c1.
auto.
*)

(* Prove by induction on the proof tree *)
destruct H.
destruct c.

(* Induction case 1 *)
auto.

(* Induction case 2 *)
auto.

(* Induction case 3 *)
simpl.
unfold vLookup.
simpl in h1.
simpl in h2.
simpl in h3.
destruct H.
destruct H0.

(*
 * Need to show that the two physical addresses must be different.  This is
 * because the address written cannot be in the text segment while the address
 * checked is within the text segment.  The address written cannot be within
 * the text segment because the text segment is not writeable.
 *)
assert (getPhysical (getTLB v MMU) <> getPhysical (getTLB n MMU)).

(* Detour: show that v is not writeable *)
simpl in h4.
assert (~ canWrite v MMU).
apply h3.
auto.

(* Back from detour: show that the two physical addresses must be different *)
assert (v <> n).
contradict H2.
rewrite -> H2.
apply H1.
apply h4.
auto.

(* Resume the proof of induction case 3 *)
rewrite <- sameRead.
auto.
apply H2.

(* Induction case 4 *)
auto.

(* Induction case 5 *)
auto.

(* Subtraction case *)
auto.

(* Induction case 6 *)
simpl.
destruct H as [h5 H].
destruct H as [h6 H].
destruct H as [h7 H].
destruct H as [h8 H].
destruct H as [h9 H].
rewrite -> h7 in h9.

simpl in h1.
simpl in h2.
simpl in h3.
simpl in h4.

assert (v <> v0).
destruct h9 as [ha | hb].

(* Case: getPhysical (getTLB v0 MMU) < cs *)
contradict ha.
apply le_not_lt.
rewrite <- ha.
apply h1.

(* Case: ce < getPhysical (getTLB v0 MMU) *)
contradict hb.
apply le_not_lt.
rewrite <- hb.
apply h1.

apply sameMMURead.
apply H0.

(* Induction case 7 *)
auto.

(* Induction case 8 *)
auto.
auto.

(* Induction case 9 *)
auto.
auto.

(* Induction case 10 *)
auto.

(* Induction case 11 *)
auto.

(* Induction case 12 *)
auto.

(* Induction case 13 *)
auto.

(* Induction case 14 *)
auto.

(* Induction case 15 *)
auto.

(* Induction case 16 *)
auto.

(* Induction case 17 *)
auto.

(* Induction case 18 *)
auto.
Qed.


(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                            Solange Coupet-Grimal                         *)
(*                                                                          *)
(*                                                                          *)
(*           Laboratoire d'Informatique Fondamentale de Marseille           *)
(*                   CMI-Technopole de Chateau-Gombert                      *)
(*                       39, Rue F. Joliot Curie                            *)
(*                      13453 MARSEILLE Cedex 13                            *)
(*                    Solange.Coupet@cmi.univ-mrs.fr                        *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V7.0                                  *)
(*                             Juillet  2002                                *)
(*                                                                          *)
(****************************************************************************)
(*                                fairness.v                                *)
(****************************************************************************)

Section fairness.

Require Import congruence.

Variables (state label : Set) (transition : label -> relation state)
  (fair : label -> Prop).

Notation Stream := (stream state) (only parsing).
Notation Stream_formula := (stream_formula state) (only parsing).
Notation Fair_step := (fair_step transition fair) (only parsing).
Notation Fairstr := (fairstr transition fair) (only parsing).
Notation Strong_fairstr := (strong_fairstr transition fair) (only parsing).

(************************* Fairness comparison ********************************)

Lemma strong_fairstr_implies_fairstr :
 forall str : stream state,
 strong_fairstr transition fair str -> fairstr transition fair str.

unfold fairstr in |- *; unfold strong_fairstr in |- *;
 unfold infinitely_often in |- *.
intros str H_fairstr.
apply
 implies_always
  with
    (P := eventually
            (fun str' : stream state =>
             fair_step transition fair (head_str str')
               (head_str (tl_str str')))); auto.
clear H_fairstr.
generalize str; clear str; unfold implies in |- *; cofix.
intros str; case str; clear str.
constructor; auto.
clear strong_fairstr_implies_fairstr.
intro H.
apply
 implies_eventually
  with
    (P := fun str' : stream state =>
          fair_step transition fair (head_str str') (head_str (tl_str str')));
 try assumption.
clear H.
apply lift_implies_stream; auto.
Qed.

End fairness.


Require Import Coq.Strings.String.

Require Export SystemFR.TermList.
Require Export SystemFR.ReducibilityMeasure.
Require Export SystemFR.ReducibilityCandidate.

From Equations Require Import Equations.
Require Import Equations.Prop.Subterm.
Require Import Coq.Classes.RelationClasses.

Require Import Psatz.

Definition reduces_to (P: tree -> Prop) (t: tree) :=
  closed_term t /\
  exists v, P v /\ t ~>* v.

Lemma reduces_to_equiv:
  forall (P P': tree -> Prop) t,
    reduces_to P t ->
    (forall v, P v -> P' v) ->
    reduces_to P' t.
Proof.
  unfold reduces_to; repeat step; eauto.
Qed.

Reserved Notation "[ ρ ⊨ v : T ]v" (at level 60, ρ at level 60, v at level 60).
Reserved Notation "[ ρ ⊨ t : T ]"  (at level 60, ρ at level 60, t at level 60).

Equations (noind) reducible_values (ρ: interpretation) (v: tree) (T: tree): Prop
    by wf (get_measure T) lt_measure := {
  reducible_values ρ v (fvar X type_var) :=
    match lookup PeanoNat.Nat.eq_dec ρ X with
    | None => False
    | Some P => P v
    end;

  reducible_values ρ v T_unit := v = uu;

  reducible_values ρ v T_bool := v = ttrue \/ v = tfalse;

  reducible_values ρ v T_nat := is_nat_value v;

  reducible_values ρ v (T_abs T) :=
    closed_value v /\
    exists X,
      ~(X ∈ support ρ) /\
      ~(X ∈ pfv T type_var) /\
      forall RC,
        reducibility_candidate RC ->
        [ (X,RC) :: ρ ⊨ v : topen 0 T (fvar X type_var) ]v;

  reducible_values ρ v (T_arrow A B) :=
    exists (_: is_erased_type B),
    closed_value v /\
    forall a (p: is_erased_term a),
      wf a 0 ->
      pfv a term_var = nil ->
      [ ρ ⊨ a : A ]v ->
      [ ρ ⊨ app v a : open 0 B a ];

  reducible_values ρ v (T_prod A B) :=
    exists (_: is_erased_type B),
    closed_value v /\
    exists a b (_: is_erased_term a),
      wf a 0 /\
      pfv a term_var = nil /\
      v = pp a b /\
      [ ρ ⊨ a : A ]v /\
      [ ρ ⊨ b : open 0 B a ]v;

  reducible_values ρ v (T_sum A B) :=
    closed_value v /\ (
      (exists v', v = tleft v' /\ [ ρ ⊨ v' : A ]v) \/
      (exists v', v = tright v' /\ [ ρ ⊨ v' : B ]v)
    );

  reducible_values ρ v (T_refine T p) :=
    closed_value v /\
    [ ρ ⊨ v : T ]v /\
    is_erased_term p /\
    wf p 1 /\
    pfv p term_var = nil /\
    open 0 p v ~>* ttrue;

  reducible_values ρ v (T_type_refine T1 T2) :=
    exists (_: is_erased_type T2),
    exists (_: closed_value v),
      [ ρ ⊨ v : T1 ]v /\
      exists p, [ ρ ⊨ p : open 0 T2 v ]v;

  reducible_values ρ v (T_intersection A B) :=
    closed_value v /\
    [ ρ ⊨ v : A ]v /\
    [ ρ ⊨ v : B ]v;

  reducible_values ρ v (T_union A B) :=
    closed_value v /\ (
      [ ρ ⊨ v : A ]v \/
      [ ρ ⊨ v : B ]v
    );

  reducible_values ρ v T_top := closed_value v;

  reducible_values ρ v T_bot := False;

  reducible_values ρ v (T_equiv t1 t2) :=
    v = uu /\
    [ t1 ≡ t2 ];

  reducible_values ρ v (T_forall A B) :=
    exists (_: is_erased_type B),
    closed_value v /\
    forall a (p: is_erased_term a),
      wf a 0 ->
      pfv a term_var = nil ->
      [ ρ ⊨ a : A ]v ->
      [ ρ ⊨ v : open 0 B a ]v;

  reducible_values ρ v (T_exists A B) :=
    exists (_: is_erased_type B),
    closed_value v /\
    exists a (_: is_erased_term a),
      wf a 0 /\
      pfv a term_var = nil /\
      [ ρ ⊨ a : A ]v /\
      [ ρ ⊨ v : open 0 B a ]v;

  reducible_values ρ v (T_rec n T0 Ts) :=
    closed_value v /\
    is_erased_term n /\ (
      (n ~>* zero /\ [ ρ ⊨ v : T0 ]v) \/
      (exists n' X (p1: is_nat_value n') (p2: n ~>* succ n'),
         ~(X ∈ pfv T0 type_var) /\
         ~(X ∈ pfv Ts type_var) /\
         ~(X ∈ support ρ) /\
          [ (X, fun t => [ ρ ⊨ t : T_rec n' T0 Ts ]v) :: ρ ⊨ v : topen 0 Ts (fvar X type_var) ]v
      )
    );

  reducible_values _ _ _ := False
}
  where "[ ρ ⊨ v : T ]v" := (reducible_values ρ v T)
  where "[ ρ ⊨ t : T ]" := (reduces_to (fun v => [ ρ ⊨ v : T ]v) t)
.

#[export]
Hint Transparent lt_measure: core.

Ltac reducibility_definition :=
  repeat step || autorewrite with bsize || unfold "<<", get_measure, closed_value, closed_term in *;
    try solve [ apply right_lex, right_lex, lt_index_step; steps ];
    try solve [ apply right_lex, lt_index_step; steps ];
    try solve [ apply leq_lt_measure; lia ];
    try solve [ apply left_lex; lia ].

Solve Obligations with reducibility_definition.

Fail Next Obligation. (* no more obligations for reducible_values *)

Notation "'[' ρ '⊨' T1 '<:' T2 ']'" := (forall v, [ ρ ⊨ v : T1 ]v -> [ ρ ⊨ v : T2 ]v)
  (at level 60, ρ at level 60, T1 at level 60).

Notation "'[' v ':' T ']v'" := ([ nil ⊨ v : T ]v)
  (at level 60, v at level 60, format "[  v  :  T  ]v").

Notation "'[' t ':' T ']'" := ([ nil ⊨ t : T ])
  (at level 60, t at level 60, format "[  t  :  T  ]").

Definition equivalent_types ρ T1 T2 :=
  forall v, [ ρ ⊨ v : T1 ]v <-> [ ρ ⊨ v : T2 ]v.

Notation "'[' ρ ⊨ T1 '=' T2 ']'" := (equivalent_types ρ T1 T2)
  (ρ at level 60, T1 at level 60, T2 at level 60, at level 60).

Definition open_reducible (Θ: tvar_list) (Γ: context) t T : Prop :=
  forall ρ lterms,
    valid_interpretation ρ ->
    satisfies (reducible_values ρ) Γ lterms  ->
    support ρ = Θ ->
    [ ρ ⊨ substitute t lterms : substitute T lterms ].

Definition open_subtype (Θ: tvar_list) (Γ: context) T1 T2 : Prop :=
  forall ρ l,
    valid_interpretation ρ ->
    satisfies (reducible_values ρ) Γ l ->
    support ρ = Θ ->
    [ ρ ⊨ substitute T1 l <: substitute T2 l ].

Definition open_equivalent_types (Θ: tvar_list) (Γ: context) T1 T2 : Prop :=
  forall ρ l,
    valid_interpretation ρ ->
    satisfies (reducible_values ρ) Γ l ->
    support ρ = Θ ->
    [ ρ ⊨ substitute T1 l = substitute T2 l ].

Definition open_equivalent (Θ: tvar_list) (Γ: context) t1 t2 : Prop :=
  forall ρ l,
    valid_interpretation ρ ->
    satisfies (reducible_values ρ) Γ l ->
    support ρ = Θ ->
    [ substitute t1 l ≡ substitute t2 l ].

Notation "'[' Θ ';' Γ '⊨' t ':' T ']'" := (open_reducible Θ Γ t T)
  (at level 60, Θ at level 60, Γ at level 60, t at level 60).

Notation "'[' Θ ';' Γ '⊨' T1 '<:' T2 ']'" := (open_subtype Θ Γ T1 T2)
  (at level 60, Θ at level 60, Γ at level 60, T1 at level 60).

Notation "'[' Θ ';' Γ '⊨' t1 '≡' t2 ']'" := (open_equivalent Θ Γ t1 t2)
  (at level 60, Θ at level 60, Γ at level 60, t1 at level 60, t2 at level 60).

Notation "'[' Θ ';' Γ '⊨' T1 '=' T2 ']'" :=
  (open_equivalent_types Θ Γ T1 T2)
  (at level 60, Θ at level 60, Γ at level 60, T1 at level 60, T2 at level 60).

Notation "'[' Γ '⊫' t ':' T ']'" :=
  (open_reducible nil Γ t T)
  (at level 60, Γ at level 60, t at level 60, T at level 60).

Notation "'[' Γ '⊫' T1 '<:' T2 ']'" :=
  (open_subtype nil Γ T1 T2)
  (at level 60, Γ at level 60, T1 at level 60, T2 at level 60).

Notation "'[' Γ '⊫' T1 '=' T2 ']'" :=
  (open_equivalent_types nil Γ T1 T2)
  (at level 60, Γ at level 60, T1 at level 60, T2 at level 60).

Notation "'[' Γ '⊫' t1 '≡' t2 ']'" :=
  (open_equivalent nil Γ t1 t2)
  (at level 60, Γ at level 60, t1 at level 60, t2 at level 60).

Lemma reducibility_rewrite:
  forall ρ t T,
    reduces_to (fun v => [ ρ ⊨ v : T ]v) t =
    [ ρ ⊨ t : T ].
Proof.
  reflexivity.
Qed.

(* see https://github.com/coq/coq/issues/3814 *)
#[export]
Instance: subrelation eq Basics.impl.
Proof.
  steps.
Qed.

#[export]
Instance: subrelation eq (Basics.flip Basics.impl).
Proof.
  steps.
Qed.

Ltac simp_red_hyp :=
  match goal with
  | H: _ |- _ => rewrite_strat outermost hints reducible_values in H
  end.

Ltac simp_red_top_level_hyp :=
  match goal with
  | H: _ |- _ => rewrite_strat hints reducible_values in H
  end.

Ltac simp_red_goal := rewrite_strat outermost hints reducible_values.

Ltac simp_red_top_level_goal := rewrite_strat hints reducible_values.

Ltac simp_red := simp_red_hyp || simp_red_goal.

Ltac simp_red_nat :=
  match goal with
  | H: [ _ ⊨ _ : T_nat ]v |- _ => simp reducible_values in H
  end.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.whiskering.

Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.Colimits.Initial.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection.
Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Transformations.Examples.Whiskering.
Require Import UniMath.Bicategories.Transformations.Examples.Associativity.
Require Import UniMath.Bicategories.Transformations.Examples.Unitality.
Require Import UniMath.Bicategories.Modifications.Modification.

Require Import prelude.all.
Require Import signature.hit_signature.
Require Import signature.hit.
Require Import algebra.one_types_polynomials.
Require Import algebra.one_types_endpoints.
Require Import algebra.one_types_homotopies.
Require Import displayed_algebras.displayed_algebra.
Require Import existence.hit_existence.
Require Import existence.initial_algebra.
Require Import examples.free_algebra.
Require Import free_alg_biadj.free_alg_functor.
Require Import free_alg_biadj.free_alg_unit.
Require Import free_alg_biadj.free_alg_counit.
Require Import free_alg_biadj.free_alg_biadjunction_unit_counit.

Local Open Scope cat.

Opaque hit_existence.
Opaque make_free_alg_algebra.
Opaque free_ump_1.
Opaque free_alg_ump_2.
Opaque free_alg_ump_eq.

Section FreeAlgebraLeftTriangle.
  Variable (Σ : hit_signature).

  Definition free_alg_left_triangle_comp
             (X : one_type)
    : biadj_triangle_l_lhs (free_alg_unit_counit Σ) X
      ==>
      id_pstrans (free_alg_psfunctor Σ) X.
  Proof.
    use free_alg_ump_2.
    - apply free_alg_is_initial.
    - exact (free_alg_inc (free_alg _ X)).
    - intro x.
      exact (maponpaths
               (alg_map_carrier (free_alg_counit_comp _ _))
               (free_alg_mor_on_A (free_alg_unit_comp Σ X) x)
             @ free_alg_counit_comp_on_A Σ (free_alg_psfunctor_obj Σ X) _).
    - exact (λ _, idpath _).
  Defined.

  Definition free_alg_left_triangle_comp_on_A
             (X : one_type)
             (x : X)
    : alg_2cell_carrier
        (free_alg_left_triangle_comp X)
        (free_alg_inc _ x)
      =
      maponpaths
        (alg_map_carrier (free_alg_counit_comp _ _))
        (free_alg_mor_on_A (free_alg_unit_comp Σ X) x)
      @ free_alg_counit_comp_on_A Σ (free_alg_psfunctor_obj Σ X) _.
  Proof.
    refine (!(pathscomp0rid _) @ _).
    exact (free_alg_ump_2_on_A _ _ _ _ _ x).
  Qed.

  Definition free_alg_left_triangle_data
    : invertible_modification_data
        (biadj_triangle_l_lhs (free_alg_unit_counit Σ))
        (id_pstrans (free_alg_psfunctor Σ)).
  Proof.
    intro X.
    use make_invertible_2cell.
    - exact (free_alg_left_triangle_comp X).
    - apply hit_alg_is_invertible_2cell_one_type.
  Defined.

  Definition free_alg_counit_natural_on_A_help
             {X Y : one_type}
             (f : X → Y)
             (x : X)
    : alg_2cell_carrier
        (free_alg_counit_natural Σ (free_alg_psfunctor_mor Σ f))
        (free_alg_inc _ (free_alg_unit_comp Σ X x))
      @ maponpaths
          (alg_map_carrier (free_alg_counit_comp Σ (free_alg_psfunctor_obj Σ Y)))
          (free_alg_mor_on_A
             (alg_map_carrier (free_alg_psfunctor_mor Σ f))
             (free_alg_unit_comp Σ X x))
      @ free_alg_counit_comp_on_A
          Σ (free_alg_psfunctor_obj Σ Y)
          (alg_map_carrier
             (free_alg_psfunctor_mor Σ f)
             (free_alg_unit_comp Σ X x))
      =
      maponpaths
        (alg_map_carrier (free_alg_psfunctor_mor Σ f))
        (free_alg_counit_comp_on_A
           Σ
           (free_alg_psfunctor_obj Σ X)
           (free_alg_unit_comp Σ X x)).
  Proof.
    exact (free_alg_counit_natural_on_A
             Σ
             (free_alg_psfunctor_mor Σ f)
             (free_alg_unit_comp Σ X x)).
  Qed.

  Local Lemma free_alg_left_triangle_is_modification_help
        {X Y : one_type}
        (f : X → Y)
        (x : X)
    : (((((((((((maponpaths
                   (λ (z : alg_carrier (free_alg Σ Y)), z)
                   (alg_2cell_carrier
                      (free_alg_counit_natural Σ (free_alg_psfunctor_mor Σ f))
                      (alg_map_carrier
                         (free_alg_psfunctor_mor Σ (free_alg_unit_comp Σ X))
                         (free_alg_inc _ x)))
                   @ idpath _)
                  @ idpath _)
                 @ idpath _)
                @ idpath _)
               @ idpath _)
              @ maponpaths
                  (alg_map_carrier (free_alg_counit_comp Σ (free_alg_psfunctor_obj Σ Y)))
                  (((pr111 (free_alg_psfunctor_comp
                              Σ (free_alg_unit_comp Σ X)
                              (alg_map_carrier (free_alg_psfunctor_mor Σ f))))
                              (free_alg_inc (free_alg Σ X) x)
                      @ alg_2cell_carrier
                          (free_alg_psfunctor_cell Σ (free_alg_unit_natural Σ f))
                          (free_alg_inc _ x))
                     @ !(alg_2cell_carrier
                           (free_alg_psfunctor_comp Σ f (free_alg_unit_comp Σ Y))
                           (free_alg_inc _ x))))
             @ idpath _)
            @ idpath _)
           @ idpath _)
          @ idpath _)
         @ alg_2cell_carrier
             (free_alg_left_triangle_comp Y)
             (alg_map_carrier
                (free_alg_psfunctor_mor Σ f)
                (free_alg_inc _ x)))
        @ free_alg_mor_on_A f x
      =
      maponpaths
        (alg_map_carrier (free_alg_psfunctor_mor Σ f))
        (maponpaths
           (alg_map_carrier (free_alg_counit_comp Σ (free_alg_psfunctor_obj Σ X)))
           (free_alg_mor_on_A (free_alg_unit_comp Σ X) x)
      @ free_alg_counit_comp_on_A
          Σ (free_alg_psfunctor_obj Σ X)
          (free_alg_unit_comp Σ X x))
      @ free_alg_mor_on_A f x.
  Proof.
    etrans.
    {
      do 2 apply maponpaths_2.
      do 4 refine (pathscomp0rid _ @ _).
      apply maponpaths_2.
      do 5 refine (pathscomp0rid _ @ _).
      apply maponpathsidfun.
    }
    etrans.
    {
      do 2 apply maponpaths_2.
      do 2 apply maponpaths.
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          exact (free_alg_psfunctor_comp_on_A _ f (free_alg_unit_comp Σ Y) x).
        }
        refine (pathscomp_inv _ _ @ _).
        apply maponpaths_2.
        refine (pathscomp_inv _ _ @ _).
        apply maponpaths_2.
        apply pathsinv0inv0.
      }
      etrans.
      {
        refine (!(path_assoc _ _ _) @ _).
        apply maponpaths.
        refine (path_assoc _ _ _ @ _).
        apply maponpaths_2.
        refine (path_assoc _ _ _ @ _).
        apply maponpaths_2.
        exact (free_alg_psfunctor_cell_on_A Σ (free_alg_unit_natural Σ f) x).
      }
      etrans.
      {
        apply maponpaths_2.
        exact (free_alg_psfunctor_comp_on_A
                 _
                 (free_alg_unit_comp Σ X)
                 (alg_map_carrier (free_alg_psfunctor_mor Σ f))
                 x).
      }
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      etrans.
      {
        refine (path_assoc _ _ _ @ _).
        apply maponpaths_2.
        apply pathsinv0l.
      }
      apply pathscomp0lid.
    }
    etrans.
    {
      do 2 apply maponpaths_2.
      etrans.
      {
        apply maponpaths.
        apply (maponpathscomp0
                 (alg_map_carrier (free_alg_counit_comp Σ (free_alg_psfunctor_obj Σ Y)))).
      }
      refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths.
        apply (maponpathscomp
                 (alg_map_carrier
                    (free_alg_psfunctor_mor
                       Σ
                       (alg_map_carrier (free_alg_psfunctor_mor Σ f))))
                 (alg_map_carrier
                    (free_alg_counit_comp Σ (free_alg_psfunctor_obj Σ Y)))).
      }
      exact (!(homotsec_natural'
                 (alg_2cell_carrier
                    (free_alg_counit_natural Σ (free_alg_psfunctor_mor Σ f)))
                 (free_alg_mor_on_A (free_alg_unit_comp Σ X) x))).
    }
    do 3 refine (!(path_assoc _ _ _) @ _).
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      etrans.
      {
        apply maponpathscomp0.
      }
      apply maponpaths_2.
      apply (maponpathscomp
               (alg_map_carrier (free_alg_counit_comp Σ (free_alg_psfunctor_obj Σ X)))
               (alg_map_carrier (free_alg_psfunctor_mor Σ f))).
    }
    refine (!(path_assoc _ _ _) @ _).
    apply maponpaths.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths_2.
        apply maponpathscomp0.
      }
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths.
          refine (!_).
          apply (maponpathsinv0
                   (alg_map_carrier
                      (free_alg_psfunctor_mor Σ (free_alg_unit_comp Σ Y)))).
        }
        apply (maponpathscomp
                 (alg_map_carrier (free_alg_psfunctor_mor Σ (free_alg_unit_comp Σ Y)))
                 (alg_map_carrier (free_alg_counit_comp Σ (free_alg_psfunctor_obj Σ Y)))).
      }
      exact (homotsec_natural'
               (alg_2cell_carrier (free_alg_left_triangle_comp Y))
               (!(free_alg_mor_on_A f x))).
    }
    do 2 refine (path_assoc _ _ _ @ _).
    apply maponpaths_2.
    etrans.
    {
      apply maponpaths.
      apply maponpaths_2.
      exact (free_alg_left_triangle_comp_on_A Y (f x)).
    }
    refine (path_assoc _ _ _ @ _).
    etrans.
    {
      apply maponpaths_2.
      refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      etrans.
      {
        refine (!_).
        apply maponpathscomp0.
      }
      apply maponpaths.
      etrans.
      {
        do 2 (refine (!(path_assoc _ _ _) @ _) ; apply maponpaths).
        apply pathsinv0l.
      }
      apply maponpaths.
      apply pathscomp0rid.
    }
    etrans.
    {
      apply maponpaths_2.
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      etrans.
      {
        apply maponpaths_2.
        apply maponpathscomp0.
      }
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      etrans.
      {
        apply maponpaths_2.
        apply maponpathscomp.
      }
      exact (homotsec_natural'
               (free_alg_counit_comp_on_A Σ (free_alg_psfunctor_obj Σ Y))
               (free_alg_unit_natural Σ f x)).
    }
    etrans.
    {
      apply maponpaths_2.
      do 3 apply maponpaths.
      apply maponpathsidfun.
    }
    etrans.
    {
      apply maponpaths.
      apply maponpathsidfun.
    }
    refine (!(path_assoc _ _ _) @ _).
    etrans.
    {
      apply maponpaths.
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      refine (!(path_assoc _ _ _) @ _).
      etrans.
      {
        apply maponpaths.
        apply pathsinv0r.
      }
      apply pathscomp0rid.
    }
    exact (free_alg_counit_natural_on_A_help f x).
  Qed.

  Definition free_alg_left_triangle_is_modification
    : is_modification free_alg_left_triangle_data.
  Proof.
    intros X Y f.
    use free_alg_ump_eq.
    - apply free_alg_is_initial.
    - exact (λ z, free_alg_inc (free_alg _ Y) (f z)).
    - intro x ; cbn.
      exact (maponpaths
               (alg_map_carrier (free_alg_psfunctor_mor Σ f))
               (maponpaths
                  (alg_map_carrier (free_alg_counit_comp Σ (free_alg_psfunctor_obj Σ X)))
                  (free_alg_mor_on_A (free_alg_unit_comp _ X) x)
                @ free_alg_counit_comp_on_A
                    _
                    (free_alg_psfunctor_obj Σ X)
                    _)
             @ free_alg_mor_on_A f x).
    - exact (free_alg_mor_on_A f).
    - intro x.
      cbn ; unfold homotcomp, funhomotsec, homotfun.
      rewrite !pathscomp0lid.
      exact (free_alg_left_triangle_is_modification_help f x).
    - intro x.
      cbn ; unfold homotcomp, funhomotsec, homotfun.
      apply maponpaths_2.
      refine (pathscomp0rid _ @ _).
      apply maponpaths.
      exact (free_alg_left_triangle_comp_on_A X x).
  Qed.

  Definition free_alg_left_triangle
    : biadj_triangle_l_law (free_alg_unit_counit Σ).
  Proof.
    use make_invertible_modification.
    - exact free_alg_left_triangle_data.
    - exact free_alg_left_triangle_is_modification.
  Defined.
End FreeAlgebraLeftTriangle.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D E F Dprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ C D /\ (wd_ D A /\ (wd_ A C /\ (wd_ B D /\ (wd_ D E /\ (wd_ E F /\ (wd_ F C /\ (wd_ C E /\ (wd_ D F /\ (wd_ A E /\ (wd_ C Dprime /\ (wd_ D Dprime /\ (wd_ B F /\ (col_ A E F /\ (col_ B E F /\ col_ D C Dprime))))))))))))))))) -> col_ A B F)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* The spec and proof of the following rules are based on `The Ramifications  *)
(* of Sharing in Data Structures' by Aquinas Hobor and Jules Villard.         *)
(*    RAMIF_PLAIN.frame                                                       *)
(*    RAMIF_PLAIN.split                                                       *)
(* The following lemmas are found useful by Shengyi Wang, Qinxiang Cao and    *)
(* Aquinas Hobor in 2015 summer in Yale-NUS.                                  *)
(*    RAMIF_PLAIN.solve                                                       *)
(*    RAMIF_Q.reduce                                                          *)
(*    RAMIF_Q.solve                                                           *)
(*    RAMIF_Q.frame                                                           *)
(*    RAMIF_Q.split                                                           *)
(* The following lemmas are developed by Qinxiang Cao in 2015 in Princeton.   *)
(*    RAMIF_PLAIN.trans                                                       *)
(*    RAMIF_PLAIN.weak_ramif_spec                                             *)
(*    RAMIF_PLAIN.exp_right                                                   *)
(*    RAMIF_Q.trans                                                           *)
(*    RAMIF_Q.simple_trans                                                    *)
(*    RAMIF_Q.weak_ramif_spec                                                 *)
(*    RAMIF_Q.plain_spec                                                      *)
(*    RAMIF_Q.exp_right                                                       *)

Require Import VST.msl.base.
Require Import VST.msl.Coqlib2.
Require Import VST.msl.simple_CCC.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.

Local Open Scope logic.

Lemma modus_ponens_wand' {A}{ND: NatDed A}{SL: SepLog A}:
                      forall P P' Q: A, (P |-- P') ->  derives (sepcon P (wand P' Q)) Q.
Proof.
intros.
   eapply derives_trans; [apply sepcon_derives; [ | apply derives_refl] | apply modus_ponens_wand ].
  auto.
Qed.

Module RAMIF_PLAIN.
Section RAMIF_PLAIN.

Context {A : Type}.
Context {ND : NatDed A}.
Context {SL : SepLog A}.

Lemma solve: forall g l g' l' F, (g |-- l * F) -> (F * l' |-- g') -> g |-- l * (l' -* g').
Proof.
  intros.
  apply derives_trans with (l * F); auto.
  apply sepcon_derives; auto.
  apply wand_sepcon_adjoint.
  auto.
Qed.

Lemma weak_ramif_spec: forall g l g' l', (g |-- l * (l' -* g')) -> g |-- l * TT.
Proof.
  intros.
  eapply derives_trans; [exact H |].
  apply sepcon_derives; auto.
  apply TT_right.
Qed.

Lemma trans: forall g m l g' m' l',
      (g |-- m * (m' -* g')) ->
      (m |-- l * (l' -* m')) ->
      g |-- l * (l' -* g').
Proof.
  intros.
  apply solve with ((l' -* m') * (m' -* g')).
  + eapply derives_trans; [exact H |].
    eapply derives_trans; [apply sepcon_derives; [exact H0 | apply derives_refl] |].
    rewrite sepcon_assoc; auto.
  + rewrite (sepcon_comm _ l'), <- sepcon_assoc.
    eapply derives_trans; [| apply modus_ponens_wand].
    apply sepcon_derives; [| apply derives_refl].
    apply modus_ponens_wand.
Qed.

Lemma trans':
   forall (m l g' m' l': A),
       (m |-- l * (l' -* m')) ->
       m * (m' -* g') |-- l * (l' -* g').
Proof.
  intros. eapply trans. apply derives_refl. auto.
Qed.

Lemma trans'':
   forall (p g' m' l': A),
       (p |-- l' -* m') ->
       p * (m' -* g') |-- (l' -* g').
Proof.
  intros.
  rewrite -> wand_sepcon_adjoint.
  eapply derives_trans; [apply H | ]. clear H.
  rewrite <- wand_sepcon_adjoint.
  rewrite <- wand_sepcon_adjoint.
  pull_left l'. apply modus_ponens_wand'. apply modus_ponens_wand.
Qed.

Lemma split: forall g1 g2 l1 l2 g1' g2' l1' l2',
  (g1 |-- l1 * (l1' -* g1')) ->
  (g2 |-- l2 * (l2' -* g2')) ->
  g1 * g2 |-- (l1 * l2) * (l1' * l2' -* g1' * g2').
Proof.
  intros.
  apply solve with ((l1' -* g1') * (l2' -* g2')).
  + rewrite (sepcon_assoc l1), <- (sepcon_assoc l2), (sepcon_comm l2), (sepcon_assoc _ l2), <- (sepcon_assoc l1).
    apply sepcon_derives; auto.
  + eapply derives_trans; [apply sepcon_derives; [apply wand_sepcon_wand | apply derives_refl] |].
    rewrite sepcon_comm; apply modus_ponens_wand.
Qed.

(* Using split to prove frame will lead to a simpler proof. *)
(* But it requires a unitary separation logic.              *)
Lemma frame: forall g l g' l' F, (g |-- l * (l' -* g')) -> g * F |-- l * (l' -* g' * F).
Proof.
  intros.
  apply solve with ((l' -* g') * F).
  + rewrite <- sepcon_assoc.
    apply sepcon_derives; auto.
  + rewrite (sepcon_comm _ l'), <- sepcon_assoc.
    apply sepcon_derives; [apply modus_ponens_wand | auto].
Qed.

Lemma frame_post: forall g l g' l' F, (g |-- l * (l' -* g')) -> g |-- l * (l' * F -* g' * F).
Proof.
  intros.
  apply solve with (l' -* g').
  + auto.
  + rewrite <- sepcon_assoc.
    apply sepcon_derives; [rewrite sepcon_comm; apply modus_ponens_wand | auto].
Qed.

Lemma frame_pre: forall g l g' l' F, (g |-- l * (l' -* g')) -> g * F |-- (l * F) * (l' -* g').
Proof.
  intros.
  apply solve with (l' -* g').
  + rewrite (sepcon_comm l F), sepcon_assoc, (sepcon_comm F).
    apply sepcon_derives; auto.
  + rewrite sepcon_comm; apply modus_ponens_wand.
Qed.

Lemma exp_right: forall {T} (a: T) g l g' l',
  (g |-- l * (l' -* g' a)) ->
  g |-- l * (l' -* exp g').
Proof.
  intros.
  apply solve with (l' -* g' a); auto.
  apply wand_sepcon_adjoint.
  apply wand_derives; auto.
  apply (exp_right a); auto.
Qed.

End RAMIF_PLAIN.
End RAMIF_PLAIN.

Module RAMIF_Q.
Section RAMIF_Q.

Context {A : Type}.
Context {ND : NatDed A}.
Context {SL : SepLog A}.

Lemma reduce: forall {B} g l (g' l': B -> A),
  (g |-- l * (allp (l' -* g'))) ->
  g |-- l * (exp l' -* exp g').
Proof.
  intros.
  eapply derives_trans; [exact H |].
  apply sepcon_derives; [auto |].
  apply wand_sepcon_adjoint.
  rewrite exp_sepcon2.
  apply exp_left; intro x; apply (exp_right x).
  apply wand_sepcon_adjoint.
  apply (allp_left _ x).
  apply derives_refl.
Qed.

Lemma solve: forall {B} g l g' l' F,
  (g |-- l * F) ->
  (forall x: B, F * l' x |-- g' x) ->
  g |-- l * (allp (l' -* g')).
Proof.
  intros.
  apply derives_trans with (l * F); auto.
  apply sepcon_derives; auto.
  apply allp_right; intro x.
  simpl;
  apply wand_sepcon_adjoint.
  apply H0.
Qed.

Lemma weak_ramif_spec: forall {B} g l (g' l': B -> A),
  (g |-- l * allp (l' -* g')) -> g |-- l * TT.
Proof.
  intros.
  eapply derives_trans; [exact H |].
  apply sepcon_derives; auto.
  apply TT_right.
Qed.

Lemma plain_spec: forall {B} g l g' l' (x: B),
  (g |-- l * (allp (l' -* g'))) ->
  g |-- l *  (l' x -* g' x).
Proof.
  intros.
  eapply derives_trans; [exact H |].
  apply sepcon_derives; [auto |].
  apply (allp_left _ x). apply derives_refl.
Qed.

Lemma trans: forall {B BG BL} g m l g' mG' mL' l' (fG: B -> BG) (fL: B -> BL),
  (forall b, mL' (fL b) |-- mG' (fG b)) ->
  (g |-- m * allp (mG' -* g')) ->
  (m |-- l * allp (l' -* mL')) ->
  g |-- l * allp (Basics.compose l' fL -* Basics.compose g' fG).
Proof.
  intros.
  apply solve with (allp (l' -* mL') * allp (mG' -* g')); auto.
  + eapply derives_trans; [exact H0 |].
    eapply derives_trans; [apply sepcon_derives; [exact H1 | apply derives_refl] |].
    rewrite sepcon_assoc; auto.
  + intro b.
    rewrite sepcon_assoc.
    apply wand_sepcon_adjoint.
    apply (allp_left _ (fL b)).
    apply wand_sepcon_adjoint.
    rewrite sepcon_comm, sepcon_assoc, sepcon_comm.
    apply wand_sepcon_adjoint.
    apply derives_trans with (mG' (fG b)).
    - eapply derives_trans; [| apply H].
      simpl; apply modus_ponens_wand.
    - apply wand_sepcon_adjoint.
      rewrite sepcon_comm.
      apply wand_sepcon_adjoint.
      apply (allp_left _ (fG b)).
      apply derives_refl.
Qed.

Lemma simple_trans: forall {B} g m l (g' m' l': B -> A),
  (g |-- m * allp (m' -* g')) ->
  (m |-- l * allp (l' -* m')) ->
  g |-- l * allp (l' -* g').
Proof.
  intros.
  eapply trans with (mL' := m') (mG' := m') (fL := id B) (fG := id B); eauto.
Qed.

Lemma trans'':
  forall {CS: ClassicalSep A}
     {B C: Type} (f: B->C) p l m g1 g2,
     g2 = g1 oo f ->
     (p |-- allp (l -* m oo f)) ->
     p * allp (m -* g1) |-- allp (l -* g2).
Proof.
   intros.
   subst g2.
   apply allp_right; intro x.
   simpl. rewrite <- wand_sepcon_adjoint.
   rewrite sepcon_assoc.
   eapply derives_trans; [apply sepcon_derives; [apply H0 | apply derives_refl] | ].
    rewrite -> wand_sepcon_adjoint.
  apply allp_left with x.
   rewrite <- wand_sepcon_adjoint.
   simpl.
   rewrite <- !sepcon_assoc.
   pull_left (l x).
   eapply derives_trans; [apply sepcon_derives; [ | apply derives_refl] | ].
   apply modus_ponens_wand.
   rewrite sepcon_comm.
   rewrite -> wand_sepcon_adjoint.
   apply allp_left with (f x). apply derives_refl.
Qed.

Lemma split: forall {B} g1 g2 l1 l2 (g1' g2' l1' l2': B -> A),
  (g1 |-- l1 * allp (l1' -* g1')) ->
  (g2 |-- l2 * allp (l2' -* g2')) ->
  g1 * g2 |-- (l1 * l2) * allp (l1' * l2' -* g1' * g2').
Proof.
  intros.
  apply solve with (allp (l1' -* g1') * allp (l2' -* g2')).
  + rewrite (sepcon_assoc l1), <- (sepcon_assoc l2), (sepcon_comm l2), (sepcon_assoc _ l2), <- (sepcon_assoc l1).
    apply sepcon_derives; auto.
  + intros x.
    change ((l1' * l2') x) with (l1' x * l2' x).
    rewrite <- (sepcon_assoc _ (l1' x)), (sepcon_assoc _ _ (l1' x)), (sepcon_comm _ (l1' x)), <- (sepcon_assoc _ (l1' x)), (sepcon_assoc _ _ (l2' x)).
    apply sepcon_derives.
    - apply wand_sepcon_adjoint.
      apply (allp_left _ x); apply derives_refl.
    - apply wand_sepcon_adjoint.
      apply (allp_left _ x).
      apply derives_refl.
Qed.

(* Using split to prove frame will lead to a simpler proof. *)
(* But it requires a unitary separation logic.              *)
Lemma frame: forall {B} g l (g' l': B -> A) F,
  (g |-- l * allp (l' -* g')) ->
  g * F |-- l * allp (l' -* g' * Basics.const F).
Proof.
  intros.
  apply solve with (allp (l' -* g') * F).
  + rewrite <- sepcon_assoc.
    apply sepcon_derives; auto.
  + intros x; unfold Basics.const; simpl.
    rewrite (sepcon_comm _ (l' x)), <- sepcon_assoc.
    apply sepcon_derives; [| auto].
    rewrite sepcon_comm; apply wand_sepcon_adjoint.
    apply (allp_left _ x); auto.
Qed.

Lemma frame_post: forall {B} g l (g' l' F: B -> A),
  (g |-- l * allp (l' -* g')) ->
  g |-- l * allp (l' * F -* g' * F).
Proof.
  intros.
  apply solve with (allp (l' -* g')).
  + auto.
  + intros x; simpl.
    rewrite <- sepcon_assoc.
    apply sepcon_derives; [rewrite sepcon_comm | auto].
    rewrite sepcon_comm; apply wand_sepcon_adjoint.
    apply (allp_left _ x); auto.
Qed.

Lemma frame_pre: forall {B} g l (g' l': B -> A) F,
  (g |-- l * allp (l' -* g')) ->
  g * F |-- (l * F) * allp (l' -* g').
Proof.
  intros.
  apply solve with (allp (l' -* g')).
  + rewrite (sepcon_comm l F), sepcon_assoc, (sepcon_comm F).
    apply sepcon_derives; auto.
  + intros x.
    apply wand_sepcon_adjoint.
    apply (allp_left _ x); apply derives_refl.
Qed.

Lemma exp_right: forall {T B} (a: B -> T) g l (g': T -> B -> A) (l': B -> A),
  (g |-- l * allp (l' -* (fun b => g' (a b) b))) ->
  g |-- l * allp (l' -* exp g').
Proof.
  intros.
  apply solve with (allp (l' -* (fun b => g' (a b) b))); auto.
  intros.
  apply wand_sepcon_adjoint.
  apply (allp_left _ x).
  simpl.
  apply wand_derives; auto.
  apply (exp_right (a x)); auto.
Qed.

End RAMIF_Q.

Ltac formalize :=
  match goal with
  | |- @derives ?Pred _ ?g (?l * @allp ?Pred _ ?T ?Func) =>
      let g' := fresh "g'" in evar (g': T -> Pred);
      let l' := fresh "l'" in evar (l': T -> Pred);
      let x := fresh "x" in
      let H := fresh "H" in
      assert (Func = l' -* g') as H;
      [
        extensionality x; cbv beta;
        match goal with
        | |- ?L' -* exp ?G' = _ =>
             super_pattern L' x; super_pattern_in_func G' x
        | |- ?L' -* ?G' = _ =>
             super_pattern L' x; super_pattern G' x
        end;
        match goal with
        | |- ?L' _ -* exp (fun a => ?G' a _) = _ =>
             instantiate (1 := L') in (value of l');
             instantiate (1 := exp G') in (value of g')
        | |- ?L' _ -* ?G' _ = _ =>
             instantiate (1 := L') in (value of l');
             instantiate (1 := G') in (value of g')
        end;
        subst g' l';
        reflexivity
      | subst g' l'; rewrite H; clear H]
  end.

End RAMIF_Q.

Module RAMIF_Q'.
Section RAMIF_Q'.

Context {A : Type}.
Context {ND : NatDed A}.
Context {SL : SepLog A}.
Context {CoSL: CorableSepLog A}.

Lemma reduce: forall {B} g l p (g' l': B -> A),
  corable p ->
  (g |-- l * (allp (p --> (l' -* g')))) ->
  g |-- l * (exp (p && l') -* exp (p && g')).
Proof.
  intros.
  eapply derives_trans; [exact H0 |].
  apply sepcon_derives; [auto |].
  apply wand_sepcon_adjoint.
  rewrite exp_sepcon2.
  apply exp_left; intro x; apply (exp_right x).
  apply wand_sepcon_adjoint.
  apply (allp_left _ x).
  simpl.
  apply wand_sepcon_adjoint.
  rewrite corable_sepcon_andp1 by auto.
  apply andp_right; [apply andp_left1; auto |].
  rewrite <- corable_andp_sepcon1 by auto.
  apply wand_sepcon_adjoint.
  apply modus_ponens.
Qed.

Lemma solve: forall {B} g l p g' l' F,
  corable p ->
  (g |-- l * F) ->
  (forall x: B, (p x) && (F * l' x) |-- g' x) ->
  g |-- l * (allp (p --> (l' -* g'))).
Proof.
  intros.
  apply derives_trans with (l * F); auto.
  apply sepcon_derives; auto.
  apply allp_right; intro x.
  simpl.
  apply imp_andp_adjoint.
  apply wand_sepcon_adjoint.
  rewrite corable_andp_sepcon2 by auto.
  auto.
Qed.

Lemma weak_ramif_spec: forall {B} g l p (g' l': B -> A),
  (g |-- l * allp (p --> l' -* g')) -> g |-- l * TT.
Proof.
  intros.
  eapply derives_trans; [exact H |].
  apply sepcon_derives; auto.
  apply TT_right.
Qed.

Lemma plain_spec: forall {B} g l p g' l' (x: B),
  corable p ->
  (g |-- p x) ->
  (g |-- l * allp (p --> (l' -* g'))) ->
  g |-- l * (l' x -* g' x).
Proof.
  intros.
  rewrite (add_andp _ _ H1).
  rewrite (add_andp _ _ H0).
  rewrite andp_assoc; apply andp_left2.
  rewrite <- corable_sepcon_andp1 by auto.
  apply sepcon_derives; [auto |].
  rewrite andp_comm; apply imp_andp_adjoint.
  apply (allp_left _ x); apply derives_refl.
Qed.

Lemma trans: forall {B BG BL} g m l p pG pL g' mG' mL' l' (fG: B -> BG) (fL: B -> BL),
  corable p ->
  corable pL ->
  corable pG ->
  (g |-- m * allp (pG --> (mG' -* g'))) ->
  (m |-- l * allp (pL --> (l' -* mL'))) ->
  (forall b, p b |-- pL (fL b)) ->
  (forall b, p b && mL' (fL b) |-- pG (fG b) && mG' (fG b)) ->
  g |-- l * allp (p --> (Basics.compose l' fL -* Basics.compose g' fG)).
Proof.
  intros.
  apply solve with (allp (pL --> (l' -* mL')) * allp (pG --> (mG' -* g'))).
  + simpl; unfold Basics.compose.
    auto.
  + eapply derives_trans; [exact H2 |].
    eapply derives_trans; [apply sepcon_derives; [exact H3 | apply derives_refl] |].
    rewrite sepcon_assoc; auto.
  + intro b.
    unfold Basics.compose.
    rewrite <- !corable_andp_sepcon1 by auto.
    rewrite sepcon_assoc.
    apply wand_sepcon_adjoint.
    rewrite andp_comm; apply imp_andp_adjoint.
    apply (allp_left _ (fL b)); apply imp_andp_adjoint.
    apply wand_sepcon_adjoint.
    rewrite sepcon_comm, sepcon_assoc, sepcon_comm.
    apply wand_sepcon_adjoint.
    apply derives_trans with (pG (fG b) && mG' (fG b)).
    - apply derives_trans with (p b && mL' (fL b)); [| apply H5].
      rewrite corable_sepcon_andp2 by auto.
      apply andp_right; [apply andp_left1; auto |].
      rewrite <- corable_sepcon_andp1 by auto.
      rewrite sepcon_comm.
      apply wand_sepcon_adjoint.
      simpl; eapply derives_trans; [| apply modus_ponens].
      apply andp_derives; [apply H4 | apply derives_refl].
    - apply wand_sepcon_adjoint.
      rewrite sepcon_comm.
      apply wand_sepcon_adjoint.
      apply (allp_left _ (fG b)); simpl.
      apply wand_sepcon_adjoint.
      rewrite corable_sepcon_andp1, <- corable_andp_sepcon1 by auto.
      apply wand_sepcon_adjoint.
      apply modus_ponens.
Qed.

Lemma split: forall {B} g1 g2 l1 l2 (p g1' g2' l1' l2': B -> A),
  (forall x: B, corable (p x)) ->
  (g1 |-- l1 * allp (p --> (l1' -* g1'))) ->
  (g2 |-- l2 * allp (p --> (l2' -* g2'))) ->
  g1 * g2 |-- (l1 * l2) * allp (p --> (l1' * l2' -* g1' * g2')).
Proof.
  intros.
  apply solve with (allp (p --> (l1' -* g1')) * allp (p --> (l2' -* g2'))).
  + auto.
  + rewrite (sepcon_assoc l1), <- (sepcon_assoc l2), (sepcon_comm l2), (sepcon_assoc _ l2), <- (sepcon_assoc l1).
    apply sepcon_derives; auto.
  + intros x.
    change ((l1' * l2') x) with (l1' x * l2' x).
    rewrite <- (sepcon_assoc _ (l1' x)), (sepcon_assoc _ _ (l1' x)), (sepcon_comm _ (l1' x)), <- (sepcon_assoc _ (l1' x)), (sepcon_assoc _ _ (l2' x)).
    rewrite <- (andp_dup (p x)), andp_assoc.
    rewrite <- corable_sepcon_andp1, <- corable_andp_sepcon1 by auto.
    rewrite <- !corable_sepcon_andp1 by auto.
    apply sepcon_derives.
    - apply wand_sepcon_adjoint.
      apply (allp_left _ x).
      apply wand_sepcon_adjoint.
      rewrite corable_sepcon_andp1, <- corable_andp_sepcon1 by auto.
      (eapply derives_trans; [apply sepcon_derives; [simpl; intros; apply modus_ponens | apply derives_refl] |]).
      apply wand_sepcon_adjoint; apply derives_refl.
    - apply wand_sepcon_adjoint.
      apply (allp_left _ x).
      apply wand_sepcon_adjoint.
      rewrite corable_sepcon_andp1, <- corable_andp_sepcon1 by auto.
      (eapply derives_trans; [apply sepcon_derives; [simpl; intros; apply modus_ponens | apply derives_refl] |]).
      apply wand_sepcon_adjoint; apply derives_refl.
Qed.

(* Using split to prove frame will lead to a simpler proof. *)
(* But it requires a unitary separation logic.              *)
Lemma frame: forall {B} g l p g' l' F,
  (forall x: B, corable (p x)) ->
  (g |-- l * allp (p --> (l' -* g'))) ->
  g * F |-- l * allp (p --> (l' -* g' * Basics.const F)).
Proof.
  intros.
  apply solve with (allp (p --> (l' -* g')) * F).
  + auto.
  + rewrite <- sepcon_assoc.
    apply sepcon_derives; auto.
  + intros x; unfold Basics.const; simpl.
    rewrite <- !corable_andp_sepcon1 by auto.
    rewrite (sepcon_comm _ (l' x)), <- sepcon_assoc.
    apply sepcon_derives; [| auto].
    rewrite sepcon_comm; apply wand_sepcon_adjoint.
    rewrite andp_comm; apply imp_andp_adjoint; apply (allp_left _ x); apply imp_andp_adjoint.
    rewrite andp_comm; apply modus_ponens.
Qed.

Lemma frame_post: forall {B} g l (p g' l' F: B -> A),
  (forall x: B, corable (p x)) ->
  (g |-- l * allp (p --> (l' -* g'))) ->
  g |-- l * allp (p --> (l' * F -* g' * F)).
Proof.
  intros.
  apply solve with (allp (p --> (l' -* g'))).
  + auto.
  + auto.
  + intros x; simpl.
    rewrite <- !corable_andp_sepcon1 by auto.
    rewrite <- sepcon_assoc.
    apply sepcon_derives; [rewrite sepcon_comm | auto].
    rewrite sepcon_comm; apply wand_sepcon_adjoint.
    rewrite andp_comm; apply imp_andp_adjoint; apply (allp_left _ x); apply imp_andp_adjoint.
    rewrite andp_comm; apply modus_ponens.
Qed.

Lemma frame_pre: forall {B} g l (p g' l': B -> A) F,
  (forall x: B, corable (p x)) ->
  (g |-- l * allp (p --> (l' -* g'))) ->
  g * F |-- (l * F) * allp (p --> (l' -* g')).
Proof.
  intros.
  apply solve with (allp (p --> (l' -* g'))).
  + auto.
  + rewrite (sepcon_comm l F), sepcon_assoc, (sepcon_comm F).
    apply sepcon_derives; auto.
  + intros x; simpl.
    rewrite <- !corable_andp_sepcon1 by auto.
    apply wand_sepcon_adjoint.
    rewrite andp_comm; apply imp_andp_adjoint; apply (allp_left _ x); apply imp_andp_adjoint.
    rewrite andp_comm; apply modus_ponens.
Qed.

Lemma exp_right: forall {T B} (a: B -> T) p g l (g': T -> B -> A) (l': B -> A),
  corable p ->
  (g |-- l * allp (p --> (l' -* (fun b => g' (a b) b)))) ->
  g |-- l * allp (p --> (l' -* exp g')).
Proof.
  intros.
  apply solve with (allp (p --> (l' -* (fun b => g' (a b) b)))); auto.
  intros.
  rewrite <- corable_sepcon_andp1 by auto.
  apply wand_sepcon_adjoint.
  apply (allp_left _ x).
  simpl.
  apply wand_sepcon_adjoint.
  rewrite corable_sepcon_andp1 by auto.
  rewrite <- corable_andp_sepcon1 by auto.
  eapply derives_trans; [apply sepcon_derives; [apply modus_ponens | apply derives_refl] |].
  apply wand_sepcon_adjoint.
  apply wand_derives; auto.
  apply (exp_right (a x)); auto.
Qed.

End RAMIF_Q'.

Ltac formalize :=
  match goal with
  | |- @derives ?Pred _ ?g (?l * @allp ?Pred _ ?T ?Func) =>
      let p := fresh "p" in evar (p: T -> Pred);
      let g' := fresh "g'" in evar (g': T -> Pred);
      let l' := fresh "l'" in evar (l': T -> Pred);
      let x := fresh "x" in
      let H := fresh "H" in
      assert (Func = p --> (l' -* g'));
      [
        extensionality x; cbv beta;
        match goal with
        | |- ?P --> (?L' -* exp ?G') = _ =>
             super_pattern P x; super_pattern L' x; super_pattern_in_func G' x
        | |- ?P --> (?L' -* ?G') = _ =>
             super_pattern P x; super_pattern L' x; super_pattern G' x
        end;
        match goal with
        | |- ?P _ --> (?L' _ -* exp (fun a => ?G' a _)) = _ =>
             instantiate (1 := P) in (value of p);
             instantiate (1 := L') in (value of l');
             instantiate (1 := exp G') in (value of g')
        | |- ?P _ --> (?L' _ -* ?G' _) = _ =>
             instantiate (1 := P) in (value of p);
             instantiate (1 := L') in (value of l');
             instantiate (1 := G') in (value of g')
        end;
        subst p g' l';
        reflexivity
      | subst p g' l'; rewrite H; clear H]
  end.

End RAMIF_Q'.


Definition ext_eq {A B} (f g : A -> B) := forall a, f a = g a.

Definition task :=
  forall A B (f g : A -> B), ext_eq f g -> ext_eq g f.


(*
  vim: filetype=coq
*)
(*
Copyright (C) 2016-2018 Philip H. Smith

This program 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.

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

Require Import Way.Tactics.

Require Export Way.Atom.

(* Preterms are terms that may have dangling bound variables.

Variables are managed in the locally nameless style. This means that free and bound
variables are syntactically distinct.  Free variables are identified by names (atoms),
while bound variables are given de Bruijn indices.  This eliminates the need for alpha
conversion, but opens the possibility that bound variable indices may be invalid (that is,
may refer to abstractions which do not exist).  "Local closure" is the property that all
such indices are valid.
*)
Inductive preterm : Set :=

(* A named variable appearing in the term's context *)
| free_variable : atom -> preterm

(* A nameless variable (de Bruijn index)

de Bruijn indices appearing in binder annotations (the argument types of lambdas and
products) do not range over the binder they are included in.  Indices appearing in the
bodies of those terms do.

Thus the polymorphic identity, informally (fun (x : Set) (y : x) => y) becomes
(abs (type 0) (abs (bvar 0) (bvar 0))).  Notice how the two occurrences of (bvar 0) refer
to different bound variables even though they appear within the same abs, due to their
placement.
*)
| bound_variable : nat -> preterm

(* Introduce a dependent product *)
| product : preterm -> preterm -> preterm

(* Introduce a lambda *)
| abstraction : preterm -> preterm -> preterm

(* Eliminate an abstraction *)
| application : preterm -> preterm -> preterm

(* Introduce a sort (type of types)

Non-type terms have types whose type is type 0. The type of type 0 is type 1, and so on.
This is the "stratified" presentation avoiding Girard's paradox.
*)
| type : nat -> preterm.

Module Aliases.

(* It seems these simple rewrites cannot be put into notation scopes. *)
Notation fvar := free_variable.
Notation bvar := bound_variable.
Notation prod := product.
Notation abs := abstraction.
Notation app := application.
Notation type := Preterm.type.

End Aliases.

Module Examples.

Import Aliases.

(* Fudge the annotations; omega isn't typable anyway *)
Example omega :=
  (app
    (abs (type 0) (app (bvar 0) (bvar 0)))
    (abs (type 0) (app (bvar 0) (bvar 0)))).

Example polymorphic_identity := (abs (type 0) (abs (bvar 0) (bvar 0))).

End Examples.


(** * Verification of imperative programs *)

(**
Verifiable C
- C light intermediate language
  • Dialect of C with side effects
    factored out of expressions;
  • No casting between integers
    and pointers;
  • No goto statements;
  • Only structured switch statements
    (no Duff’s device)
- Program logic for reasoning about
  the functional correctness of C programs
  (higher-order separation logic)
*)

(**
Verifiable C is foundationally sound:
all proven properties of C programs
are preserved by translation down to the
assembly code.

The program logic is proved sound with
respect to the semantics of CompCert C.

And the C compiler is proved correct with
respect to those same semantics.

This chain of proofs from top to bottom,
connected in Coq at specification
interfaces, is part of the Verified
Software Toolchain (VST).
*)

(**
Real-world verifications with VST:
- "Verified correctness and security of
   OpenSSL HMAC" - Beringer, Petcher, KQ, Appel (2015)
- "Verification of a cryptographic
   primitive: SHA-256" - Appel(2015)

See "Position paper:
     the Science of Deep Specification" -
     A.W. Appel, L. Beringer, A. Chlipala,
     B.C. Pierce, Z. Shao, S. Weirich,
     S. Zdancewic(2017)
*)

(**
How to install VST:
- Make sure you have Coq 8.10
- opam install coq-compcert.3.6
- git clone https://github.com/PrincetonUniversity/VST
- cd VST
- make IGNORECOQVERSION=true -j3

See also "Verifiable C" by A.W. Appel
*)

(** Let's consider a concrete example:
    sumarray.c program, this example
    is a slightly adopted version of
    VST's sumarray example described
    in "Verifiable C" by A.W. Appel,
    version 2.4 *)

(**
First, we need to embed it into Coq
using CompCert's [clightgen] tool:

clightgen -normalize sumarray.c

[clightgen] translates C into
abstract syntax trees (ASTs) of Clight:
• Factors out function calls and
  assignments from inside subexpressions;
• Factors [&&] and [||] operators into
  [if] statements;
• When the [-normalize] flag is used,
  factors each memory dereference into
  a top level expression, i.e.
    x=a[b[i]];
  becomes
    t=b[i]; x=a[t].

This is needed because the program logic
works only on a restricted subset of
the language.

To see the result of this translation
take a look at sumarray.v file.
But you don't have to do it usually.
 *)

(** some automation *)
From Coq Require Import Lia.

(** The directory you installed VST into *)
Add LoadPath "~/prj/coq/vst/".

(** Import the Verifiable C system *)
From VST Require Import floyd.proofauto.

(** Import the AST of sumarray C program *)
From VST Require Import sumarray.

(** The next few line is "boilerplate",
    always required after importing an AST
 *)
Instance CompSpecs : compspecs.
  make_compspecs prog. Defined.
Definition Vprog : varspecs.
  mk_varspecs prog. Defined.

(** Functional spec of this program:
    Notice that it is independent of
    sumarray.v file
 *)
Definition sum_Z : list Z -> Z :=
  fold_right Z.add 0.

Lemma sum_Z_app a b :
  sum_Z (a ++ b) =  sum_Z a + sum_Z b.
Proof.
  induction a; simpl; lia.
(** Vanilla tactics!
- [induction] == [elim]
- [simpl] == [move=> /=]
- [lia] -- linear integral arithmetic
           solver
 *)
Qed.

(** Beginning of the API spec
    for the sumarray.c program.
    Funspecs correspond to
    function prototypes.
 *)
Definition sumarray_spec :
  ident * funspec :=

DECLARE _sumarray
 WITH a: val, sh : share,
      contents : list Z, size: Z
 PRE [ _a OF (tptr tuint), _n OF tint ]
   PROP (
     (** [PROP] desribes propositions
         independent of state *)
     readable_share sh;
     0 <= size <= Int.max_signed;
     Forall
      (fun x => 0 <= x <= Int.max_unsigned)
      contents
   )
   LOCAL (
     (** variable bindings of type
         [localdef]
         relate C local variables to
         Coq values *)
     temp _a a;
     temp _n (Vint (Int.repr size))
   )
   SEP (
     (** spatial assertions in
         separation logic *)
     data_at
       sh
       (tarray tuint size)
       (map Vint (map Int.repr contents))
       a
     (** This says that at address [a]
         there is an array of type
         unsigned int [size] with
         access-permission [sh] and the
         contents is a list related to
         [contents] *)
   )
 POST [ tuint ]
   PROP ()
   LOCAL (
     temp
       ret_temp
       (Vint (Int.repr (sum_Z contents)))
   )
   SEP (
     data_at
       sh
       (tarray tuint size)
       (map Vint (map Int.repr contents))
       a
   ).

(** Note:
It would also be reasonable to let
[contents] have type [list int].
Then the [Forall] would not be needed
in the [PROP] part of [PRE].
*)

(** The precondition of "int main(void){}"
    always looks like this. *)
Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog tt nil gv
  POST [ tint ]
     PROP()
     LOCAL (
       temp ret_temp
            (Vint (Int.repr (1+2+3+4)))
     )
     SEP(
       (** trivially true
           spatial predicate *)
       TT
     ).

(** Packaging the API spec all together. *)
Definition Gprog : funspecs :=
  (** [ltac] quotation *)
  ltac:(
    with_library
      prog [sumarray_spec; main_spec]
  ).

(** Proof that [f_sumarray],
    the body of the "sumarray()" function,
    satisfies [sumarray_spec],
    in the global context ([Vprog],[Gprog])
 *)
Lemma body_sumarray:
  semax_body (** Hoare triple of
                 the function body *)
    Vprog (** global variables context *)
    Gprog (** global functions context *)
    f_sumarray
    sumarray_spec.
Proof.
(** Always do this at the beginning of
    a semax_body proof *)
start_function.

(** The next two lines do forward
    symbolic execution through
    the first two executable statements
    of the function body *)
forward.  (* i = 0; *)
forward.  (* s = 0; *)
(** To do symbolic execution through
    a [while] loop, we must provide
    a loop invariant, so we use
    [forward_while] with the invariant
    as an argument .*)
forward_while
 (EX i: Z,
   PROP  (0 <= i <= size)
   LOCAL (
    temp _a a;
    temp _i (Vint (Int.repr i));
    temp _n (Vint (Int.repr size));
    temp _s (Vint (Int.repr
           (sum_Z (sublist 0 i contents))))
   )
   SEP (
     data_at
       sh
       (tarray tuint size)
       (map Vint (map Int.repr contents)) a
   )
 ).

(** [forward_while] leaves four subgoals *)

- (** Current precondition implies
      loop invariant *)
(* Instantiate the existential
   on the right-side of |-- *)
Exists 0.
(* Simplify this entailment *)
entailer!.
- (** loop invariant implies
      typechecking condition *)
entailer!.
- (** Prove postcondition of loop body
      implies loop invariant *)
Fail forward.
assert_PROP (Zlength contents = size). {
  entailer!. now rewrite !Zlength_map.
}
forward. (* x = a[i] *)
forward. (* s += x; *)
forward. (* i++; *)
(** Now we have reached the end of
    the loop body, and it's time to prove
    that the _current precondition_
    entails the loop invariant. *)
 Exists (i+1).
 entailer!.
 f_equal.
 rewrite (sublist_split 0 i (i+1)) by lia.
 rewrite sum_Z_app, (sublist_one i) by lia.
 now simpl; rewrite Z.add_0_r.
- (** After the loop *)
forward.  (* return s; *)
(* postcondition of the function body
   entails the postcondition of funspec *)
entailer!.
autorewrite with sublist in *.
now autorewrite with sublist.
Qed.

(** Contents of the extern global
    initialized array "_four" *)
Definition four_contents := [1; 2; 3; 4].

Lemma body_main:
  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
forward_call (*  s = sumarray(four,4); *)
  (gv _four, Ews,four_contents,4).
split3. auto. computable.
repeat constructor; computable.
forward. (* return s; *)
Qed.

Existing Instance NullExtension.Espec.

Lemma prog_correct:
  semax_prog prog tt Vprog Gprog.
Proof.
  prove_semax_prog.
  semax_func_cons body_sumarray.
  semax_func_cons body_main.
Qed.

(** ==================================== *)

(**
What have we covered so far:
- The SSReflect proof language
- Elements of intuitionistic logic
- Curry-Howard correspondence
- Patterns of proofs by induction
- A bit of proof automation: lia (omega)
- The building blocks of the Mathcomp library:
  • Boolean reflection
  • Canonical Structures
  • Coercions, Notations
  • Phantom types
- Subtyping
- Commonly used axioms:
  • Axiom K
  • Proof irrelevance
  • Functional extensionality
- Totality
- Prop vs Type
- Hinted at Universe Polymorphism
- Inductive predicates
- A bit of tooling:
  • Program, Function builtin plugins
  • Equations plugin
  • QuickChick plugin
  • Typing Flags plugin
- Introduction to specification and verification of
  functional algorithms
- A survey of approaches to verifying of
  imperative heap manipulating programs
- Verification of C programs using VST
 *)

(** ==================================== *)

(**
What we did NOT cover in this course:
- We did not address logic and Calculus of Inductive
  Constructions formally
- Vanilla Coq tactics
- Coq Standard Library
- Ltac hacking and proof automation
  • Ltac2, Mtac/Mtac2, Rtac, coq-elpi
  • CoqHammer, SMTcoq
- Advanced dependently typed programming
- Module system
- Typeclasses
- Generalized rewriting
- SProp (proof irrelevant propositions)
  see "Definitional Proof-Irrelevance
  without K" by G. Gilbert et al.(2019)
  • Definition irrelevance
                 (A:SProp) (P:A -> Prop)
                 (x:A) (v:P x) (y:A)
                 : P y
     := v.
- Native binary integers
- More tooling:
  • Handling of projects (_CoqProject & coq_makefile)
  • coqdoc, coqdep, coqchk
  • SerAPI (Coq Protocol Playground with Se(xp)rialization of Internal Structures)
- Ecosystem in the large
 *)

(** ==================================== *)

(** Further directions to explore
- For mathematically inclined --
  explore the Mathcomp library further,
  read the associated papers
  (https://github.com/math-comp/math-comp.github.io)
- Type theoretic foundations of Coq
  (to track recent developments see papers
   by Sozeau, Tabareau, Gilbert, Pedrot)
- (Concurrent) separation logic
- PL (meta-)theory
- Hardware verification:
  Kami by A. Chlipala
- A great review of the area: the deep
  spec paper mentioned above
- Exercises/competition:
  • https://www21.in.tum.de/~wimmers/proofground/
  • https://competition.isabelle.systems/competitions
  • https://www.codewars.com [Coq tag]
- Books:
  • The manual: https://coq.inria.fr/distrib/current/refman/
  • Coq'art by Casteran and Bertot
    (a great reference)
  • Software Foundation series
    (PL theory mostly)
  • Programs and Proofs - I. Sergey
    (ssreflect, HTT)
  • Mathcomp book
    (architecture of Mathcomp)
*)


Require Export prosa.model.schedule.limited_preemptive.
Require Export prosa.analysis.definitions.job_properties.
Require Export prosa.analysis.facts.behavior.all.
Require Export prosa.analysis.facts.model.sequential.
Require Export prosa.analysis.facts.model.ideal_schedule.

(** Throughout this file, we assume the job model with limited
    preemption points. *)
Require Import prosa.model.preemption.limited_preemptive.

(** * Platform for Models with Limited Preemptions *)
(** In this section, we prove that instantiation of predicate
    [job_preemptable] to the model with limited preemptions
    indeed defines a valid preemption model. *)
Section ModelWithLimitedPreemptions.

  (** Consider any type of tasks ... *)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.

  (**  ... and any type of jobs associated with these tasks. *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** In addition, assume the existence of a function that maps a job
      to the sequence of its preemption points. *)
  Context `{JobPreemptionPoints Job}.

  (** Consider any arrival sequence. *)
  Variable arr_seq : arrival_sequence Job.

  (** Next, consider any limited ideal uni-processor schedule of this arrival sequence ... *)
  Variable sched : schedule (ideal.processor_state Job).
  Hypothesis H_schedule_respects_preemption_model:
    schedule_respects_preemption_model arr_seq sched.

  (** ...where jobs do not execute after their completion. *)
  Hypothesis H_completed_jobs_dont_execute: completed_jobs_dont_execute sched.

  (** Next, we assume that preemption points are defined by the
      job-level model with limited preemptions. *)
  Hypothesis H_valid_limited_preemptions_job_model:
    valid_limited_preemptions_job_model arr_seq.

  (** First, we prove a few auxiliary lemmas. *)
  Section AuxiliaryLemmas.

    (** Consider a job j. *)
    Variable j : Job.
    Hypothesis H_j_arrives : arrives_in arr_seq j.

    (** Recall that 0 is a preemption point. *)
    Remark zero_in_preemption_points: 0 \in job_preemption_points j.
    Proof. by apply H_valid_limited_preemptions_job_model. Qed.

    (** Using the fact that [job_preemption_points] is a
        non-decreasing sequence, we prove that the first element of
        [job_preemption_points] is 0. *)
    Lemma zero_is_first_element: first0 (job_preemption_points j) = 0.
    Proof.
      have F := zero_in_preemption_points.
      destruct H_valid_limited_preemptions_job_model as [_ [_ C]]; specialize (C j H_j_arrives).
        by apply nondec_seq_zero_first.
    Qed.

    (** We prove that the list of preemption points is not empty. *)
    Lemma list_of_preemption_point_is_not_empty:
      0 < size (job_preemption_points j).
    Proof.
      move: H_valid_limited_preemptions_job_model => [BEG [END _]].
      apply/negPn/negP; rewrite -eqn0Ngt; intros CONTR; rewrite size_eq0 in CONTR.
      specialize (BEG j H_j_arrives).
        by rewrite /beginning_of_execution_in_preemption_points (eqbool_to_eqprop CONTR) in BEG.
    Qed.

    (** Next, we prove that the cost of a job is a preemption point. *)
    Lemma job_cost_in_nonpreemptive_points: job_cost j \in job_preemption_points j.
    Proof.
      move: H_valid_limited_preemptions_job_model => [BEG [END _]].
      move: (END _ H_j_arrives) => EQ.
      rewrite -EQ; clear EQ.
      rewrite /last0 -nth_last.
      apply/(nthP 0).
      exists ((size (job_preemption_points j)).-1); last by done.
      rewrite -(leq_add2r 1) !addn1 prednK //.
        by apply list_of_preemption_point_is_not_empty.
    Qed.

    (** As a corollary, we prove that the sequence of non-preemptive
        points of a job with positive cost contains at least 2
        points. *)
    Corollary number_of_preemption_points_at_least_two:
      job_cost_positive j ->
      2 <= size (job_preemption_points j).
    Proof.
      intros POS.
      move: H_valid_limited_preemptions_job_model => [BEG [END _]].
      have EQ: 2 = size [::0; job_cost j]; first by done.
      rewrite EQ; clear EQ.
      apply subseq_leq_size.
      rewrite !cons_uniq.
      { apply/andP; split.
        rewrite in_cons negb_or; apply/andP; split; last by done.
        rewrite neq_ltn; apply/orP; left; eauto 2.
        apply/andP; split; by done. }
      intros t EQ; move: EQ; rewrite !in_cons.
      move => /orP [/eqP EQ| /orP [/eqP EQ|EQ]]; last by done.
      - by rewrite EQ; apply zero_in_preemption_points.
      - by rewrite EQ; apply job_cost_in_nonpreemptive_points.
    Qed.

    (** Next we prove that "anti-density" property (from
        [preemption.util] file) holds for [job_preemption_point j]. *)
    Lemma antidensity_of_preemption_points:
      forall (ρ : work),
        ρ <= job_cost j ->
        ~~ (ρ \in job_preemption_points j) ->
        first0 (job_preemption_points j) <= ρ < last0 (job_preemption_points j).
    Proof.
      intros ρ LE NotIN.
      move: H_valid_limited_preemptions_job_model => [BEG [END NDEC]].
      apply/andP; split.
      - by rewrite zero_is_first_element.
      - rewrite END; last by done.
        rewrite ltn_neqAle; apply/andP; split; last by done.
        apply/negP; intros CONTR; move: CONTR => /eqP CONTR.
        rewrite CONTR in NotIN.
        move: NotIN => /negP NIN; apply: NIN.
          by apply job_cost_in_nonpreemptive_points.
    Qed.

    (** We also prove that any work that doesn't belong to
        preemption points of job j is placed strictly between two
        neighboring preemption points. *)
    Lemma work_belongs_to_some_nonpreemptive_segment:
      forall (ρ : work),
        ρ <= job_cost j ->
        ~~ (ρ \in job_preemption_points j)->
        exists n,
          n.+1 < size (job_preemption_points j) /\
          nth 0 (job_preemption_points j) n < ρ < nth 0 (job_preemption_points j) n.+1.
    Proof.
      intros ρ LE NotIN.
      case: (posnP (job_cost j)) => [ZERO|POS].
      { exfalso; move: NotIN => /negP NIN; apply: NIN.
        move: LE. rewrite ZERO leqn0; move => /eqP ->.
          by apply zero_in_preemption_points. }
      move: (belonging_to_segment_of_seq_is_total
               (job_preemption_points j) ρ (number_of_preemption_points_at_least_two POS)
               (antidensity_of_preemption_points _ LE NotIN)) => [n [SIZE2 /andP [N1 N2]]].
      exists n; split; first by done.
      apply/andP; split; last by done.
      move: N1; rewrite leq_eqVlt; move => /orP [/eqP EQ | G]; last by done.
      exfalso.
      move: NotIN => /negP CONTR; apply: CONTR.
      rewrite -EQ; clear EQ.
      rewrite mem_nth //.
        by apply ltnW.
    Qed.

    (** Recall that file [job.parameters] also defines notion of
        preemption points.  And note that
        [job.parameter.job_preemption_points] cannot have a
        duplicating preemption points. Therefore, we need additional
        lemmas to relate [job.parameter.job_preemption_points] and
        [limited.job_preemption_points]]. *)

    (** First we show that the length of the last non-preemptive
        segment of [job.parameter.job_preemption_points] is equal to
        the length of the last non-empty non-preemptive segment of
        [limited.job_preemption_points]. *)
    Lemma job_parameters_last_np_to_job_limited:
        last0 (distances (parameter.job_preemption_points j)) =
        last0 (filter (fun x => 0 < x) (distances (job_preemption_points j))).
    Proof.
      destruct H_valid_limited_preemptions_job_model as [A1 [A2 A3]].
      unfold parameter.job_preemption_points, job_preemptable, limited_preemptions_model.
      intros; rewrite distances_iota_filtered; eauto.
      rewrite -A2 //.
        by intros; apply last_is_max_in_nondecreasing_seq; eauto 2.
    Qed.

    (** Next we show that the length of the max non-preemptive
        segment of [job.parameter.job_preemption_points] is equal to
        the length of the max non-preemptive segment of
        [limited.job_preemption_points]. *)
    Lemma job_parameters_max_np_to_job_limited:
      max0 (distances (parameter.job_preemption_points j)) =
      max0 (distances (job_preemption_points j)).
    Proof.
      destruct H_valid_limited_preemptions_job_model as [A1 [A2 A3]].
      unfold parameter.job_preemption_points, job_preemptable, limited_preemptions_model.
      intros; rewrite distances_iota_filtered; eauto 2.
      rewrite max0_rem0 //.
      rewrite -A2 //.
        by intros; apply last_is_max_in_nondecreasing_seq; eauto 2.
    Qed.

  End AuxiliaryLemmas.

  (** We prove that the [fixed_preemption_point_model] function
      defines a valid preemption model. *)
  Lemma valid_fixed_preemption_points_model_lemma:
    valid_preemption_model arr_seq sched.
  Proof.
    intros j ARR; repeat split.
    { by apply zero_in_preemption_points. }
    { by apply job_cost_in_nonpreemptive_points. }
    { by move => t NPP; apply H_schedule_respects_preemption_model. }
    { intros t NSCHED SCHED.
      have SERV: service sched j t = service sched j t.+1.
      { rewrite -[service sched j t]addn0 /service /service_during; apply/eqP.
        rewrite big_nat_recr //=.
        rewrite eqn_add2l eq_sym.
        rewrite scheduled_at_def in NSCHED.
          by rewrite eqb0. }
      rewrite -[job_preemptable _ _]Bool.negb_involutive.
      apply/negP; intros CONTR.
      move: NSCHED => /negP NSCHED; apply: NSCHED.
      apply H_schedule_respects_preemption_model; first by done.
        by rewrite SERV.
    }
  Qed.

End ModelWithLimitedPreemptions.
Hint Resolve valid_fixed_preemption_points_model_lemma : basic_facts.