Welcome to Coq 8.4pl4 (November 2015)

Coq < Theorem mult_0_plus' : forall n m : nat, (0 + n) * m = n * m.
1 subgoal

  ============================
   forall n m : nat, (0 + n) * m = n * m

mult_0_plus' < Proof.
1 subgoal

  ============================
   forall n m : nat, (0 + n) * m = n * m

mult_0_plus' < info_auto.
(* info auto : *)
 intro.
 intro.
 apply @eq_refl.
No more subgoals.

mult_0_plus' < Qed.
info_auto.

mult_0_plus' is defined


Require Export Structure.

Module Slice.

Structure obj (C: Category) (c: C) := Obj {
  dom: C;
  arr: dom ~> c;
}.

Arguments dom {C c} o.
Arguments arr {C c} o.

Structure hom {C: Category} {c: C} (f g: obj C c) := Hom {
  map: dom f ~> dom g;
  comm: arr g ∘ map = arr f;
}.

Arguments Hom {C c f g} map comm.
Arguments map {C c f g} _.
Arguments comm {C c f g} _.
Coercion map: hom >-> Categories.hom.

Lemma obj_eq {C: Category} {c: C} {f g: obj C c}: f = g <-> dom f = dom g /\ (forall e: dom f = dom g, arr f = arr g ∘ eq_iso e).
Proof.
  split.
  + intros H.
    subst g.
    repeat split.
    intros e.
    rewrite eq_iso_refl.
    symmetry.
    apply comp_id_r.
  + destruct f as [x f], g as [x' g].
    simpl.
    intros [Hx H].
    subst x'.
    f_equal.
    rewrite <- comp_id_r.
    exact (H eq_refl).
Qed.

Lemma hom_eq {C: Category} {c: C} {f g: obj C c} (a b: hom f g): a = b <-> map a = map b.
Proof.
  split.
  intros H.
  now subst b.
  destruct a as [a Ha], b as [b Hb].
  simpl.
  intros H.
  subst b.
  f_equal.
  apply proof_irrelevance.
Qed.

Program Definition cat_mixin (C: Category) (c: C) := Category.Mixin (obj C c) hom
  (fun f => {|
    map := id (dom f);
    comm := comp_id_r (arr f);
  |})
  (fun f g h a b => {|
    map := a ∘ b;
    comm := eq_trans (comp_assoc _ _ _) (eq_trans (f_equal (fun f => f ∘ _) (comm a)) (comm b));
  |})
  _ _ _.
Next Obligation.
  apply hom_eq; simpl.
  apply comp_assoc.
Qed.
Next Obligation.
  apply hom_eq; simpl.
  apply comp_id_l.
Qed.
Next Obligation.
  apply hom_eq; simpl.
  apply comp_id_r.
Qed.

Canonical cat (C: Category) (c: C): Category :=
  Category.Pack (obj C c) (cat_mixin C c).

Program Canonical Dom (C: Category) (c: C): cat C c ~> C := {|
  fobj := dom;
  fmap := @map C c;
|}.

Definition img {C: Category} {x y: C} (f: x ~> y) (p: obj C x) := {|
  dom := dom p;
  arr := f ∘ arr p;
|}.

Program Definition img_map {C: Category} {x y: C} (f: x ~> y) {p q: obj C x} (g: p ~> q): img f p ~> img f q := {|
  map := map g;
|}.
Next Obligation.
  rewrite <- comp_assoc.
  f_equal.
  apply comm.
Qed.

Program Canonical Img {C: Category} {x y: C} (f: x ~> y): Functor (cat C x) (cat C y) := {|
  fobj := img f;
  fmap := @img_map C x y f;
|}.
Next Obligation.
  now apply hom_eq.
Qed.
Next Obligation.
  now apply hom_eq.
Qed.

Program Definition preimg {C: PullCategory} {x y: C} (f: y ~> x) (p: obj C x): obj C y := {|
  dom := Pull f (arr p);
  arr := pull1 f (arr p);
|}.

Program Definition preimg_map {C: PullCategory} {x y: C} (f: y ~> x) {p q: obj C x} (g: p ~> q): preimg f p ~> preimg f q := {|
  map := pull_med f (arr q) (pull1 f (arr p)) (map g ∘ pull2 f (arr p)) _;
|}.
Next Obligation.
  rewrite pull_comm, comp_assoc.
  f_equal.
  symmetry.
  apply comm.
Qed.
Next Obligation.
  apply pull_med1.
Qed.

Program Canonical Preimg {C: PullCategory} {x y: C} (f: y ~> x): Functor (cat C x) (cat C y) := {|
  fobj := preimg f;
  fmap := @preimg_map C x y f;
|}.
Next Obligation.
  apply hom_eq; simpl.
  apply pull_med_unique.
  2: rewrite comp_id_l.
  all: apply comp_id_r.
Qed.
Next Obligation.
  apply hom_eq; simpl.
  apply pull_med_unique.
  all: rewrite comp_assoc.
  rewrite pull_med1.
  apply pull_med1.
  rewrite pull_med2.
  rewrite <- !comp_assoc.
  f_equal.
  apply pull_med2.
Qed.

Program Definition img_unit {C: PullCategory} {x y: C} (f: x ~> y) (p: obj C x): p ~> preimg f (img f p) := {|
  map := pull_med f (f ∘ arr p) (arr p) (id (dom p)) _;
|}.
Next Obligation.
  symmetry.
  apply comp_id_r.
Qed.
Next Obligation.
  apply pull_med1.
Qed.

Program Canonical imgU {C: PullCategory} {x y: C} (f: x ~> y): id (cat C x) ~> Preimg f ∘ Img f := {|
  transform := img_unit f;
|}.
Next Obligation.
  rename x0 into p, y0 into q, f0 into g.
  apply hom_eq; simpl.
  transitivity (pull_med f (f ∘ arr q) (arr q ∘ g) g (comp_assoc f (arr q) g)).
  symmetry.
  all: apply pull_med_unique.
  all: rewrite !comp_assoc.
  2: rewrite <- comp_id_l.
  1, 2: f_equal.
  apply pull_med1.
  apply pull_med2.
  rewrite !pull_med1.
  symmetry.
  apply comm.
  rewrite pull_med2.
  rewrite <- comp_assoc, <- comp_id_r.
  f_equal.
  apply pull_med2.
Qed.

Program Definition img_counit {C: PullCategory} {x y: C} (f: x ~> y) (p: obj C y): img f (preimg f p) ~> p := {|
  map := pull2 f (arr p);
|}.
Next Obligation.
  symmetry.
  apply pull_comm.
Qed.

Program Canonical imgCU {C: PullCategory} {x y: C} (f: x ~> y): Img f ∘ Preimg f ~> id (cat C y) := {|
  transform := img_counit f;
|}.
Next Obligation.
  rename x0 into p, y0 into q, f0 into g.
  apply hom_eq; simpl.
  apply pull_med2.
Qed.

Lemma img_adjoint {C: PullCategory} {x y: C} (f: x ~> y): adjoint_by (Img f) (Preimg f) (imgU f) (imgCU f).
Proof.
  apply adjoint_by_alt.
  split.
  + intros p.
    apply hom_eq; simpl.
    apply pull_med2.
  + intros p.
    apply hom_eq; simpl.
    transitivity (pull_med f (arr p) (pull1 f (arr p)) (pull2 f (arr p)) (pull_comm f (arr p))).
    symmetry.
    all: apply pull_med_unique.
    3, 4: apply comp_id_r.
    all: rewrite comp_assoc.
    rewrite pull_med1.
    apply pull_med1.
    rewrite pull_med2.
    rewrite <- comp_assoc.
    rewrite pull_med2.
    apply comp_id_r.
Qed.

End Slice.

Canonical Slice.cat.
Canonical Slice.Dom.
Canonical Slice.Img.
Canonical Slice.Preimg.
Canonical Slice.imgU.
Canonical Slice.imgCU.
Coercion Slice.map: Slice.hom >-> hom.
Notation Slice := Slice.cat.
Infix "/" := Slice.

Module Coslice.

Structure obj (C: Category) (c: C) := Obj {
  cod: C;
  arr: c ~> cod;
}.

Arguments cod {C c} o.
Arguments arr {C c} o.

Structure hom {C: Category} {c: C} (f g: obj C c) := Hom {
  map: cod f ~> cod g;
  comm: map ∘ arr f = arr g;
}.

Arguments Hom {C c f g} map comm.
Arguments map {C c f g} _.
Arguments comm {C c f g} _.
Coercion map: hom >-> Categories.hom.

Lemma obj_eq {C: Category} {c: C} {f g: obj C c}: f = g <-> cod f = cod g /\ (forall e: cod f = cod g, eq_iso e ∘ arr f = arr g).
Proof.
  split.
  + intros H.
    subst g.
    repeat split.
    intros e.
    rewrite eq_iso_refl.
    apply comp_id_l.
  + destruct f as [x f], g as [x' g].
    simpl.
    intros [Hx H].
    subst x'.
    f_equal.
    rewrite <- (comp_id_l f).
    exact (H eq_refl).
Qed.

Lemma hom_eq {C: Category} {c: C} {f g: obj C c} (a b: hom f g): a = b <-> map a = map b.
Proof.
  split.
  intros H.
  now subst b.
  destruct a as [a Ha], b as [b Hb].
  simpl.
  intros H.
  subst b.
  f_equal.
  apply proof_irrelevance.
Qed.

Program Definition cat_mixin (C: Category) (c: C) := Category.Mixin (obj C c) hom
  (fun f => {|
    map := id (cod f);
    comm := comp_id_l (arr f);
  |})
  (fun f g h a b => {|
    map := a ∘ b;
    comm := eq_trans (eq_sym (comp_assoc _ _ _)) (eq_trans (f_equal (fun f => _ ∘ f) (comm b)) (comm a));
  |})
  _ _ _.
Next Obligation.
  apply hom_eq; simpl.
  apply comp_assoc.
Qed.
Next Obligation.
  apply hom_eq; simpl.
  apply comp_id_l.
Qed.
Next Obligation.
  apply hom_eq; simpl.
  apply comp_id_r.
Qed.

Canonical cat (C: Category) (c: C): Category :=
  Category.Pack (obj C c) (cat_mixin C c).

Program Canonical Cod (C: Category) (c: C): cat C c ~> C := {|
  fobj := cod;
  fmap := @map C c;
|}.

Definition preimg {C: Category} {x y: C} (f: y ~> x) (p: obj C x) := {|
  cod := cod p;
  arr := arr p ∘ f;
|}.

Program Definition preimg_map {C: Category} {x y: C} (f: y ~> x) {p q: obj C x} (g: p ~> q): preimg f p ~> preimg f q := {|
  map := map g;
|}.
Next Obligation.
  rewrite comp_assoc.
  f_equal.
  apply comm.
Qed.

Program Canonical Preimg {C: Category} {x y: C} (f: y ~> x): Functor (cat C x) (cat C y) := {|
  fobj := preimg f;
  fmap := @preimg_map C x y f;
|}.
Next Obligation.
  now apply hom_eq.
Qed.
Next Obligation.
  now apply hom_eq.
Qed.

End Coslice.

Canonical Coslice.cat.
Canonical Coslice.Cod.
Canonical Coslice.Preimg.
Coercion Coslice.map: Coslice.hom >-> hom.
Notation Coslice := Coslice.cat.
Infix "\" := Coslice (at level 40, left associativity).


(* ***********************************************************************)
(*                                                                       *)
(*   Synchronously executed Interpreted Time Petri Nets (SITPNs)         *)
(*                                                                       *)
(*                                                                       *)
(*   Copyright Université de Montpellier, contributor(s): Vincent        *)
(*   Iampietro, David Andreu, David Delahaye (May 2020)                  *)
(*                                                                       *)
(*   This software is governed by the CeCILL-C license under French law  *)
(*   and abiding by the rules of distribution of free software.  You can *)
(*   use, modify and/ or redistribute the software under the terms of    *)
(*   the CeCILL-C license as circulated by CEA, CNRS and INRIA at the    *)
(*   following URL "http://www.cecill.info".  The fact that you are      *)
(*   presently reading this means that you have had knowledge of the     *)
(*   CeCILL-C license and that you accept its terms.                     *)
(*                                                                       *)
(* ***********************************************************************)

(** * Global type definitions. *)

Require Import Coqlib.
Require Import String.
Require Import Ascii.
Require Import HexString.

(** Type definitions used in all part of the Hilecop-Cert project. *)

(** Defines the set of strictly positive natural numbers. *)

Definition natstar := { n : nat | n > 0 }.

(** Casts a natstar into a nat. *)

Definition natstar_to_nat (ns : natstar) := proj1_sig ns.
Coercion natstar_to_nat : natstar >-> nat.

(** Defines some natstar. *)

Definition onens := exist _ 1 (gt_Sn_O 0).
Definition twons := exist _ 2 (gt_Sn_O 1).
Definition threens := exist _ 3 (gt_Sn_O 2).

(** Defines the type of relation that are a strict order
    over a type A.
 *)

Inductive IsStrictOrderBRel {A} (brel : A -> A -> bool) : Prop :=
  MkStrictOrderB {
      brel_irrefl : forall a, brel a a = false;
      brel_trans : forall a b c, brel a b = true -> brel b c = true -> brel a c = true;

      (* Irreflexivity and transitivity entail anti-symmetry. *)
      (* brel_antisym : forall a b, brel a b = true -> brel b a = false; *)
    }.

(** States that two elements of type A are comparable through
    the boolean relation [brel]. *)

Definition AreComparableWithBRel {A} (x y : A) (brel : A -> A -> bool) : Prop :=
  brel x y <> false \/ brel y x <> false.

(** States that [brel] is a strict total order over a type A, that is:
    - [brel] is a strict order over type A.
    - all elements of A that are different are comparable with [brel].
 *)

Definition IsStrictTotalOrderBRel {A}
           (eqA : A -> A -> Prop)
           (decEqA : forall x y, {eqA x y} + {~eqA x y})
           (brel : A -> A -> bool) :=
  IsStrictOrderBRel brel /\ forall x y, ~eqA x y -> AreComparableWithBRel x y brel.

(** Defines the type of Petri net arcs. *)

Inductive ArcT : Type := basic | test | inhibitor.

(** Implements the equality between two arc_t values. *)

Definition arct_eqb (a a' : ArcT) : bool :=
  match a, a' with
  | basic, basic => true
  | test, test => true
  | inhibitor, inhibitor => true
  | _, _ => false
  end.

(** Cast from ArcT to nat. *)

Definition ArcT_in_nat (a : ArcT) :=
  match a with
  | basic => 0
  | test => 1
  | inhibitor => 2
  end.

Coercion ArcT_in_nat : ArcT >-> nat.

(** Defines the type of Petri net transitions. *)

Inductive TransitionT : Type := not_temporal | temporal_a_b |
                                temporal_a_a | temporal_a_inf.

(** Cast from TransitionT to nat. *)

Definition TransitionT_in_nat (t : TransitionT) :=
  match t with
  | not_temporal => 0
  | temporal_a_b => 1
  | temporal_a_a => 2
  | temporal_a_inf => 3
  end.

Coercion TransitionT_in_nat : TransitionT >-> nat.

(** Implements the equality between two transition_t values. *)

Definition transt_eqb (t t' : TransitionT) : bool :=
  match t, t' with
  | not_temporal, not_temporal => true
  | temporal_a_b, temporal_a_b => true
  | temporal_a_a, temporal_a_a => true
  | temporal_a_inf, temporal_a_inf => true
  | _, _ => false
  end.

(** Defines an option type able to return error messages. *)

Inductive optionE (A : Type) : Type :=
| Success : A -> optionE A
| Err : string -> optionE A.

Arguments Success {A} a.
Arguments Err {A}.

(** Converts a nat into its hexadecimal string representation. Useful
    to display variable values in error messages.  *)

Notation "$$ n" := (of_nat n) (at level 0, only parsing).


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

(** %\subsection*{ support :  pointwise.v }%*)
Set Implicit Arguments.
Unset Strict Implicit.
Require Export concat.
From Algebra Require Export Cartesian.

(** - The pointwise operation of a binary operator: suppose $f:A\to B, g:A\to C,
 \circ:B\times C\to D$, then (pointwise $\circ$ f g) = $a\mapsto f(a)\circ g(a): A\to D$.
 This is used almost solely to define linear combinations: we have a sequence $\vec a$
 of scalars and a sequence $\vec v$ of vectors, then (sum (pointwise (mX) a v)) =
 $\sum_{i=0}^{n-1} a_i v_i$.

 %\label{pointwise}% *)

Definition pointwise :
  forall (A B C D : Setoid) (op : Map (cart B C) D)
    (f : Map A B) (g : Map A C), MAP A D.
intros.
apply (Build_Map (Ap:=fun a : A => op (couple (f a) (g a)))).
red in |- *.
intros.
apply Ap_comp; auto with algebra.
Defined.

Lemma pointwise_comp_general :
 forall (A B C D : Setoid) (op op' : Map (cart B C) D)
   (f f' : Map A B) (g g' : Map A C),
 op =' op' in MAP _ _ ->
 f =' f' in MAP _ _ ->
 g =' g' in MAP _ _ -> pointwise op f g =' pointwise op' f' g' in _.
intros.
intro.
unfold pointwise in |- *.
simpl in |- *.
apply Ap_comp; auto with algebra.
Qed.

Lemma pointwise_comp :
 forall (n : Nat) (B C D : Setoid) (op op' : Map (cart B C) D)
   (f f' : seq n B) (g g' : seq n C),
 op =' op' in MAP _ _ ->
 f =' f' in _ -> g =' g' in _ -> pointwise op f g =' pointwise op' f' g' in _.
intros.
apply (pointwise_comp_general H H0 H1).
Qed.

Hint Resolve pointwise_comp: algebra.

Lemma pointwise_hd :
 forall (A B C : Setoid) (n : Nat) (v : seq (S n) A)
   (w : seq (S n) B) (op : Map (cart A B) C) (H : 0 < S n),
 pointwise op v w (Build_finiteT H) ='
 op (couple (v (Build_finiteT H)) (w (Build_finiteT H))) in _.
intros.
unfold pointwise in |- *.
simpl in |- *.
apply Refl.
Qed.

Hint Resolve pointwise_hd: algebra.

Lemma pointwise_cons :
 forall (A B C : Setoid) (a : A) (b : B) (n : Nat)
   (v : seq n A) (w : seq n B) (op : Map (cart A B) C),
 pointwise op (a;; v) (b;; w) =' op (couple a b);; pointwise op v w
 in seq _ _.
intros.
apply split_hd_tl_equality; auto with algebra.
Qed.

Hint Resolve pointwise_cons: algebra.

Lemma pointwise_hd_tl :
 forall (A B C : Setoid) (n : Nat) (v : seq (S n) A)
   (w : seq (S n) B) (op : Map (cart A B) C),
 pointwise op v w ='
 op (couple (head v) (head w));; pointwise op (Seqtl v) (Seqtl w) in
 seq _ _.
intros.
apply split_hd_tl_equality; auto with algebra.
unfold pointwise in |- *; intro; simpl in |- *.
destruct x; (apply Ap_comp; auto with algebra).
Qed.

Hint Resolve pointwise_hd_tl: algebra.

Lemma pointwise_Seqtl :
 forall (A B C : Setoid) (n : Nat) (v : seq n A) (w : seq n B)
   (op : Map (cart A B) C),
 pointwise op (Seqtl v) (Seqtl w) =' Seqtl (pointwise op v w) in seq _ _.
induction n.
simpl in |- *.
red in |- *.
auto with algebra.
intros.
apply
 Trans
  with
    (Seqtl (op (couple (head v) (head w));; pointwise op (Seqtl v) (Seqtl w)));
 auto with algebra.
Qed.

Hint Resolve pointwise_Seqtl: algebra.

Lemma pointwise_concat :
 forall (A B C : Setoid) (n m : Nat) (v : seq n A)
   (w : seq m A) (x : seq n B) (y : seq m B) (op : MAP (cart A B) C),
 pointwise op (v ++ w) (x ++ y) =' pointwise op v x ++ pointwise op w y
 in seq _ _.
induction n.
intuition.
intros.
apply
 (split_hd_tl_equality (v:=pointwise op (v ++ w) (x ++ y))
    (w:=pointwise op v x ++ pointwise op w y)); auto with algebra.
apply Trans with (pointwise op (Seqtl (v ++ w)) (Seqtl (x ++ y)));
 auto with algebra.
apply Trans with (pointwise op (Seqtl v ++ w) (Seqtl x ++ y)).
apply
 (pointwise_comp (op:=op) (op':=op) (f:=Seqtl (v ++ w)) (f':=
    Seqtl v ++ w) (g:=Seqtl (x ++ y)) (g':=Seqtl x ++ y));
 auto with algebra.
apply Trans with (Seqtl (pointwise op v x) ++ pointwise op w y);
 auto with algebra.
apply Trans with (pointwise op (Seqtl v) (Seqtl x) ++ pointwise op w y);
 auto with algebra.
apply (IHn _ (Seqtl v) w (Seqtl x) y).
generalize concat_comp.
intro p.
apply
 (p _ _ _ (pointwise op (Seqtl v) (Seqtl x)) (Seqtl (pointwise op v x))
    (pointwise op w y) (pointwise op w y)); auto with algebra.
apply Sym.
apply (Seqtl_concat (pointwise op v x) (pointwise op w y)).
Qed.

Hint Resolve pointwise_concat: algebra.


(*

  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 Export terms_props.
Require Export list. (* why? *)

Lemma isprog_vars_ufun_imp {p} :
  forall vs a b,
    isprog_vars vs a
    -> @isprog_vars p vs b
    -> isprog_vars vs (mk_ufun a b).
Proof.
  introv; rw <- @isprog_vars_ufun; sp.
Qed.

Hint Resolve isprog_vars_ufun_imp : isprog.
Hint Resolve isprog_unit : isprog.
Hint Resolve isprog_vars_cons : isprog.

(*
(* ------ erase ------ *)

Definition mk_erase T := mk_ufun T mk_unit.

Lemma isprog_vars_erase :
  forall vs a,
    isprog_vars vs a
    -> isprog_vars vs (mk_erase a).
Proof.
  unfold mk_erase; sp.
  apply isprog_vars_ufun_imp; sp.
  apply isprog_vars_if_isprog.
  apply isprog_unit.
Qed.

Lemma isprog_erase :
  forall a, isprog a -> isprog (mk_erase a).
Proof.
  unfold mk_erase; sp.
  apply isprog_ufun; sp.
Qed.

Hint Resolve isprog_vars_erase : isprog.
Hint Resolve isprog_erase : isprog.

Definition mkc_erase (T : CTerm) : CTerm :=
  let (t,x) := T in existT isprog (mk_erase t) (isprog_erase t x).

Lemma mkc_erase_eq :
  forall T, mkc_erase T = mkc_ufun T mkc_unit.
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl; sp.
Qed.
*)

(* ------ erase ------ *)

(**

  The following erasure operator is basically ``quotiented by true''.

*)

Definition erase_rel {p} A :=
  match @newvars2 p [A] with
    | (va,vb) => mk_lam va (mk_lam vb A)
  end.

Lemma isprog_erase_rel {p} :
  forall a, @isprog p a -> isprog (erase_rel a).
Proof.
  introv ipa.
  unfold erase_rel.
  destruct (newvars2 [a]); repnd.
  eauto 10 with isprog.
Qed.

Lemma isprog_vars_erase_rel {p} :
  forall vs a, @isprog_vars p vs a -> isprog_vars vs (erase_rel a).
Proof.
  introv ipa.
  unfold erase_rel.
  destruct (newvars2 [a]); repnd.
  eauto 10 with isprog.
Qed.

Lemma isprog_vars_erase_rel_iff {o} :
  forall vs a, @isprog_vars o vs a <=> isprog_vars vs (erase_rel a).
Proof.
  introv; split; intro k.
  apply isprog_vars_erase_rel; auto.
  unfold erase_rel in k.
  remember (newvars2 [a]); repnd.
  repeat (rw @isprog_vars_lam_iff in k).
  apply newvars2_prop2 in Heqp; allsimpl.
  allrw app_nil_r; repnd.
  allrw @isprog_vars_eq.
  repnd; dands; auto.
  provesv.
  allrw in_app_iff; allrw in_single_iff; repdors; auto; subst; sp.
Qed.

Definition erase {o} A := @mk_pertype o (erase_rel A).

Lemma isprog_erase {p} :
  forall a, @isprog p a -> isprog (erase a).
Proof.
  introv ipa.
  apply isprog_pertype.
  apply isprog_erase_rel; auto.
Qed.

Lemma isprog_vars_erase {p} :
  forall vs a, @isprog_vars p vs a -> isprog_vars vs (erase a).
Proof.
  introv ipa.
  apply isprog_vars_pertype.
  apply isprog_vars_erase_rel; auto.
Qed.

Lemma isprog_vars_erase_iff {p} :
  forall vs a, @isprog_vars p vs a <=> isprog_vars vs (erase a).
Proof.
  introv.
  rw @isprog_vars_pertype.
  apply isprog_vars_erase_rel_iff.
Qed.

Hint Resolve isprog_erase_rel : isprog.
Hint Resolve isprog_erase : isprog.
Hint Resolve isprog_vars_erase_rel : isprog.
Hint Resolve isprog_vars_erase : isprog.

Definition erasec_rel {p} (A : @CTerm p) : CTerm :=
  let (a,x) := A in exist isprog (erase_rel a) (isprog_erase_rel a x).

Definition erasec {p} (A : @CTerm p) : CTerm :=
  let (a,x) := A in exist isprog (erase a) (isprog_erase a x).

Lemma erasec_eq {p} :
  forall A, @erasec p A = mkc_pertype (erasec_rel A).
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl; sp.
Qed.

Lemma wf_erase_rel {p} :
  forall a, @wf_term p a -> wf_term (erase_rel a).
Proof.
  unfold erase_rel; introv w.
  destruct (newvars2 [a]).
  repeat (apply wf_lam); auto.
Qed.

Lemma wf_erase {p} :
  forall a, @wf_term p a -> wf_term (erase a).
Proof.
  unfold erase; introv w.
  apply wf_pertype.
  apply wf_erase_rel; auto.
Qed.

Theorem wf_erase_rel_iff {p} :
  forall a, @wf_term p a <=> wf_term (erase_rel a).
Proof.
  introv; split; intro k.
  apply wf_erase_rel; auto.
  revert k.
  unfold erase_rel; destruct (newvars2 [a]); intro.
  repeat (rw <- @wf_lam_iff in k); auto.
Qed.

Theorem wf_erase_iff {p} :
  forall a, @wf_term p a <=> wf_term (erase a).
Proof.
  unfold erase; introv.
  rw <- @wf_pertype_iff.
  rw <- @wf_erase_rel_iff; sp.
Qed.

(* ------ Erased relation ------ *)

Definition sqper_rel {p} v1 v2 R := @mk_lam p v1 (mk_lam v2 (erase R)).
Definition sqper {p} v1 v2 R := @mk_pertype p (sqper_rel v1 v2 R).

(* ------ per-function ------ *)

Definition mk_per_function_base {o} va vb vf vg vx (A B : @NTerm o) :=
  let Ef := mk_equality
              (mk_apply (mk_var vf) (mk_var va))
              (mk_apply (mk_var vg) (mk_var vb))
              (mk_apply B (mk_var va)) in
  let Et := mk_tequality (mk_apply B (mk_var va)) (mk_apply B (mk_var vb)) in
  let Ea := mk_equality (mk_var va) (mk_var vb) A in
  let I := mk_isect Ea vx (mk_uand Ef Et) in
  mk_isect mk_base va (mk_isect mk_base vb I).

(* I should use sqper_rel here *)
Definition mk_per_function_rel {o} (A B : @NTerm o) :=
  match newvars5 [A,B] with
    | (va,vb,vf,vg,vx) =>
      mk_lam vf (mk_lam vg (erase (mk_per_function_base va vb vf vg vx A B)))
  end.

Definition mk_per_function {o} (A B : @NTerm o) :=
 mk_pertype (mk_per_function_rel A B).

Lemma wf_term_mk_per_function_rel {o} :
  forall A B,
    wf_term (@mk_per_function_rel o A B)
    <=> (wf_term A # wf_term B).
Proof.
  introv; unfold mk_per_function_rel.
  destruct (newvars5 [A,B]); repnd.
  allrw <- @wf_lam_iff.
  allrw <- @wf_erase_iff.
  rw <- @wf_isect_iff.
  rw <- @wf_isect_iff.
  rw <- @wf_isect_iff.
  rw @wf_uand.
  allrw <- @wf_equality_iff; repnd.
  allrw <- @wf_tequality_iff; repnd.
  allrw <- @wf_apply_iff.
  split; sp.
Qed.

Lemma wf_term_mk_per_function {o} :
  forall A B,
    wf_term (@mk_per_function o A B)
    <=> (wf_term A # wf_term B).
Proof.
  introv; unfold mk_per_function.
  rw <- @wf_pertype_iff.
  rw <- @wf_term_mk_per_function_rel; sp.
Qed.

Lemma isprog_vars_mk_per_function_rel_iff {o} :
  forall a b vs,
    (isprog_vars vs a # @isprog_vars o vs b)
      <=> isprog_vars vs (mk_per_function_rel a b).
Proof.
  introv.

  unfold mk_per_function_rel.

  remember (newvars5 [a,b]).
  repnd.
  apply newvars5_prop in Heqp; repnd; allsimpl.
  allrw app_nil_r.

  allrw @isprog_vars_lam_iff.
  allrw <- @isprog_vars_erase_iff.
  rw <- @isprog_vars_isect_iff.
  rw <- @isprog_vars_isect_iff.
  rw <- @isprog_vars_isect_iff.
  rw @isprog_vars_uand.
  allrw <- @isprog_vars_equality_iff.
  allrw <- @isprog_vars_tequality_iff.
  allrw @isprog_vars_apply; repnd.
  repeat (rw <- app_assoc); simpl.
  allrw @isprog_vars_base_iff.
  allrw <- @isprog_vars_var_iff; simpl.
  repeat (rw in_app_iff); simpl.
  allrw eq_var_iff.
  repeat (first [rw or_true_l | rw or_true_r | rw and_true_l | rw and_true_r]).

  split; intro k; repnd; dands.

  repeat (apply isprog_vars_cons).
  apply isprog_vars_app1; sp.

  repeat (apply isprog_vars_cons).
  apply isprog_vars_app1; sp.

  repeat (apply isprog_vars_cons).
  apply isprog_vars_app1; sp.

  repeat (apply isprog_vars_cons).
  apply isprog_vars_app1; sp.

  apply isprog_vars_cons_if2 in k0;
    try (complete (repeat (rw in_app_iff in Heqp1); repeat (rw not_over_or in Heqp1); sp)).
  apply isprog_vars_cons_if2 in k0;
    try (complete (repeat (rw in_app_iff in Heqp0); repeat (rw not_over_or in Heqp0); sp)).
  apply isprog_vars_cons_app1 in k0; try (complete sp).
  introv i; simpl in i; repdors; try (complete sp); subst.
  repeat (rw in_app_iff in Heqp2); repeat (rw not_over_or in Heqp2); sp.
  repeat (rw in_app_iff in Heqp3); repeat (rw not_over_or in Heqp3); sp.

  apply isprog_vars_cons_if2 in k;
    try (complete (repeat (rw in_app_iff in Heqp); repeat (rw not_over_or in Heqp); sp)).
  apply isprog_vars_cons_if2 in k;
    try (complete (repeat (rw in_app_iff in Heqp1); repeat (rw not_over_or in Heqp1); sp)).
  apply isprog_vars_cons_if2 in k;
    try (complete (repeat (rw in_app_iff in Heqp0); repeat (rw not_over_or in Heqp0); sp)).
  apply isprog_vars_cons_app1 in k; try (complete sp).
  introv i; simpl in i; repdors; try (complete sp); subst.
  repeat (rw in_app_iff in Heqp2); repeat (rw not_over_or in Heqp2); sp.
  repeat (rw in_app_iff in Heqp3); repeat (rw not_over_or in Heqp3); sp.
Qed.

Lemma isprog_vars_mk_per_function_iff {o} :
  forall a b vs,
    (isprog_vars vs a # @isprog_vars o vs b)
      <=> isprog_vars vs (mk_per_function a b).
Proof.
  introv.

  unfold mk_per_function.
  rw @isprog_vars_pertype.
  rw <- @isprog_vars_mk_per_function_rel_iff; sp.
Qed.

Lemma isprog_mk_per_function_rel_iff {o} :
  forall a b, (isprog a # @isprog o b) <=> isprog (mk_per_function_rel a b).
Proof.
  introv.
  repeat (rw @isprog_vars_nil_iff_isprog).
  apply isprog_vars_mk_per_function_rel_iff.
Qed.

Lemma isprog_mk_per_function_iff {o} :
  forall a b, (isprog a # @isprog o b) <=> isprog (mk_per_function a b).
Proof.
  introv.
  unfold mk_per_function.
  rw <- @isprog_pertype_iff.
  rw <- @isprog_mk_per_function_rel_iff; sp.
Qed.

Lemma isprog_mk_per_function_rel {o} :
  forall a b,
    isprog a
    -> @isprog o b
    -> isprog (mk_per_function_rel a b).
Proof.
  introv ipa ipb.
  rw <- @isprog_mk_per_function_rel_iff; sp.
Qed.

Definition mkc_per_function_rel {o} (A B : @CTerm o) : CTerm :=
  let (a,x) := A in
  let (b,y) := B in
  exist isprog (mk_per_function_rel a b) (isprog_mk_per_function_rel a b x y).

(* ------ iper-function ------ *)

Definition mk_iper_function_rel {o} (A B : @NTerm o) :=
  match newvars5 [A,B] with
    | (va,vb,vf,vg,vx) =>
      mk_lam vf (mk_lam vg (mk_per_function_base va vb vf vg vx A B))
  end.

Definition mk_iper_function {o} (A B : @NTerm o) :=
  mk_ipertype (mk_iper_function_rel A B).

(*
Lemma fold_mk_iper_function_rel :
  forall v1 v2 v3 v4 v5 A B,
    (v1, v2, v3, v4, v5) = newvars5 [A, B]
    -> mk_lam
         v3
         (mk_lam
            v4
            (mk_isect
               mk_base
               v1
               (mk_isect
                  mk_base
                  v2
                  (mk_isect
                     (mk_equality (mk_var v1) (mk_var v2) A)
                     v5
                     (mk_equality (mk_apply (mk_var v3) (mk_var v1))
                                  (mk_apply (mk_var v4) (mk_var v2))
                                  (mk_apply B (mk_var v1)))))))
       = mk_iper_function_rel A B.
Proof.
  introv eq.
  unfold mk_iper_function_rel.
  rw <- eq; sp.
Qed.
*)

Lemma wf_term_mk_iper_function_rel {o} :
  forall A B : @NTerm o,
    wf_term (mk_iper_function_rel A B)
    <=> (wf_term A # wf_term B).
Proof.
  introv; unfold mk_iper_function_rel.
  destruct (newvars5 [A,B]); repnd.
  allrw <- @wf_lam_iff.
  rw <- @wf_isect_iff.
  rw <- @wf_isect_iff.
  rw <- @wf_isect_iff.
  rw @wf_uand.
  allrw <- @wf_equality_iff; repnd.
  allrw <- @wf_tequality_iff; repnd.
  allrw <- @wf_apply_iff.
  split; sp.
Qed.

Lemma wf_term_mk_iper_function {o} :
  forall A B,
    wf_term (@mk_iper_function o A B)
    <=> (wf_term A # wf_term B).
Proof.
  introv; unfold mk_iper_function.
  rw <- @wf_ipertype_iff.
  rw <- @wf_term_mk_iper_function_rel; sp.
Qed.

Lemma isprog_vars_mk_iper_function_rel_iff {o} :
  forall a b vs,
    (isprog_vars vs a # @isprog_vars o vs b)
      <=> isprog_vars vs (mk_iper_function_rel a b).
Proof.
  introv.

  unfold mk_iper_function_rel.

  remember (newvars5 [a,b]).
  repnd.
  apply newvars5_prop in Heqp; repnd; allsimpl.
  allrw app_nil_r.

  do 2 onerw @isprog_vars_lam_iff.
  rw <- @isprog_vars_isect_iff.
  rw <- @isprog_vars_isect_iff.
  rw <- @isprog_vars_isect_iff.
  rw @isprog_vars_uand.
  allrw <- @isprog_vars_equality_iff.
  allrw <- @isprog_vars_tequality_iff.
  allrw @isprog_vars_apply; repnd.
  repeat (rw <- app_assoc); simpl.
  allrw @isprog_vars_base_iff.
  allrw <- @isprog_vars_var_iff; simpl.
  repeat (rw in_app_iff); simpl.
  allrw eq_var_iff.
  repeat (first [rw or_true_l | rw or_true_r | rw and_true_l | rw and_true_r]).

  split; intro k; repnd; dands.

  repeat (apply isprog_vars_cons).
  apply isprog_vars_app1; sp.

  repeat (apply isprog_vars_cons).
  apply isprog_vars_app1; sp.

  repeat (apply isprog_vars_cons).
  apply isprog_vars_app1; sp.

  repeat (apply isprog_vars_cons).
  apply isprog_vars_app1; sp.

  apply isprog_vars_cons_if2 in k0;
    try (complete (repeat (rw in_app_iff in Heqp1); repeat (rw not_over_or in Heqp1); sp)).
  apply isprog_vars_cons_if2 in k0;
    try (complete (repeat (rw in_app_iff in Heqp0); repeat (rw not_over_or in Heqp0); sp)).
  apply isprog_vars_cons_app1 in k0; try (complete sp).
  introv i; simpl in i; repdors; try (complete sp); subst.
  repeat (rw in_app_iff in Heqp2); repeat (rw not_over_or in Heqp2); sp.
  repeat (rw in_app_iff in Heqp3); repeat (rw not_over_or in Heqp3); sp.

  apply isprog_vars_cons_if2 in k;
    try (complete (repeat (rw in_app_iff in Heqp); repeat (rw not_over_or in Heqp); sp)).
  apply isprog_vars_cons_if2 in k;
    try (complete (repeat (rw in_app_iff in Heqp1); repeat (rw not_over_or in Heqp1); sp)).
  apply isprog_vars_cons_if2 in k;
    try (complete (repeat (rw in_app_iff in Heqp0); repeat (rw not_over_or in Heqp0); sp)).
  apply isprog_vars_cons_app1 in k; try (complete sp).
  introv i; simpl in i; repdors; try (complete sp); subst.
  repeat (rw in_app_iff in Heqp2); repeat (rw not_over_or in Heqp2); sp.
  repeat (rw in_app_iff in Heqp3); repeat (rw not_over_or in Heqp3); sp.
Qed.

Lemma isprog_vars_mk_iper_function_iff {o} :
  forall a b vs,
    (isprog_vars vs a # @isprog_vars o vs b)
      <=> isprog_vars vs (mk_iper_function a b).
Proof.
  introv.

  unfold mk_iper_function.
  rw @isprog_vars_ipertype.
  rw <- @isprog_vars_mk_iper_function_rel_iff; sp.
Qed.

Lemma isprog_mk_iper_function_rel_iff {o} :
  forall a b, (isprog a # @isprog o b) <=> isprog (mk_iper_function_rel a b).
Proof.
  introv.
  allrw @isprog_vars_nil_iff_isprog.
  apply isprog_vars_mk_iper_function_rel_iff.
Qed.

Lemma isprog_mk_iper_function_iff {o} :
  forall a b, (isprog a # @isprog o b) <=> isprog (mk_iper_function a b).
Proof.
  introv.
  unfold mk_iper_function.
  rw <- @isprog_ipertype_iff.
  rw <- @isprog_mk_iper_function_rel_iff; sp.
Qed.

Lemma isprog_mk_iper_function_rel {o} :
  forall a b,
    isprog a
    -> @isprog o b
    -> isprog (mk_iper_function_rel a b).
Proof.
  introv ipa ipb.
  rw <- @isprog_mk_iper_function_rel_iff; sp.
Qed.

Definition mkc_iper_function_rel {o} (A B : @CTerm o) : CTerm :=
  let (a,x) := A in
  let (b,y) := B in
  exist isprog (mk_iper_function_rel a b) (isprog_mk_iper_function_rel a b x y).

(* ------ sper-function ------ *)

Definition mk_sper_function {o} (A B : @NTerm o) :=
  mk_spertype (mk_iper_function_rel A B).

Lemma wf_term_mk_sper_function {o} :
  forall A B,
    wf_term (@mk_sper_function o A B)
    <=> (wf_term A # wf_term B).
Proof.
  introv; unfold mk_sper_function.
  rw <- @wf_spertype_iff.
  rw <- @wf_term_mk_iper_function_rel; sp.
Qed.

Lemma isprog_vars_mk_sper_function_iff {o} :
  forall a b vs,
    (isprog_vars vs a # @isprog_vars o vs b)
      <=> isprog_vars vs (mk_sper_function a b).
Proof.
  introv.

  unfold mk_iper_function.
  rw @isprog_vars_spertype.
  rw <- @isprog_vars_mk_iper_function_rel_iff; sp.
Qed.

Lemma isprog_mk_sper_function_iff {o} :
  forall a b, (isprog a # @isprog o b) <=> isprog (mk_sper_function a b).
Proof.
  introv.
  unfold mk_sper_function.
  rw <- @isprog_spertype_iff.
  rw <- @isprog_mk_iper_function_rel_iff; sp.
Qed.

(* Some other stuff *)

Lemma free_vars_erase {o} :
  forall a, free_vars (@erase o a) = free_vars a.
Proof.
  introv.
  unfold erase, erase_rel.

  remember (newvars2 [a]); repnd.
  apply newvars2_prop2 in Heqp; simpl in Heqp.
  repeat (rw app_nil_r in Heqp); repnd.

  simpl.
  allrw app_nil_r.
  allrw remove_nvars_nil_l.
  rw remove_nvars_app_l; simpl.
  repeat (rw remove_nvars_cons_l_weak; sp).
Qed.

Lemma free_vars_per_function_rel_eq {o} :
  forall A B,
    free_vars (@mk_per_function_rel o A B)
    = free_vars A ++ free_vars B ++ free_vars B ++ free_vars B.
Proof.
  introv.
  unfold mk_per_function_rel.
  remember (newvars5 [A,B]); repnd.
  apply newvars5_prop2 in Heqp; simpl in Heqp.
  repeat (rw app_nil_r in Heqp); repeat (rw in_app_iff in Heqp).
  repeat (rw not_over_or in Heqp); repnd.
  repeat rw @free_vars_lam.
  rw @free_vars_erase.
  unfold mk_per_function_base.
  rw @free_vars_isect.
  rw @free_vars_isect.
  rw @free_vars_isect.
  rw @free_vars_uand.
  allrw @free_vars_equality.
  allrw @free_vars_tequality.
  allrw @free_vars_apply; simpl.
  repeat (first [ rw remove_nvars_app_r
                | rw remove_nvars_app_l; simpl
                | rw remove_nvars_nil_r
                | rw app_nil_r
                | rw remove_nvars_cons_r; boolvar; allrw not_over_or; repnd; spFalseHyp
         ]; GC).
  repeat (rw remove_nvars_cons_l_weak; auto); repeat (rw remove_nvars_nil_l).
Qed.

Lemma free_vars_per_function_rel {o} :
  forall A B,
    eqvars (free_vars (@mk_per_function_rel o A B))
           (free_vars A ++ free_vars B).
Proof.
  introv.
  rw @free_vars_per_function_rel_eq.
  rw eqvars_prop; introv.
  repeat (rw in_app_iff); split; sp.
Qed.

Lemma free_vars_per_function {o} :
  forall A B, eqvars (free_vars (@mk_per_function o A B)) (free_vars A ++ free_vars B).
Proof.
  introv.
  unfold mk_per_function.
  rewrite free_vars_mk_pertype.
  apply free_vars_per_function_rel; auto.
Qed.

Lemma free_vars_mk_per_function {o} :
  forall A B,
    free_vars (@mk_per_function o A B)
    = free_vars (mk_per_function_rel A B).
Proof.
  introv.
  unfold mk_per_function.
  rw @free_vars_mk_pertype; sp.
Qed.

Lemma free_vars_iper_function_rel_eq {o} :
  forall A B,
    free_vars (@mk_iper_function_rel o A B)
    = free_vars A ++ free_vars B ++ free_vars B ++ free_vars B.
Proof.
  introv.
  unfold mk_iper_function_rel.
  remember (newvars5 [A,B]); repnd.
  apply newvars5_prop2 in Heqp; simpl in Heqp.
  repeat (rw app_nil_r in Heqp); repeat (rw in_app_iff in Heqp).
  repeat (rw not_over_or in Heqp); repnd.
  repeat rw @free_vars_lam.
  unfold mk_per_function_base.
  rw @free_vars_isect.
  rw @free_vars_isect.
  rw @free_vars_isect.
  rw @free_vars_uand.
  allrw @free_vars_equality.
  allrw @free_vars_tequality.
  allrw @free_vars_apply; simpl.
  repeat (first [ rw remove_nvars_app_r
                | rw remove_nvars_app_l; simpl
                | rw remove_nvars_nil_r
                | rw app_nil_r
                | rw remove_nvars_cons_r; boolvar; allrw not_over_or; repnd; spFalseHyp
         ]; GC).
  repeat (rw remove_nvars_cons_l_weak; auto); repeat (rw remove_nvars_nil_l).
Qed.

Lemma free_vars_iper_function_rel {o} :
  forall A B,
    eqvars (free_vars (@mk_iper_function_rel o A B))
           (free_vars A ++ free_vars B).
Proof.
  introv.
  rw @free_vars_iper_function_rel_eq.
  rw eqvars_prop; introv.
  repeat (rw in_app_iff); split; sp.
Qed.

Lemma free_vars_iper_function {o} :
  forall A B, eqvars (free_vars (@mk_iper_function o A B)) (free_vars A ++ free_vars B).
Proof.
  introv.
  unfold mk_iper_function.
  rewrite free_vars_mk_ipertype.
  apply free_vars_iper_function_rel; auto.
Qed.

Lemma free_vars_mk_iper_function {o} :
  forall A B,
    free_vars (@mk_iper_function o A B)
    = free_vars (mk_iper_function_rel A B).
Proof.
  introv.
  unfold mk_iper_function.
  rw @free_vars_mk_ipertype; sp.
Qed.

Lemma free_vars_sper_function {o} :
  forall A B, eqvars (free_vars (@mk_sper_function o A B)) (free_vars A ++ free_vars B).
Proof.
  introv.
  unfold mk_sper_function.
  rewrite free_vars_mk_spertype.
  apply free_vars_iper_function_rel; auto.
Qed.

Lemma free_vars_mk_sper_function {o} :
  forall A B,
    free_vars (@mk_sper_function o A B)
    = free_vars (mk_iper_function_rel A B).
Proof.
  introv.
  unfold mk_sper_function.
  rw @free_vars_mk_spertype; sp.
Qed.

(* image type *)

Definition mk_per_image_rel {o} (T f : @NTerm o) :=
  match newvars4 [T,f] with
    | (va,vb,vx,vy) =>
        let C1 := mk_cequiv (mk_var vx) (mk_apply f (mk_var va)) in
        let C2 := mk_cequiv (mk_var vy) (mk_apply f (mk_var vb)) in
        let C3 := mk_equality (mk_var va) (mk_var vb) T in
        let U := mk_uand C1 (mk_uand C2 C3) in
        let E := mk_exists mk_base va (mk_exists mk_base vb U) in
          mk_lam vx (mk_lam vy E)
  end.

Definition mk_per_image {o} (T f : @NTerm o) :=
  mk_pertype (mk_per_image_rel T f).


From coq_sortscan Require Import helper.
From stdpp Require Import list.

Definition CAP_DISK : nat := 100.
Definition CAP_MEM : nat := 16.

Record Data := {
  disk : list nat;
  mem : list nat;
  disk_length : length disk = CAP_DISK;
  mem_length : length mem = CAP_MEM
}.

Implicit Type (data : Data).

Program Definition write_const_disk data (i v : nat) : Data :=
  {| disk := <[i:=v]> (disk data); mem := mem data |}.
Next Obligation. intros. rewrite insert_length. apply (disk_length data). Qed.
Next Obligation. intros. apply (mem_length data). Qed.

Program Definition write_const_mem data (i v : nat) : Data :=
  {| disk := disk data; mem := <[i:=v]> (mem data) |}.
Next Obligation. intros. apply (disk_length data). Qed.
Next Obligation. intros. rewrite insert_length. apply (mem_length data). Qed.

Definition read_mem data (i : nat) := (mem data) !! i.

(* copy disk[i] to mem[j] *)
Definition read_disk data (i j : nat) :=
  match (disk data) !! i with
  | None => data
  | Some v => write_const_mem data j v
  end.

(* copy mem[i] to disk[j] *)
Definition write_disk data (i j : nat) :=
  match (mem data) !! i with
  | None => data
  | Some v => write_const_disk data j v
  end.

(* copy disk[i..i+len) to mem[j..j+len) *)
Fixpoint read_range_disk data (i len j : nat) :=
  match len with
  | O => data
  | S len' => read_range_disk (read_disk data i j) (S i) len' (S j)
  end.

(* copy mem[i..i+len) to disk[j..j+len) *)
Fixpoint write_range_disk data (i len j : nat) :=
  match len with
  | O => data
  | S len' => write_range_disk (write_disk data i j) (S i) len' (S j)
  end.
(*
Lemma read_disk_length data i j :
  length (read_disk data i j) = length mem.
Proof.
  unfold read_disk. destruct (disk !! i) eqn:E; auto.
  unfold write_const_mem. by rewrite insert_length.
Qed.

Lemma read_range_disk_length data i len j :
  length (read_range_disk data i len j) = length mem.
Proof.
  revert data i j. induction len; auto; simpl; intros.
  rewrite IHlen. by rewrite read_disk_length.
Qed.
*)
Lemma read_range_disk_slice data i len j :
  slice (mem (read_range_disk data i len j)) j len =
  slice (disk data) i len.
Admitted.

Lemma read_range_disk_eq data i len j :
  mem (read_range_disk data i len j) =
  take j (mem data) ++ slice (disk data) i len ++ drop (j+len) (mem data).
Proof.
  rewrite (slice_cut (mem (read_range_disk data i len j)) j len).
  rewrite read_range_disk_slice.
Admitted.

Lemma read_range_disk_disk data i len j :
  disk (read_range_disk data i len j) = disk data.
Admitted.

Lemma write_range_disk_slice data i len j :
  i+len ≤ CAP_MEM → j+len ≤ CAP_DISK →
  slice (disk (write_range_disk data i len j)) j len =
  slice (mem data) i len.
Admitted.

Lemma write_range_disk_eq data i len j :
  disk (write_range_disk data i len j) =
  take j (disk data) ++ slice (mem data) i len ++ drop (j+len) (disk data).
Admitted.

Lemma write_range_disk_mem data i len j :
  mem (write_range_disk data i len j) = mem data.
Admitted.


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 D T Bprime MB Bprimeprime : Universe, ((wd_ A B /\ (wd_ A D /\ (wd_ A T /\ (wd_ B D /\ (wd_ B T /\ (wd_ D T /\ (wd_ D Bprime /\ (wd_ B Bprime /\ (wd_ MB B /\ (wd_ MB T /\ (wd_ MB Bprime /\ (wd_ Bprime Bprimeprime /\ (wd_ MB Bprimeprime /\ (wd_ T Bprimeprime /\ (wd_ B Bprimeprime /\ (wd_ A Bprime /\ (col_ A B Bprime /\ (col_ Bprime MB Bprimeprime /\ (col_ B MB T /\ (col_ Bprime B D /\ col_ T D A)))))))))))))))))))) -> col_ A B T)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 O E Eprime A B C D Bprime X Bprimeprime Dprime : Universe, ((wd_ C O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ D O /\ (wd_ Eprime A /\ (wd_ X O /\ (wd_ D Dprime /\ (wd_ Bprime X /\ (wd_ B Bprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O Eprime Bprime /\ (col_ O E X /\ (col_ O Eprime Bprimeprime /\ col_ O Eprime Dprime))))))))))))))))))) -> col_ O Dprime Bprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 O A B C Bprime Cprime : Universe, ((wd_ O A /\ (wd_ O Bprime /\ (wd_ O Cprime /\ (wd_ A B /\ (wd_ B Bprime /\ (wd_ A Bprime /\ (wd_ A C /\ (wd_ C Cprime /\ (wd_ O B /\ (wd_ O C /\ (col_ O A B /\ (col_ O A Bprime /\ (col_ A Bprime Cprime /\ (col_ B C Cprime /\ (col_ Bprime C Cprime /\ col_ A B C))))))))))))))) -> col_ Bprime O Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^322 - 2^161 - 1
Base: 53 + 2/3
***)

Definition curve : CurveParameters :=
  {|
    sz := 6%nat;
    base := 53 + 2/3;
    bitwidth := 64;
    s := 2^322;
    c := [(1, 1); (2^161, 1)];
    carry_chains := Some [[2; 5]; [3; 0; 4; 1; 5; 2]; [3; 0]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := Some true;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Export DACandMAC.
Require Export setACLdata.

Set Implicit Arguments.
Unset Strict Implicit.

Section Mkdir.

Variable s : SFSstate.

(*********************************************************************)
(*                   Some Useful Synonymous                          *)
(*********************************************************************)

Definition NEWDIR (p : OBJNAME) : OBJECT := (p, Directory).

Definition mkdir_oSC (u : SUBJECT) (p : OBJNAME) :
  set (OBJECT * SecClass) :=
  match fSSC (subjectSC s) u, fsecmat (secmat s) (MyDir p) with
  | None, _ => objectSC s
  | _, None => objectSC s
  | Some y, Some z => set_add OSCeq_dec (NEWDIR p, y) (objectSC s)
  end.

Let ChangeGAR (u : SUBJECT) (oct : RIGHTS) : set GRPNAME :=
  ChangeGroupR (AllGrp s) oct
    (ChangeGroupR (primaryGrp s u) oct (empty_set GRPNAME)).

Let ChangeGAW (u : SUBJECT) (oct : RIGHTS) : set GRPNAME :=
  ChangeGroupW (AllGrp s) oct
    (ChangeGroupW (primaryGrp s u) oct (empty_set GRPNAME)).

Let NEW (u : SUBJECT) (p : OBJNAME) (perms : PERMS) : AccessCtrlListData :=
  acldata u (primaryGrp s u)
    (ChangeUserR u (empty_set SUBJECT) (ownerp perms))
    (ChangeGAR u (groupp perms))
    (ChangeUserW u (empty_set SUBJECT) (ownerp perms))
    (ChangeGAW u (groupp perms)) (set_add SUBeq_dec u (empty_set SUBJECT))
    (ChangeGroupO (RootGrp s) (empty_set GRPNAME)).

Definition mkdir_acl (u : SUBJECT) (p : OBJNAME) (perms : PERMS) :
  set (OBJECT * AccessCtrlListData) :=
  match fSSC (subjectSC s) u, fsecmat (secmat s) (MyDir p) with
  | None, _ => acl s
  | _, None => acl s
  | Some y, Some z => set_add ACLeq_dec (NEWDIR p, NEW u p perms) (acl s)
  end.

Let t (u : SUBJECT) (p : OBJNAME) (perms : PERMS) : SFSstate :=
  mkSFS (groups s) (primaryGrp s) (subjectSC s) (AllGrp s)
    (RootGrp s) (SecAdmGrp s) (mkdir_oSC u p) (mkdir_acl u p perms)
    (secmat s) (files s) (mkdir_directories u p).

(*********************************************************************)
(*                            mkdir                                  *)
(*********************************************************************)

(*This operation creates a new, empty directory given by an absolute *)
(*path. The directory is created with the mode indicated by perms.   *)

Inductive mkdir (u : SUBJECT) (p : OBJNAME) (perms : PERMS) :
SFSstate -> Prop :=
    MkdirOK :
      ~ set_In (p, File) (domf (files s)) ->
      ~ set_In (p, Directory) (domd (directories s)) ->
      set_In (MyDir p) (domd (directories s)) ->
      match fsecmat (secmat s) (MyDir p) with
      | None => False
      | Some y => set_In u (ActWriters y)
      end -> mkdir u p perms (t u p perms).

End Mkdir.

Hint Unfold mkdir_oSC mkdir_acl.


Require Import Lia.
Require Import RelationClasses.

From sflib Require Import sflib.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.

Set Implicit Arguments.

Module MemoryDomain.
  Definition t := Loc.t -> DOSet.t.

  Definition mem loc ts (dom:t) := DOSet.mem ts (dom loc).

  Lemma ext lhs rhs
        (EXT: forall loc ts, mem loc ts lhs = mem loc ts rhs):
    lhs = rhs.
  Proof.
    apply LocFun.ext. unfold LocFun.find. i.
    apply DOSet.eq_leibniz. ii.
    specialize (EXT i a). unfold mem in *. econs; i.
    - apply DOSet.mem_spec. erewrite <- EXT.
      apply DOSet.mem_spec. auto.
    - apply DOSet.mem_spec. erewrite EXT.
      apply DOSet.mem_spec. auto.
  Qed.

  Definition bot: t := fun _ => DOSet.empty.

  Lemma bot_spec loc ts: mem loc ts bot = false.
  Proof.
    unfold mem, bot. apply DOSet.Facts.empty_b.
  Qed.

  Definition le (lhs rhs:t): Prop :=
    forall loc ts, mem loc ts lhs -> mem loc ts rhs.

  Definition join (lhs rhs:t): t :=
    fun loc => DOSet.union (lhs loc) (rhs loc).

  Lemma join_comm lhs rhs: join lhs rhs = join rhs lhs.
  Proof.
    apply LocFun.ext. unfold LocFun.find, join. i.
    apply DOSet.eq_leibniz. ii.
    rewrite ? DOSet.union_spec. econs; i; des; auto.
  Qed.

  Lemma join_assoc a b c: join (join a b) c = join a (join b c).
  Proof.
    apply LocFun.ext. unfold LocFun.find, join. i.
    apply DOSet.eq_leibniz. ii.
    rewrite ? DOSet.union_spec. econs; i; des; auto.
  Qed.

  Lemma join_l lhs rhs: le lhs (join lhs rhs).
  Proof.
    unfold join. ii. unfold mem in *.
    rewrite DOSet.Facts.union_b, H. auto.
  Qed.

  Lemma join_r lhs rhs: le rhs (join lhs rhs).
  Proof. rewrite join_comm. apply join_l. Qed.

  Lemma join_spec lhs rhs o
        (LHS: le lhs o)
        (RHS: le rhs o):
    le (join lhs rhs) o.
  Proof.
    unfold join. ii.
    unfold mem in *. rewrite DOSet.Facts.union_b in *.
    apply Bool.orb_true_iff in H. des; eauto.
  Qed.

  Definition set (loc:Loc.t) (ts:Time.t) (dom:t) :=
    LocFun.add loc (DOSet.add ts (dom loc)) dom.

  Lemma set_o loc1 ts1 loc2 ts2 dom:
    mem loc1 ts1 (set loc2 ts2 dom) =
    if loc_ts_eq_dec (loc1, ts1) (loc2, ts2)
    then true
    else mem loc1 ts1 dom.
  Proof.
    unfold mem, set, LocFun.add, LocFun.find.
    repeat (try condtac; ss; des; subst; try congr).
    - rewrite DOSet.Facts.add_b.
      unfold DOSet.Facts.eqb. rewrite Time.eq_dec_eq. auto.
    - rewrite DOSet.Facts.add_b.
      unfold DOSet.Facts.eqb. rewrite Time.eq_dec_neq; auto.
  Qed.

  Lemma set_eq loc ts dom:
    mem loc ts (set loc ts dom) = true.
  Proof.
    rewrite set_o. condtac; ss. des; congr.
  Qed.

  Lemma set_inv loc1 ts1 loc2 ts2 dom
        (MEM: mem loc1 ts1 (set loc2 ts2 dom)):
    (loc1 = loc2 /\ ts1 = ts2) \/ mem loc1 ts1 dom.
  Proof.
    revert MEM. rewrite set_o. repeat condtac; ss; auto.
  Qed.

  Definition unset (loc:Loc.t) (ts:Time.t) (dom:t) :=
    LocFun.add loc (DOSet.remove ts (dom loc)) dom.

  Lemma unset_o loc1 ts1 loc2 ts2 dom:
    mem loc1 ts1 (unset loc2 ts2 dom) =
    if loc_ts_eq_dec (loc1, ts1) (loc2, ts2)
    then false
    else mem loc1 ts1 dom.
  Proof.
    unfold mem, unset, LocFun.add, LocFun.find.
    repeat (try condtac; ss; des; subst; try congr).
    - rewrite DOSet.Facts.remove_b.
      unfold DOSet.Facts.eqb. rewrite Time.eq_dec_eq.
      apply Bool.andb_false_iff. auto.
    - rewrite DOSet.Facts.remove_b.
      unfold DOSet.Facts.eqb. rewrite Time.eq_dec_neq; auto.
      apply Bool.andb_true_r.
  Qed.

  Lemma unset_eq loc ts dom:
    mem loc ts (unset loc ts dom) = false.
  Proof.
    rewrite unset_o. condtac; ss. des; congr.
  Qed.

  Lemma unset_inv loc1 ts1 loc2 ts2 dom
        (MEM: mem loc1 ts1 (unset loc2 ts2 dom)):
    ~ (loc1 = loc2 /\ ts1 = ts2) /\ mem loc1 ts1 dom.
  Proof.
    revert MEM. rewrite unset_o. condtac; ss. i.
    splits; auto. ii. des; auto.
  Qed.

  Lemma unset_set loc to inv
        (MEM: mem loc to inv = false):
    unset loc to (set loc to inv) = inv.
  Proof.
    apply ext. i.
    rewrite unset_o, set_o.  condtac; ss. des. subst. auto.
  Qed.

  Lemma unset_bot loc to:
    unset loc to bot = bot.
  Proof.
    apply ext. i. rewrite unset_o. condtac; ss.
  Qed.

  Inductive disjoint (lhs rhs:t): Prop :=
  | disjoint_intro
      (DISJOINT: forall loc ts
                   (LHS: mem loc ts lhs)
                   (RHS: mem loc ts rhs),
          False).

  Global Program Instance disjoint_Symmetric: Symmetric disjoint.
  Next Obligation.
    econs. ii. eapply H; eauto.
  Qed.

  Definition sound (dom: t) (promises: Memory.t): Prop :=
    forall loc ts (MEM: mem loc ts dom),
      exists from msg, Memory.get loc ts promises = Some (from, msg).
End MemoryDomain.


Require Import Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrbool Ssreflect.finfun Ssreflect.fintype Ssreflect.ssrnat Ssreflect.eqtype Ssreflect.seq Ssreflect.tuple.
Require Import x86proved.bitsrep x86proved.bitsprops.
Require Import x86proved.x86.program.

Require Import stringbuff.
Require Import compiler.

(* ATBR *)
(*Require Import ATBR.Common.*)
Require Import ATBR.Classes.
Require Import ATBR.Graph.
Require Import ATBR.DecideKleeneAlgebra.
Require Import ATBR.DKA_Definitions.
Close Scope A_scope.

(* BinPos *)
Require Import BinNums BinPos.

(****************************************************************)
(* Interface with RelationAlgebra                               *)
(****************************************************************)

Section Compile.

Variables
  (r: regex)
  (alphabet: seq DWORD).

Definition dfa_r: DFA.t := X_to_DFA r.

Lemma dfa_br: DFA.bounded dfa_r.
Proof.
  apply X_to_DFA_bounded.
Qed.

(*Coercion Pos.to_nat : positive >-> nat.*)
(*Coercion Pos.of_nat : nat >-> positive.*)

Notation char := positive.

Definition char_of_DWORD (n: DWORD) : char := Pos.of_nat (toNat n).
Definition DWORD_of_char (p: char): DWORD := #((Pos.to_nat p)).

(*
Lemma char_of_DWORDK (c: DWORD):
  c \in alphabet -> DWORD_of_char (char_of_DWORD c) = c.
Proof.
  move=> H; apply alphabet_char in H.
  rewrite /char_of_DWORD/DWORD_of_char.
  rewrite (Pnat.Nat2Pos.id);
    first by apply  toNatK.
  set x := toNat c.
  rewrite -(toNat_fromNat0 32).
  rewrite /x {x}.
  rewrite /not=> H'.
  apply  toNat_inj in H'.
  apply H.
  assumption.
Qed.
*)

(*
Coercion char_of_DWORD : DWORD >-> char.
Coercion DWORD_of_char : char >-> DWORD.
*)

Definition dfa_size: nat := (Pos.to_nat (DFA.size dfa_r)).-1.

Notation state := positive.

Lemma ord_of_belongHelp (s: state): DFA.belong s dfa_r -> (Pos.to_nat s).-1 < dfa_size.
Proof.
  move=> H.
  apply/ltP.
  rewrite /dfa_size.
  apply Lt.lt_pred.
  rewrite prednK;
    last by apply/ltP;
            apply Pnat.Pos2Nat.is_pos.
  rewrite -Pnat.Pos2Nat.inj_lt.
  exact: H.
Qed.

Definition ord_of_belong (s: state)(H: DFA.belong s dfa_r): 'I_dfa_size :=
  Ordinal (ord_of_belongHelp s H).

Lemma ord_of_belongK: forall s q, state_of_nat (nat_of_ord (ord_of_belong s q)) = s.
Proof.
  move=> s q.
  rewrite /ord_of_belong/=/state_of_nat.
  rewrite Pos.of_nat_succ prednK;
    last by apply/ltP;
            apply Pnat.Pos2Nat.is_pos.
  by rewrite Pnat.Pos2Nat.id.
Qed.

Definition DFA_init: 'I_dfa_size := ord_of_belong (DFA.initial dfa_r) (DFA.bounded_initial dfa_br).

Definition accept (s: 'I_dfa_size): bool := StateSet.mem s (DFA.finaux dfa_r).

Definition trans (s: 'I_dfa_size)(v: DWORD): 'I_dfa_size :=
  ord_of_belong (DFA.delta dfa_r (Pos.of_nat (toNat v) (* this is safe because v <> #0 *)) s)
                (DFA.bounded_delta dfa_br _ _).

Definition lang' (s: 'I_dfa_size)(w: seq DWORD): bool :=
  lang alphabet accept trans s w.

Lemma in_mem t s : StateSet.mem t s <-> StateSet.In t s.
Proof.
  split; [apply StateSet.mem_1 | apply StateSet.mem_2].
Qed.

Lemma equiv_read_lang
      (w: seq DWORD)
      (s: state)(q: DFA.belong s dfa_r) :
   StateSet.mem
     (DKA_DFA_Language.read dfa_r [seq char_of_DWORD c | c <- w] s)
     (DFA.finaux dfa_r) /\ (all (fun a => a \in alphabet) w)
   <-> lang' (ord_of_belong s q) w.
Proof.
  elim: w s q=> [s q|a w IH s q].
  * (* CASE: w ~ [::] *)
    rewrite /map/lang'/lang/accept/DKA_DFA_Language.read /=.
    rewrite /statesetelt_of_nat/state_of_nat.
    rewrite Pos.of_nat_succ.
    rewrite prednK;
         last by apply/ltP;
                 apply Pnat.Pos2Nat.is_pos.
    rewrite Pnat.Pos2Nat.id.
    by split; [ move=> [a _]; assumption
              | move=> a; split; assumption || done].

  * (* CASE: w ~ i :: a *)
    rewrite [map _ (_ :: _)]/=.
    rewrite /lang' [lang _ _ _ _ (_ :: _)]/=.
    rewrite [DKA_DFA_Language.read _ (_ :: _) _]/=.
    rewrite [all _ (_ :: _)]/=.

    rewrite [(trans (ord_of_belong s q) a)]/trans.
    rewrite ord_of_belongK.
    rewrite /char_of_DWORD.

    split.

    - (* CASE: read -> lang *)
      move=> [HMem /andP [a_in_alphabet all_in_w]].
      apply/andP; split; first by assumption.

      move: IH=> /(_ (DFA.delta dfa_r (char_of_DWORD a) s)
                  (DFA.bounded_delta dfa_br (char_of_DWORD a) s)) IH.

      by apply IH; split; by assumption.

    - (* CASE: lang -> read *)
      move=> /andP [a_in_alpha in_lang].

      apply IH in in_lang.
      move: in_lang=> [in_mem all_in_w].

      by split; try (apply/andP; split); assumption.
Qed.

Lemma lang_in_alphabet (s: 'I_dfa_size)(w: seq DWORD):
  lang' s w -> all (fun a => a \in alphabet) w.
Proof.
  elim: w s=> [_ _|a w IH s H] //=.
  rewrite [lang' _ (_ :: _)]/= in H.
  move/andP: H=> [a_in_alphabet lang_w].
  apply/andP; split; first by assumption.
  move: IH=> /(_ (trans s a) lang_w).
  done.
Qed.

Variable
  (alphabet_compat:
     forall c, c \in alphabet ->
                     below (char_of_DWORD c) (DFA.max_label dfa_r)).

Lemma lang_is_bounded (w: seq DWORD):
  lang' DFA_init w -> DKA_DFA_Language.bounded_word dfa_r [seq char_of_DWORD c | c <- w].
Proof.
  rewrite /DKA_DFA_Language.bounded_word.
  move=> w_in_lang c c_in_w.
  have w_in_alphabet: all (fun a => a \in alphabet) w
    by apply lang_in_alphabet with DFA_init;
       assumption.
  clear w_in_lang.
  elim: w w_in_alphabet c_in_w=> [_ _|a w IH w_in_alphabet c_in_w]//=.

  rewrite [map _ (_ :: _)]/= in c_in_w.
  rewrite [List.In _ (_ :: _)]/= in c_in_w.

  rewrite [all _ (_ :: _)]/= in w_in_alphabet.
  move: w_in_alphabet=> /andP [a_in_alphabet w_in_alphabet].
  move: c_in_w=> [<- | c_in_w].

  * (* CASE: below (char_of_DWORD a) (DFA.max_label dfa_r)
             with a \in alphabet *)
    apply: alphabet_compat.
    by done.

  * (* CASE: below c (DFA.max_label dfa_r)
             with c \in w *)
    move: IH=> /(_ w_in_alphabet c_in_w).
    by done.
Qed.

Lemma equiv_DFA_language
      (w: seq DWORD) :
  DKA_DFA_Language.DFA_language dfa_r [seq char_of_DWORD c | c <- w] /\ (all (fun a => a \in alphabet) w)
  <-> lang' DFA_init w.
Proof.
  rewrite /DKA_DFA_Language.DFA_language.
  split.
    * (* CASE: read -> lang *)
      move=> [[read _] bounded].
      rewrite /DFA_init.
      rewrite -(equiv_read_lang w (DFA.initial dfa_r) ((DFA.bounded_initial dfa_br))).
      rewrite in_mem.
      by split; assumption.

    * (* CASE: lang -> read *)
      move=> inLang.
      rewrite -in_mem and_assoc
              [_ /\ all _ _]and_comm -and_assoc.
      split;
        first by rewrite (equiv_read_lang w (DFA.initial dfa_r) ((DFA.bounded_initial dfa_br)));
                 assumption.
      by apply lang_is_bounded; assumption.
Qed.

Lemma test: (DKA_DFA_Language.DFA_language (X_to_DFA r) ==
            DKA_DFA_Language.regex_language r)%A.
apply equal_trans with (DKA_DFA_Language.regex_language (DFA.eval (X_to_DFA r))); last first.
apply DKA_DFA_Language.regex_language_graph_functor.
apply X_to_DFA_correct.
rewrite DKA_DFA_Language.language_DFA_eval.
reflexivity.
exact: dfa_br.
Qed.

Lemma compiler_correct (w: seq DWORD):
      lang' DFA_init w <->
         DKA_DFA_Language.regex_language r (map char_of_DWORD w)
      /\ (all (fun a => a \in alphabet) w).
Proof.
  rewrite -(test (map char_of_DWORD w)).
  rewrite /dfa_r.
  rewrite -equiv_DFA_language.
  done.
Qed.

Definition X_to_x86 (acc rej: DWORD): program :=
  compiler acc rej DFA_init alphabet accept trans.

End Compile.

(*
Definition X_to_x86
             (r: regex)
             (acc rej: DWORD): program :=
  DFA_to_x86 (X_to_DFA r) acc rej.
*)


Require Import Coq.Logic.Classical_Prop.
Require Import Logic.lib.Coqlib.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Model.OSAExamples.
Require Import Logic.SeparationLogic.Model.OSAGenerators.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.
Require Import Logic.HoareLogic.ImperativeLanguage.
Require Import Logic.HoareLogic.ProgramState.
Require Import Logic.HoareLogic.BigStepSemantics.
Require Import Logic.HoareLogic.TraceSemantics.
Require Import Logic.HoareLogic.HoareTriple_BigStepSemantics.
Require Import Logic.HoareLogic.GuardedHoareTriple_TraceSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelSingleNotation.
Import KripkeModelNotation_Intuitionistic.

Lemma start_by_Aacq_or_Arel {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res} {nAcr: NormalAction_resource Ac Res}: forall r tr, start_by_Aacq r tr -> start_by_Arel r tr -> False.
Proof.
  intros.
  induction tr.
  + inversion H0.
  + destruct (classic (is_resource_action r a)) as [[? | ?] | ?]; subst.
    - inversion H0; subst; solve_resource_action.
    - inversion H; subst; solve_resource_action.
    - inversion H; subst; solve_resource_action.
      inversion H0; subst; solve_resource_action.
      auto.
Qed.

Lemma start_by_Aacq_trace_acc_spec {state: Type} {Ac: Action} {Res: Resource} {J: Join state} {state_R: Relation state} {Acr: Action_resource Ac Res} {nAcr: NormalAction_resource Ac Res} {ac_sem: ActionInterpret (resources * state) Ac} {AIr: ActionInterpret_resource state Ac Res ac_sem}: forall (Inv: resource * (state -> Prop) -> Prop) (tr: trace) A1 A2 s1 s2,
  (forall r, start_by_Aacq r tr) ->
  @trace_access _ _ (ThreadLocal_ActionInterpret_resource _ Inv) tr (A1, s1) (Terminating (A2, s2)) ->
  A1 = A2.
Proof.
  intros.
  assert (join A2 (fun r => start_by_Arel r tr) A1).
  Focus 2. {
    extensionality r; apply prop_ext.
    specialize (H r); specialize (H1 r).
    pose proof start_by_Aacq_or_Arel r tr.
    destruct H1; tauto.
  } Unfocus.
  assert (forall r, start_by_Aacq r tr \/ start_by_Arel r tr).
  Focus 1. {
    intros r.
    specialize (H r).
    auto.
  } Unfocus.
  clear H.
  revert s1 A1 H0; induction tr; intros.
  + inversion H0; subst; clear H0.
    clear - nAcr.
    intros r.
    pose proof start_by_Aacq_or_Arel r nil.
    pose proof start_by_Aacq_nil r.
    split; tauto.
  + inversion H0; subst; clear H0.
    destruct s' as [A1' s1'].
    specialize (fun HH => IHtr HH s1' A1' H6); clear H6.
    simpl in H3.
    assert (HH: forall r : resource, start_by_Aacq r tr \/ start_by_Arel r tr).
    Focus 1. {
      clear - nAcr H1.
      intros r; specialize (H1 r).
      destruct (classic (is_resource_action r a)) as [[? | ?] | ?]; subst;
      destruct H1 as [HH | HH]; inversion HH; auto.
    } Unfocus.
    specialize (IHtr HH); clear HH.
    intros r; specialize (IHtr r); specialize (H1 r).
    destruct (classic (is_resources_action a)) as [[?r [? | ?]] | ?]; subst.
    - inversion H3; subst; clear H3; solve_resource_action.
      clear I f H7 H8 H9.
      specialize (H6 r).
      pose proof start_by_Aacq_or_Arel r (Aacquire_res r0 :: tr).
      pose proof start_by_Aacq_or_Arel r tr.
      destruct H1 as [H1 | H1]; inversion H1; subst; solve_resource_action;
      destruct IHtr, H6; split; try tauto.
    - inversion H3; subst; clear H3; solve_resource_action.
      clear I H7 H8.
      specialize (H6 r).
      pose proof start_by_Aacq_or_Arel r (Arelease_res r0 :: tr).
      pose proof start_by_Aacq_or_Arel r tr.
      destruct H1 as [H1 | H1]; inversion H1; subst; solve_resource_action;
      destruct IHtr, H6; split; try tauto.
    - rewrite <- thread_local_state_enable_non_resource_action in H3 by auto.
      apply state_enable_non_resource_action1 in H3; auto.
      subst A1.
      assert (~ is_resource_action r a) by (intro HH; apply H; exists r; auto).
      pose proof start_by_Aacq_or_Arel r (a :: tr).
      pose proof start_by_Aacq_or_Arel r tr.
      destruct H1 as [H1 | H1]; inversion H1; subst; solve_resource_action;
      destruct IHtr; split; try tauto.
Qed.

Section soundness.

Existing Instance unit_kMD.

Context {P: ProgrammingLanguage}
        {MD: Model}
        {J: Join model}
        {SA: SeparationAlgebra model}
        {R: Relation model}
        {po_R: PreOrder Krelation}
        {DCSA: DownwardsClosedSeparationAlgebra model}
        {UCSA: UpwardsClosedSeparationAlgebra model}
        {Res: Resource}
        {Ac: Action}
        {Acr: Action_resource Ac Res}
        {nAcr: NormalAction_resource Ac Res}
        {TS: TraceSemantics P (resources * model) Ac}
        {AIr: ActionInterpret_resource model Ac Res ac_sem}
        {SAAIr: @SAActionInterpret_resource (resources * model) Ac ac_sem (@prod_Join _ _ (Pred_Join resource) J) (fun a => ~ is_resources_action a)}
        {KAIr: @KActionInterpret_resource (resources * model) Ac ac_sem (RelProd (discPred_R resource) R)}.

Instance KSAAIr: @KSAActionInterpret_resource (resources * model) Ac ac_sem (@prod_Join _ _ (Pred_Join resource) J) (RelProd (discPred_R resource) R) (fun a => ~ is_resources_action a) :=
  ordered_and_frame_AIr _ _ _.

Context {L: Language} {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {SL: SeparationLanguage L} {SM: Semantics L MD} {kiSM: KripkeIntuitionisticSemantics L MD tt SM} {fsSM: FlatSemantics.SeparatingSemantics L MD tt SM}.

Class LegalInvariants (Inv: resource * (model -> Prop) -> Prop): Prop := {
  at_most_one_invariant: forall r I1 I2, Inv (r, I1) -> Inv (r, I2) -> I1 = I2;
  invariant_mono: forall r I,  Inv (r, I) -> forall s1 s2, I s1 -> s1 <= s2 -> I s2;
  invariant_precise: forall r I, Inv (r, I) -> forall s,
    (exists s', (fun s' => exists f, I f /\ join s' f s) s') ->
    (exists s', greatest (fun s' => exists f, I f /\ join s' f s) s')
}.
(*
Definition ThreadLocal_KSA_AIr: forall (Inv: resource * (model -> Prop) -> Prop) {INV: LegalInvariants Inv}, @KSAActionInterpret_resource (resources * model) Ac (ThreadLocal_ActionInterpret_resource ac_sem Inv) (@prod_Join _ _ (Pred_Join resource) J) (RelProd (discPred_R resource) R).
  Check @lift_join.
 *)

Lemma ThreadLocal_ordered_frame_property (Inv: resource * (model -> Prop) -> Prop) {INV: LegalInvariants Inv}: forall (a: action) (m1 f n1' n1: resources * model) (n2: MetaState (resources * model)) fst_m2
    (ASSU: res_enable a (fst m1) fst_m2 (fst f) (*forall r, a = Arelease_res r -> ~ fst f r*)),
    @join _ (prod_Join _ _) m1 f n1' ->
    (RelProd (discPred_R _) R) n1' n1 ->
    thread_local_state_enable Inv a n1 n2  ->
    exists m2 n2', @lift_join _ (prod_Join _ _) m2 (Terminating f) n2' /\ @Partial.forward _ (RelProd (discPred_R _) R) n2' n2 /\ match m2 with Terminating m2 => fst m2 = fst_m2 | _ => True end /\ thread_local_state_enable Inv a m1 m2.
Proof.
  intros.
  destruct (classic (is_resources_action a)) as [[?r [? | ?]] | ?].
  + subst a.
    inversion H1; subst; solve_resource_action.
    rename m into n1, n into n2.
    destruct n1' as [A1' n1'], f as [Af f], m1 as [B1 m1].
    hnf in H; simpl in H; destruct H.
    hnf in H0; simpl in H0. destruct H0. hnf in H0, H7; simpl in H0, H7.
    pose proof join_Korder_down _ _ _ _ _ H6 H7 ltac:(reflexivity) as [n2' [? ?]].
    pose proof join_assoc _ _ _ _ _ (join_comm _ _ _ H2) H8 as [m2 [? ?]].
    assert (A1 = A1').
    Focus 1. {
      extensionality r0; apply prop_ext.
      apply iff_sym, H0.
    } Unfocus.
    subst A1'.
    pose proof join_assoc _ _ _ _ _ (join_comm _ _ _ H) H3 as [B2 [? ?]].
    exists (Terminating (B2, m2)), (Terminating (A2, n2')).
    split; [| split; [| split]].
    - constructor.
      split; apply join_comm; auto.
    - constructor; split; auto; simpl.
      hnf; intro; simpl; hnf; tauto.
    - apply res_enable_acq_inv in ASSU.
      simpl in ASSU; destruct ASSU as [? _].
      simpl; clear - H14 H12.
      extensionality r0; apply prop_ext.
      specialize (H12 r0); specialize (H14 r0); destruct H12, H14; tauto.
    - simpl.
      eapply thread_local_state_enable_acq; eauto.
  + subst a.
    destruct n1 as [A1 n1], n1' as [A1' n1'], f as [Af f], m1 as [B1 m1].
    hnf in H; simpl in H; destruct H.
    hnf in H0; unfold RelCompFun in H0; simpl in H0; destruct H0.
    assert (A1' = A1).
    Focus 1. {
      extensionality r0; apply prop_ext.
      apply H0.
    } Unfocus.
    subst A1'; clear H0.
    destruct (classic (forall I, Inv (r, I) -> exists m2, (fun m2 => exists f, I f /\ join m2 f m1) m2)).
    - inversion H1; subst; solve_resource_action.
      Focus 2. {
        exfalso.
        specialize (H0 _ H8).
        destruct H0 as [m2 [f0 [? ?]]].
        pose proof join_assoc _ _ _ _ _ (join_comm _ _ _ H4) H2 as [n2' [? ?]].
        pose proof join_Korder_up _ _ _ _ H6 H3 as [_f0 [n2 [? [? ?]]]].
        apply (H10 n2); clear H10.
        exists _f0; split; [eapply (invariant_mono _ _ H8); eauto | apply join_comm; auto].
      } Unfocus.
      specialize (H0 _ H8).
      apply (invariant_precise _ _ H8) in H0.
      destruct H0 as [m2 ?].
      destruct (proj1 H0) as [f0 [? ?]].
      pose proof join_assoc _ _ _ _ _ (join_comm _ _ _ H5) H2 as [n2' [? ?]].
      pose proof join_Korder_up _ _ _ _ H9 H3 as [_f0 [_n2 [? [? ?]]]].
      assert ((fun n : model => exists f : model, I f /\ join n f n1) _n2).
      Focus 1. { exists _f0; split; [eapply (invariant_mono _ _ H8); eauto | apply join_comm; auto]. } Unfocus.
      apply (proj2 H10) in H14.
      apply res_enable_rel_inv in ASSU; simpl in ASSU.
      rename fst_m2 into B2.
      exists (Terminating (B2, m2)), (Terminating (A2, n2')).
      split; [| split; [| split]].
      * constructor.
        split; auto.
        simpl.
        clear - ASSU H H7.
        intros r0; specialize (ASSU r0); specialize (H r0); specialize (H7 r0).
        destruct ASSU, H, H7; split; tauto.
      * constructor.
        split; [hnf; intros ?; hnf; tauto | change (n2' <= n); etransitivity; eauto].
      * auto.
      * simpl.
        eapply thread_local_state_enable_rel_succ; eauto.
    - exists Error, n2.
      split; [| split; [| split]].
      * constructor.
      * destruct n2; constructor.
        destruct p as [A2 n2].
        split; [hnf; intros ?; hnf; tauto | change (n2 <= n2); reflexivity].
      * auto.
      * apply Classical_Pred_Type.not_all_ex_not in H0; destruct H0 as [I ?].
        apply imply_to_and in H0; destruct H0.
        apply res_enable_rel_inv in ASSU; simpl in ASSU.
        eapply thread_local_state_enable_rel_fail; eauto.
  + rewrite <- (thread_local_state_enable_non_resource_action Inv) in H1 by auto.
    change ((fun a => ~ is_resources_action a) a) in H2.
    pose proof ordered_frame_property _ _ _ _ _ _ H2 H H0 H1 as [m2 [n2' [? [? ?]]]].
    exists m2, n2'.
    split; [| split; [| split]]; auto.
    - apply res_enable_not_res_inv in ASSU; auto.
      destruct m1 as [A1 m1], m2 as [| | [A2 m2]]; auto.
      simpl in H5.
      apply state_enable_non_resource_action1 in H5; auto.
      subst; auto.
    - simpl.
      rewrite <- (thread_local_state_enable_non_resource_action Inv) by auto.
      auto.
Qed.

Lemma hoare_parallel_partial_sound
      {CPP: ConcurrentProgrammingLanguage_Sparallel P}
      {AcP: Action_Parallel Ac}
      {nAcPr: NormalAction_Parallel_resource Ac Res}
      {c2tP: Command2Traces_Sparallel_resource P model Ac Res c2t}
      {AIPr: ActionInterpret_Parallel_resource model Ac Res ac_sem}:
  forall Inv c1 P1 Q1 c2 P2 Q2 (INV: LegalInvariants Inv),
  guarded_triple_partial_valid Inv P1 c1 Q1 ->
  guarded_triple_partial_valid Inv P2 c2 Q2 ->
  guarded_triple_partial_valid Inv (P1 * P2) (Sparallel c1 c2) (Q1 * Q2).
Proof.
  intros.
  rename H into LEFT_ASSU, H0 into RIGHT_ASSU.
  hnf in LEFT_ASSU, RIGHT_ASSU |- *; intros.
  unfold access, ThreadLocal_BSS in LEFT_ASSU, RIGHT_ASSU, H0; simpl in LEFT_ASSU, RIGHT_ASSU, H0.
  inversion H0; subst; clear H0.
  rewrite Sparallel_denote in H1.
  set (Tr1 := cmd_denote c1) in LEFT_ASSU, H1.
  set (Tr2 := cmd_denote c2) in RIGHT_ASSU, H1.
  clearbody Tr1 Tr2; clear c1 c2.
  inversion H1; subst; clear H1.
  set (A1 := fun _: resource => False) in LEFT_ASSU at 1, H4 at 1.
  set (A2 := fun _: resource => False) in RIGHT_ASSU at 1, H4 at 1.
  set (A := fun _: resource => False) in H2 at 1.
  rewrite sat_sepcon in H.
  destruct H as [s1 [s2 [? [? ?]]]].
  set (s0 := s_pre) in H.
  assert (STATE_JOIN: @join _ (prod_Join resources model) (A1, s1) (A2, s2) (A, s0)).
  Focus 1. {
    split; auto.
    hnf; intros r0.
    simpl; subst A1 A2 A; split; tauto.
  } Unfocus.
  assert (STATE_LE: @Krelation _ (RelProd (discPred_R resource) R) (A, s0) (A, s_pre)).
  Focus 1. {
    split; hnf; simpl.
    + intros; hnf; tauto.
    + change (s_pre <= s_pre).
      reflexivity.
  } Unfocus.
  clearbody A1 A2 A s0. clear H.
  specialize (fun ms_post HH => LEFT_ASSU s1 ms_post H1 (traces_access_intro tr1 _ _ _ H0 HH)).
  specialize (fun ms_post HH => RIGHT_ASSU s2 ms_post H5 (traces_access_intro tr2 _ _ _ H3 HH)).
  clear P1 P2 H1 H5 Tr1 Tr2 H0 H3.
  rename H2 into TRACE_ACC.
  revert s0 s1 s2 s_pre A LEFT_ASSU RIGHT_ASSU STATE_JOIN STATE_LE TRACE_ACC; induction H4; intros.
  + inversion TRACE_ACC; subst.
    destruct ms_post; subst; inversion H.
    subst m A.
    assert (A2 = fun _ => False).
    Focus 1. {
      extensionality r; apply prop_ext.
      destruct STATE_JOIN as [? _].
      hnf in H0. specialize (H0 r).
      simpl in H0; destruct H0.
      tauto.
    } Unfocus.
    assert (A1 = fun _ => False).
    Focus 1. {
      extensionality r; apply prop_ext.
      destruct STATE_JOIN as [? _].
      hnf in H1. specialize (H1 r).
      simpl in H1; destruct H1.
      tauto.
    } Unfocus.
    subst A1 A2.
    specialize (LEFT_ASSU (Terminating s1) (trace_access_nil _)); simpl in LEFT_ASSU.
    specialize (RIGHT_ASSU (Terminating s2) (trace_access_nil _)); simpl in RIGHT_ASSU.
    eapply sat_mono; [exact (proj2 STATE_LE) |].
    rewrite sat_sepcon.
    exists s1, s2.
    split; [| split]; auto.
    exact (proj2 STATE_JOIN).
  + exfalso.
    destruct (res_actions_no_race _ _ H).
    apply (state_enable_race_actions_spec a1 a2 A1 A2 s1 s2 s0); auto.
    - intro.
      rewrite (thread_local_state_enable_non_resource_action Inv) in H2 by auto.
      specialize (LEFT_ASSU Error (@trace_access_Error _ _ (ThreadLocal_ActionInterpret_resource _ Inv) _ _ _ H2)).
      inversion LEFT_ASSU.
    - intro.
      rewrite (thread_local_state_enable_non_resource_action Inv) in H2 by auto.
      specialize (RIGHT_ASSU Error (@trace_access_Error _ _ (ThreadLocal_ActionInterpret_resource _ Inv) _ _ _ H2)).
      inversion RIGHT_ASSU.
    - exact (proj2 STATE_JOIN).
  + change (res_enable a1 (fst (A1, s1)) A1' (fst (A2, s2))) in H.
    inversion TRACE_ACC; subst.
    - (* NonTerminating *)
      destruct ms_post; inversion H5; clear H5; auto.
    - (* Error *)
      pose proof ThreadLocal_ordered_frame_property Inv _ _ _ _ _ Error A1' H STATE_JOIN STATE_LE H3 as [Error' [Error'' [? [? [_ ?]]]]].
      inversion H1; subst; clear H1.
      inversion H0; subst; clear H0.
      simpl lift_function in H2.
      exfalso.
      apply (LEFT_ASSU Error).
      apply trace_access_Error; auto.
    - (* Terminating *)
      pose proof ThreadLocal_ordered_frame_property Inv _ _ _ _ _ (Terminating s') A1' H STATE_JOIN STATE_LE H2 as [m2 [n2' [? [? [? ?]]]]].
      destruct n2' as [| | n2']; inversion H1; subst.
      destruct m2 as [| | m2]; inversion H0; subst.
      * exfalso.
        apply (LEFT_ASSU Error).
        apply trace_access_Error; auto.
      * destruct s' as [A' s'], m2 as [A1' s1'], n2' as [A0' s0'].
        assert (A0' = A').
        Focus 1. {
          clear - H9. destruct H9 as [? _]; hnf in H; simpl in H.
          extensionality r0; apply prop_ext; apply H.
        } Unfocus.
        subst A0'.
        apply (IHtrace_interleave s0' s1' s2 s' A'); auto.
        intros.
        apply LEFT_ASSU.
        eapply trace_access_Terminating; eauto.
  + change (res_enable a2 (fst (A2, s2)) A2' (fst (A1, s1))) in H.
    inversion TRACE_ACC; subst.
    - (* NonTerminating *)
      destruct ms_post; inversion H5; clear H5; auto.
    - (* Error *)
      pose proof ThreadLocal_ordered_frame_property Inv _ _ _ _ _ Error A2' H (@join_comm _ _ (prod_SA _ _) _ _ _ STATE_JOIN) STATE_LE H3 as [Error' [Error'' [? [? [_ ?]]]]].
      inversion H1; subst; clear H1.
      inversion H0; subst; clear H0.
      simpl lift_function in H2.
      exfalso.
      apply (RIGHT_ASSU Error).
      apply trace_access_Error; auto.
    - (* Terminating *)
      pose proof ThreadLocal_ordered_frame_property Inv _ _ _ _ _ (Terminating s') A2' H (@join_comm _ _ (prod_SA _ _) _ _ _ STATE_JOIN) STATE_LE H2 as [m2 [n2' [? [? [? ?]]]]].
      destruct n2' as [| | n2']; inversion H1; subst.
      destruct m2 as [| | m2]; inversion H0; subst.
      * exfalso.
        apply (RIGHT_ASSU Error).
        apply trace_access_Error; auto.
      * destruct s' as [A' s'], m2 as [A2' s2'], n2' as [A0' s0'].
        assert (A0' = A').
        Focus 1. {
          clear - H9. destruct H9 as [? _]; hnf in H; simpl in H.
          extensionality r0; apply prop_ext; apply H.
        } Unfocus.
        subst A0'.
        apply (IHtrace_interleave s0' s1 s2' s' A'); auto.
        intros.
        apply RIGHT_ASSU.
        eapply trace_access_Terminating; eauto.
        apply (@join_comm _ _ (prod_SA _ _)); auto.
Qed.

Lemma SRA_triple_spec
      {c2tSRA: StructuralResourceAccess P Ac Res c2t}:
  forall (Inv: (resource * (model -> Prop)) -> Prop) (Pre: expr) (c: cmd) (Post: expr),
     guarded_triple_partial_valid Inv Pre c Post <->
     (forall s_pre A_post ms_post, KRIPKE: s_pre |= Pre -> @traces_access _ _ (ThreadLocal_ActionInterpret_resource _ Inv) (cmd_denote c) (fun _ => False, s_pre) (lift_function (pair A_post) ms_post) -> match ms_post with | Error => False | NonTerminating => True | Terminating s_post => KRIPKE: s_post |= Post end).
Proof.
  intros.
  split.
  + intros.
    hnf in H.
    inversion H1; subst.
    replace (lift_function (pair A_post) ms_post) with (lift_function (pair (fun _:resource => False)) ms_post) in H3.
    Focus 2. {
      destruct ms_post as [| | ms_post]; auto.
      simpl lift_function in H3.
      eapply start_by_Aacq_trace_acc_spec in H3; [subst; auto |].
      intros; eapply resource_sequential; eauto.
    } Unfocus.
    apply (H s_pre ms_post); auto.
    apply (traces_access_intro tr); auto.
  + intros.
    hnf; intros.
    apply (H s_pre (fun _ => False) ms_post); auto.
Qed.

Lemma hoare_resource_block_partial_sound
      {CPP: ConcurrentProgrammingLanguage_Sresource P Res}
      {c2tR: Command2Traces_Sresource P Ac Res c2t}
      {c2tSRA: StructuralResourceAccess P Ac Res c2t}:
  forall Inv0 Inv1 r P1 P2 c I dI (INV: LegalInvariants Inv1),
  @join _ (Pred_Join _) Inv0 (eq (r, dI)) Inv1 ->
  (dI = fun m => KRIPKE: m |= I) ->
  resource_no_occur r (cmd_denote c) ->
  guarded_triple_partial_valid Inv0 (P1 * I) c (P2 * I) ->
  guarded_triple_partial_valid Inv1 P1 (Sresource r c) P2.
Proof.
  intros.
  subst dI.
  rewrite SRA_triple_spec in H2 |- *.
  rename H into INV_CONS, H1 into NO_OCCUR.
  rename H2 into ASSU; intros.
  unfold access, ThreadLocal_BSS in ASSU, H0; simpl in ASSU, H0.
  inversion H0; subst; clear H0.
  rewrite Sresource_denote in H1.
  set (Tr := cmd_denote c) in ASSU, H1, NO_OCCUR.
  clearbody Tr; clear c.
  inversion H1; subst; clear H1.
  inversion H3; subst; clear H3.
  unfold singleton_traces, singleton_trace in H0, H4.
  subst tr1 tr3; rename tr0 into tr.
  specialize (fun s A_post ms_post _H HH => ASSU s A_post ms_post _H (traces_access_intro tr _ _ _ H1 HH)).
  specialize (NO_OCCUR _ H1).
  clear Tr H1.
  unfold trace_app in H2; simpl app in H2; inversion H2; subst; clear H2.
  Focus 1. { exfalso; inversion H4; subst; solve_resource_action. } Unfocus.
  Focus 1. { exfalso; inversion H4; subst; solve_resource_action. } Unfocus.
  inversion H3; subst; clear H3; solve_resource_action.
  assert (I0 = fun m => KRIPKE: m |= I).
  Focus 1. {
    clear - INV_CONS INV H7.
    apply (at_most_one_invariant r); auto.
    specialize (INV_CONS (r, fun m => m |= I)).
    destruct INV_CONS; simpl in *.
    tauto.
  } Unfocus.
  subst I0.
  assert (KRIPKE: n |= P1 * I).
  Focus 1. {
    rewrite sat_sepcon.
    exists s_pre, f; auto.
  } Unfocus.
  clear f s_pre H8 H9 H.
  rename n into s.
  specialize (fun A_post ms_post => ASSU s A_post ms_post H0); clear H0 P1.

  set (A1 := fun _ => False) in H5, ASSU at 1.
  clearbody A1.
  rename H5 into JOIN_RES, H6 into TRACE_ACC, H7 into Inv_r.

  revert A1 A2 s JOIN_RES TRACE_ACC ASSU; induction tr; intros.
  + simpl in TRACE_ACC.
    specialize (ASSU A1 (Terminating s) (trace_access_nil _)).
    change (KRIPKE: s |= P2 * I) in ASSU.
    rewrite sat_sepcon in ASSU.
    destruct ASSU as [s' [f [? [? ?]]]].
    assert ((fun n : model => exists f : model, KRIPKE: f |= I /\ join n f s) s') by (exists f; auto).
    inversion TRACE_ACC; subst.
    - inversion H6; subst; solve_resource_action.
    - inversion H6; subst; solve_resource_action.
      pose proof at_most_one_invariant _ _ _ H9 Inv_r; subst I0; clear H9.
      exfalso; apply (H10 s').
      exists f; auto.
    - inversion H5; subst; solve_resource_action.
      pose proof at_most_one_invariant _ _ _ H10 Inv_r; subst I0; clear H10.
      apply (proj2 H11) in H2.
      eapply sat_mono in H0; [| exact H2].
      inversion H8; subst.
      destruct ms_post; inversion H3; subst.
      auto.
  + simpl in TRACE_ACC.
    assert (forall ms, thread_local_state_enable Inv1 a (A2, s) ms ->
                       match ms with
                       | Error => thread_local_state_enable Inv0 a (A1, s) Error
                       | NonTerminating => thread_local_state_enable Inv0 a (A1, s) NonTerminating
                       | Terminating (A2', s') => exists A1', join A1' (eq r) A2' /\ thread_local_state_enable Inv0 a (A1, s) (Terminating (A1', s'))
                       end).
    Focus 1. {
      clear - INV_CONS INV NO_OCCUR JOIN_RES AIr.
      intros.
      assert (~ is_resource_action r a).
      Focus 1. {
        intros [? | ?].
        + subst; apply (proj1 NO_OCCUR).
          left; auto.
        + subst; apply (proj2 NO_OCCUR).
          left; auto.
      } Unfocus.
      clear NO_OCCUR; rename H0 into NO_OCCUR.
      inversion H; subst; solve_resource_action.
      + assert (Inv0 (r0, I0)).
        Focus 1. {
          specialize (INV_CONS (r0, I0)).
          assert ((r, fun m : model => KRIPKE: m |= I) <> (r0, I0)) by congruence.
          destruct INV_CONS; tauto.
        } Unfocus.
        rename A3 into A2'.
        pose proof join_assoc _ _ _ _ _ (join_comm _ _ _ JOIN_RES) H2 as [A1' [? ?]].
        apply join_comm in H4.
        exists A1'; split; auto.
        eapply (thread_local_state_enable_acq _ _ _ _ _ _ _ _ H1 H0 H5 H7).
      + assert (Inv0 (r0, I0)).
        Focus 1. {
          specialize (INV_CONS (r0, I0)).
          assert ((r, fun m : model => KRIPKE: m |= I) <> (r0, I0)) by congruence.
          destruct INV_CONS; tauto.
        } Unfocus.
        rename A3 into A2'.
        set (A1' := fun rr => A2' rr /\ r <> rr).
        assert (join A1' (eq r) A2').
        Focus 1. {
          subst A1'; intros rr; specialize (H2 rr); specialize (JOIN_RES rr).
          assert (r0 = rr -> r = rr -> False) by (intros; congruence).
          destruct H2, JOIN_RES; split; tauto.
        } Unfocus.
        assert (join A1' (eq r0) A1).
        Focus 1. {
          subst A1'; intros rr; specialize (H2 rr); specialize (JOIN_RES rr).
          assert (r0 = rr -> r = rr -> False) by (intros; congruence).
          destruct H2, JOIN_RES; split; tauto.
        } Unfocus.
        exists A1'; split; auto.
        eapply (thread_local_state_enable_rel_succ _ _ _ _ _ _ _ H3 H0 H6).
      + assert (Inv0 (r0, I0)).
        Focus 1. {
          specialize (INV_CONS (r0, I0)).
          assert ((r, fun m : model => KRIPKE: m |= I) <> (r0, I0)) by congruence.
          destruct INV_CONS; tauto.
        } Unfocus.
        rename A3 into A2'.
        set (A1' := fun rr => A2' rr /\ r <> rr).
        assert (join A1' (eq r) A2').
        Focus 1. {
          subst A1'; intros rr; specialize (H2 rr); specialize (JOIN_RES rr).
          assert (r0 = rr -> r = rr -> False) by (intros; congruence).
          destruct H2, JOIN_RES; split; tauto.
        } Unfocus.
        assert (join A1' (eq r0) A1).
        Focus 1. {
          subst A1'; intros rr; specialize (H2 rr); specialize (JOIN_RES rr).
          assert (r0 = rr -> r = rr -> False) by (intros; congruence).
          destruct H2, JOIN_RES; split; tauto.
        } Unfocus.
        eapply (thread_local_state_enable_rel_fail _ _ _ _ _ _ H3 H0 H6).
      + destruct ms as [| | [A2' s']].
        - eapply thread_local_state_enable_non_resource; auto.
          change Error with (lift_function (pair A1) (@Error model)).
          change Error with (lift_function (pair A2) (@Error model)) in H1.
          apply (state_enable_non_resource_action2 _ _ _ _ _ H0 H1).
        - eapply thread_local_state_enable_non_resource; auto.
          change NonTerminating with (lift_function (pair A1) (@NonTerminating model)).
          change NonTerminating with (lift_function (pair A2) (@NonTerminating model)) in H1.
          apply (state_enable_non_resource_action2 _ _ _ _ _ H0 H1).
        - pose proof state_enable_non_resource_action1 _ _ _ _ _ H0 H1; subst A2'.
          exists A1.
          split; auto.
          eapply thread_local_state_enable_non_resource; auto.
          change (Terminating (A2, s')) with (lift_function (pair A2) (Terminating s')) in H1.
          apply (state_enable_non_resource_action2 _ _ _ _ _ H0 H1).
    } Unfocus.
    inversion TRACE_ACC; subst.
    - destruct ms_post; inversion H4; auto.
    - simpl in H3.
      apply H in H3.
      specialize (ASSU A1 Error (@trace_access_Error _ _ (ThreadLocal_ActionInterpret_resource _ Inv0) _ _ _ H3)).
      inversion ASSU.
    - simpl in H2.
      apply H in H2.
      destruct s' as [A2' s'].
      destruct H2 as [A1' [? ?]].
      assert (~ In (Aacquire_res r) tr /\ ~ In (Arelease_res r) tr)
        by (simpl in NO_OCCUR; tauto).
      apply (IHtr H2 A1' A2' s'); auto; clear H2 ms_post IHtr TRACE_ACC H5 A_post.
      intros.
      apply (ASSU A_post ms_post).
      eapply trace_access_Terminating; eauto.
Qed.

End soundness.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^414 - 17
Base: 24 + 6/17
***)

Definition curve : CurveParameters :=
  {|
    sz := 17%nat;
    base := 24 + 6/17;
    bitwidth := 32;
    s := 2^414;
    c := [(1, 17)];
    carry_chains := Some [seq 0 (pred 17); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^221 - 3
Base: 44.2
***)

Definition curve : CurveParameters :=
  {|
    sz := 5%nat;
    base := 44 + 1/5;
    bitwidth := 64;
    s := 2^221;
    c := [(1, 3)];
    carry_chains := Some [seq 0 (pred 5); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


From Coq Require Import ZArith.
From stdpp Require Import base.
From cap_machine Require Export machine_base.

Class MachineParameters := {
  decodeInstr : Z → instr;
  encodeInstr : instr → Z;

  decode_encode_instr_inv :
    forall (i: instr), decodeInstr (encodeInstr i) = i;

  encodePerm : Perm → Z;
  encodePerm_inj : Inj eq eq encodePerm;

  encodeLoc : Locality → Z;
  encodeLoc_inj : Inj eq eq encodeLoc;

  decodePermPair : Z → Perm * Locality;
  encodePermPair : Perm * Locality → Z;

  decode_encode_permPair_inv :
    forall pl, decodePermPair (encodePermPair pl) = pl;
}.

(* Lift the encoding / decoding between Z and instructions on Words: simplify
   fail on capabilities. *)

Definition decodeInstrW `{MachineParameters} : Word → instr :=
  fun w =>
    match w with
    | inl z => decodeInstr z
    | inr _ => Fail
    end.

Definition encodeInstrW `{MachineParameters} : instr → Word :=
  fun i => inl (encodeInstr i).

Lemma decode_encode_instrW_inv `{MachineParameters} (i: instr):
  decodeInstrW (encodeInstrW i) = i.
Proof. apply decode_encode_instr_inv. Qed.


Require Export Foundations.hlevel2.hSet.
Require Export carrier.

Definition preextensionAlg ( x : ecarrier ) : UU :=
  total2
    ( fun e0 : eF x -> eC x =>
        ( total2
            ( fun e1 : hfp e0 (eft x) -> eF x =>
                dirprod
                  ( forall ( P : hfp e0 (eft x) ),
                      eft x (e1 P) = eft x (pr1 (pr1 P))
                  )
                  ( forall ( P : hfp e0 (eft x) ),
                      e0 (e1 P) = e0 (pr2 (pr1 P))
                  )
            )
        )
    ).

Definition preextensionAlg_construct ( x : ecarrier ) ( e0 : eF x -> eC x )
           ( e1 : hfp e0 (eft x) -> eF x )
           ( codeq : forall ( P : hfp e0 (eft x) ), eft x (e1 P) = eft x (pr1 (pr1 P)) )
           ( domeq : forall ( P : hfp e0 (eft x) ), e0 (e1 P) = e0 (pr2 (pr1 P)))
           : preextensionAlg x.
  Proof.
  refine (tpair _ _ _).
  exact e0.
  refine (tpair _ _ _).
  exact e1.
  refine (tpair _ _ _); intro P.
  exact (codeq P).
  exact (domeq P).
  Qed.

Definition ectxext { x : ecarrier } ( CFT : preextensionAlg x ) : eF x -> eC x :=
  pr1 CFT.

Definition eF2 { x : ecarrier } ( CFT : preextensionAlg x ) : UU :=
  hfp (ectxext CFT) (eft x).

Definition efamext { x : ecarrier } ( CFT : preextensionAlg x ) : eF2 CFT -> eF x :=
  pr1 (pr2 CFT).

Definition eft2 { x : ecarrier } ( CFT : preextensionAlg x ) : eF2 CFT -> eF x :=
  fun AP => pr1 (pr1 AP).

Definition eextcodeq { x : ecarrier } ( CFT : preextensionAlg x) ( P : eF2 CFT ) :
  eft x (efamext CFT P) = eft x (eft2 CFT P) :=
  (pr1 (pr2 (pr2 CFT))) P.

Definition eextdomeq { x : ecarrier } ( CFT : preextensionAlg x) ( P : eF2 CFT ) :
  ectxext CFT (efamext CFT P) = ectxext CFT (pr2 (pr1 (P))) :=
  (pr2 (pr2 (pr2 CFT))) P.

Definition eF3 { x : ecarrier } ( CFT : preextensionAlg x ) : UU :=
  hfp (efamext CFT) (eft2 CFT).

Definition eft3 { x : ecarrier } ( CFT : preextensionAlg x ) : eF3 CFT -> eF2 CFT :=
  fun APQ => pr1 (pr1 APQ).

Definition emixpr2 { x : ecarrier } ( CFT : preextensionAlg x ) (APQ : eF3 CFT) : eF2 CFT.
  Proof.
    destruct APQ as [[[[A P] s0] [[AP Q] s1]] s2].
    refine (tpair _ _ _).
    refine (tpair _ _ _).
    exact P. exact Q.
    simpl in *.
    rewrite s1.
    unfold eft2 in s2. simpl in *.
    rewrite s2.
    refine (eextdomeq CFT _).
  Qed.

Definition eext2 { x : ecarrier } ( CFT : preextensionAlg x ) : eF3 CFT -> eF2 CFT.
  intros [[[[A P] s0] [[AP Q] s1]] s2].
  refine (tpair _ _ _).
  refine (tpair _ _ _).
  exact A.
  refine (efamext CFT _).
  refine (tpair _ _ _).
  refine (tpair _ _ _).
  exact P.
  exact Q.
  unfold eft2 in s2.
  simpl in *.
  rewrite s1.
  rewrite s2.
  refine (eextdomeq CFT _).
  unfold eft2 in *.
  simpl in *.
  rewrite (eextcodeq CFT _).
  unfold eft2. simpl.
  exact s0.
  Qed.

Definition preextFamAlg { x : ecarrier } ( CFT : preextensionAlg x ) :
  total2 preextensionAlg.
  Proof.
  refine (tpair _ _ _).
  refine (ecarrier_construct _ _ _ _ _).
  exact (eF x).
  admit.
  Qed.