Require Import Coq.Logic.Decidable.
Require Import PeanoNat.
Require Import Coq.Strings.String.
Require Import Ascii.
Require Import Bool.
Require Import Nat.
Require Import Coq.Program.Equality.

Require Import LIR.maps.

(*
** Tags for Lir
*)
Inductive Tag : Set := | TgNil | TgInt | TgTbl | TgFun.

(* Tag equality is decidable and computable *)
Lemma dec_Tag : forall (t1 t2 : Tag), {t1 = t2} + {t1 <> t2}.
Proof. decide equality. Defined.

(*
** Types for Lir
*)
Inductive IRType : Set :=
| Tag2Type : Tag  -> IRType
| IRTStar : IRType
.

(* Type equality is decidable and computable *)
Lemma dec_IRType : forall (t1 t2 : IRType), {t1 = t2} + {t1 <> t2}.
Proof. decide equality. auto using dec_Tag. Defined.

Definition Type2Tag (t : IRType) : option Tag :=
  match t with
  | Tag2Type tg => Some tg
  | IRTStar => None
  end.

Definition IRTNil := Tag2Type TgNil.
Definition IRTInt := Tag2Type TgInt.
Definition IRTTbl := Tag2Type TgTbl.
Definition IRTFun := Tag2Type TgFun.

(*
** Addresses represent tables and functions in memory
*)
Definition address := nat.

(*
** Syntax for Lir expressions
*)
Inductive IRE : Set :=
| IRENil : IRE		(* nil *)
| IRENum : nat -> IRE	(* n - integer literals *)
| IREPlus : IRE -> IRE -> IRE	(* e + e *)
| IRENew : IRE		(* {} - table constructor *)
| IRETAddr : address -> IRE  (* table address - only at runtime *)
| IREFAddr : address -> IRE  (* function address - only at runtime *)
| IREGet : IRE -> IRE -> IRE	(* e[e] - table access *)
| IRESet : IRE -> IRE -> IRE -> IRE	(* e[e] := e - table assignment *)
| IREVar : string -> IRE	(* id - variables *)
| IRELet : string -> IRType -> IRE -> IRE -> IRE  (* let e:τ = e in e *)
| IREFun : string -> IRE -> IRE		(* λx. e *)
| IREApp : IRE -> IRE -> IRE	(* e e *)
| IREBox : Tag -> IRE -> IRE	(* box[τ] e *)
| IREUnbox : Tag -> IRE -> IRE	(* unbox[τ] e *)
.

(*
Coercion IRENum : nat >-> IRE.
Coercion IREVar : string >-> IRE.

Declare Custom Entry IRE.

Declare Scope IRE_scope.

Notation "'<{' e '}>'" := e
    (at level 0, e custom IRE at level 99) : IRE_scope.
Notation "( x )" := x (in custom IRE, x at level 99) : IRE_scope.
Notation "x" := x (in custom IRE at level 0, x constr at level 0) : IRE_scope.
Notation "f x" := (IREApp f x)
                  (in custom IRE at level 0,
                  f constr at level 0, x constr at level 9) : IRE_scope.
Notation "x + y" := (IREPlus x y)
   (in custom IRE at level 50, left associativity).
Notation "x '[' y ']'" := (IREGet x y)
    (in custom IRE at level 80).
Notation "x '[' y ']' '=' z" := (IRESet x y z)
    (in custom IRE at level 80, z at level 90).
Notation "{}" := (IRENew) (in custom IRE at level 100).
Notation "'λ' x ':' t '.' e" := (IREFun x t e)
    (in custom IRE at level 100, e at level 110).
Notation "'box[' t '](' x ')'" := (IREBox t x)
    (in custom IRE at level 100).
Notation "'unbox[' t '](' x ')'" := (IREUnbox t x)
    (in custom IRE at level 100).

(* just for examples *)
Definition X := "X"%string.
Definition F := "F"%string.

Open Scope IRE_scope.

Unset Printing Notations.
Set Printing Coercions.
Check <{ X[0] = X[0] + 1 }>.
Unset Printing Coercions.
Set Printing Notations.
Check <{ X[0] = X[0] + 1 }>.

*)

(* Type environments for Lir *)
Definition IREnvironment := Map IRType.

(*
** Typing rules for Lir expressions
*)
Reserved Notation "Γ '|=' e ':' t"  (at level 40, no associativity,
                                     e at next level).

Inductive IRTyping : IREnvironment -> IRE -> IRType -> Prop :=
| IRTyNil : forall Γ, Γ |= IRENil : IRTNil
| IRTyVar : forall Γ var T,
    In Γ var = Some T ->
    Γ |= IREVar var : T
| IRTyInt : forall Γ n, Γ |= IRENum n : IRTInt
| IRTyPlus : forall Γ e1 e2,
    Γ |= e1 : IRTInt ->
    Γ |= e2 : IRTInt ->
    Γ |= (IREPlus e1 e2) : IRTInt
| IRTyNew : forall Γ, Γ |= IRENew : IRTTbl
| IRTyTAddr : forall Γ addr, Γ |= IRETAddr addr : IRTTbl
| IRTyFAddr : forall Γ addr, Γ |= IREFAddr addr : IRTFun
| IRTyGet : forall Γ e1 e2,
    Γ |= e1 : IRTTbl ->
    Γ |= e2 : IRTStar ->
    Γ |= (IREGet e1 e2) : IRTStar
| IRTySet : forall Γ e1 e2 e3,
    Γ |= e1 : IRTTbl ->
    Γ |= e2 : IRTStar ->
    Γ |= e3 : IRTStar ->
    Γ |= (IRESet e1 e2 e3) : IRTNil
| IRTyLet : forall Γ var t t' v body,
    var |=> t; Γ |= body : t' ->
    Γ |= v : t ->
    Γ |= (IRELet var t v body) : t'
| IRTyFun : forall Γ var body,
    var |=> IRTStar; Γ |= body : IRTStar ->
    Γ |= (IREFun var body) : IRTFun
| IRTyApp : forall Γ e1 e2,
    Γ |= e1 : IRTFun ->
    Γ |= e2 : IRTStar ->
    Γ |= (IREApp e1 e2) : IRTStar
| IRTyBox : forall Γ e (tg : Tag),
    Γ |= e : (Tag2Type tg) ->
    Γ |= (IREBox tg e) : IRTStar
| IRTyUnbox : forall Γ e tg t,
    t = Tag2Type tg ->
    Γ |= e : IRTStar ->
    Γ |= (IREUnbox tg e) : t

where "Γ '|=' e ':' t" := (IRTyping Γ e t)
.

(*
** Types for Lir expressions are unique
*)
Theorem typeUnique : forall Γ e t t',
   (Γ  |= e : t) -> (Γ |= e : t') -> t = t'.
Proof.
  induction 1; inversion 1; subst; auto; congruence.
Qed.

Unset Elimination Schemes.

(*
** Value predicate for Lir expressions: The only values are nil,
** numbers, and addresses, plus a box of one of those previous values.
** (The type system forbids boxes of boxes.)
*)
Inductive Value : IRE -> Prop :=
| Vnil : Value IRENil
| Vnum : forall n, Value (IRENum n)
| Vtbl : forall a, Value (IRETAddr a)
| Vfun : forall a, Value (IREFAddr a)
| Vbox : forall gt v, Value v -> Value (IREBox gt v)
.

Set Elimination Schemes.

Scheme Value_ind := Induction for Value Sort Prop.

Lemma Value_unique: forall v (Vv1 Vv2 : Value v), Vv1 = Vv2.
Proof.
  intros.
  dependent induction Vv1;
  dependent destruction Vv2; trivial.
  f_equal; auto.
Qed.

(*
** Equivalent to 'Value', but computable
*)
Fixpoint isValue (e : IRE) : bool :=
  match e with
  | IRENil => true
  | IRENum _ => true
  | IRETAddr _ => true
  | IREFAddr _ => true
  | IREBox _ e => isValue e
  | _ => false
  end.

Lemma isValueCorrect : forall e, Value e <-> isValue e = true.
Proof.
  split; induction e; trivial;
  inversion 1; subst; auto using Value.
Qed.

Lemma valBoxVal : forall gt e, Value (IREBox gt e) -> Value e.
Proof.
  inversion 1; trivial.
Qed.

(*
** Canonical forms
*)

Lemma valnil : forall Γ e,
  Γ |= e : IRTNil -> Value e -> e = IRENil.
Proof.
  inversion 1; inversion 1; subst; congruence.
Qed.

Lemma valint : forall Γ e,
    Γ |= e : IRTInt -> Value e -> exists n, e = IRENum n.
Proof.
  inversion 1; inversion 1; try discriminate.
  eexists; auto 1.
Qed.

Lemma valtbl : forall Γ e,
    Γ |= e : IRTTbl -> Value e -> exists a, e = IRETAddr a.
Proof.
  inversion 1; inversion 1; try discriminate; eauto.
Qed.

Lemma valfun : forall Γ e,
    Γ |= e : IRTFun -> Value e -> exists a, e = IREFAddr a.
Proof.
  inversion 1; inversion 1; try discriminate; eauto.
Qed.

Lemma valbox : forall Γ e, Γ |= e : IRTStar -> Value e ->
    exists o t, e = IREBox t o /\ (Γ |= o : Tag2Type t) /\ Value o.
Proof.
  intros * HT HV.
  inversion HV;
  inversion HT; subst; try discriminate.
  match goal with
  | [H: IREBox _ _ = IREBox _ _ |- _ ] => injection H; intros; subst end.
  eexists; eexists; auto using Value.
Qed.

(*
** Table indices. Only values are used as table indices, but we will
** allow any expression for now. For values, the index has a 'nat',
** good for numbers and addresses, and a tag.
*)
Inductive Index : Set :=
| I : nat -> Tag -> Index
| NI : Index   (* indices for non-values *)
.

(*
** Normalize values used as indices, so that boxed and unboxed values
** give the same index. Later we will prove that for two values, their
** indices are equal iff they are equal up to boxes and unboxes.
*)
Fixpoint ToIndex (e : IRE) : Index :=
  match e with
  | IRENil => I 0 TgNil
  | IRENum n => I n TgInt
  | IRETAddr a => I a TgTbl
  | IREFAddr a => I a TgFun
  | IREBox t e' => ToIndex e'
  | IREUnbox t e' => ToIndex e'
  | _ => NI
  end.

Lemma Index_dec : forall (i1 i2 : Index), {i1 = i2} + {i1 <> i2}.
Proof.
  decide equality; auto using Nat.eq_dec, dec_Tag.
Defined.

Ltac breakIndexDec :=
  repeat match goal with
  | [ |- context C [Nat.eq_dec ?V1 ?V2] ] =>
    destruct (Nat.eq_dec V1 V2)
  | [ |- context C [Index_dec ?V1 ?V2] ] =>
    destruct (Index_dec V1 V2) eqn:? ;
  try easy
  | [ H : context C [Nat.eq_dec ?V1 ?V2] |- _] =>
    destruct (Nat.eq_dec V1 V2); subst
  end.

(*
** Type representing expressions that are values
*)
Inductive ExpValue : Set :=
| EV : forall e, Value e -> ExpValue.

(* Extract the expression from an ExpValue *)
Definition EV2Val (me : ExpValue) : IRE :=
  match me with
  | EV v _ => v
  end.

(*
** Memory for Lir.
*)
Inductive Mem : Set :=
| EmptyMem : Mem
| UpdateT :  (* table entries *)
    address -> Index -> ExpValue -> Mem -> Mem
| UpdateF :  (* closures *)
    address -> string -> IRE -> Mem -> Mem.

Definition BoxedNil : IRE := IREBox TgNil IRENil.

Definition BoxedNilValue : Value BoxedNil := Vbox TgNil IRENil Vnil.

(*
** Get the memory content of a table entry
*)
Fixpoint queryT (a : address) (idx : IRE) (m : Mem) : IRE :=
  match m with
  | EmptyMem => BoxedNil
  | UpdateT a' idx' v m' => if Nat.eq_dec a a' then
                                    if Index_dec (ToIndex idx) idx'
                                      then (EV2Val v)
                                      else queryT  a idx m'
                                  else queryT a idx m'
  | UpdateF _ _ _ m' => queryT a idx m'
  end.

Lemma queryTIndexEq : forall m a idx idx',
  ToIndex idx = ToIndex idx' ->
  queryT a idx m = queryT a idx' m.
Proof.
  intros * HEq.
  induction m; trivial.
  simpl.
  breakIndexDec; subst; trivial;
  exfalso; auto.
Qed.

(*
** Get the memory content for closures
*)
Fixpoint queryF (a : address) (m : Mem) : (string * IRE) :=
  match m with
  | EmptyMem => (""%string, IRELet "" IRTStar (IREVar "") BoxedNil)
  | UpdateT a' _ _ m' => queryF a m'
  | UpdateF a' var body m' => if Nat.eq_dec a a' then (var, body)
                              else queryF a m'
  end.

(*
** Create a fresh address for a memory
*)
Fixpoint freshaux (m : Mem) : address :=
  match m with
  | EmptyMem => 1
  | UpdateT _ _ _ m' => S (freshaux m')
  | UpdateF _ _ _ m' => S (freshaux m')
  end.

(*
** Create a fresh address for a table and initializes
** it with {Nil = Nil}.
*)
Definition freshT (m : Mem) : (address * Mem) :=
  let f := freshaux m in
    (f, UpdateT f (ToIndex IRENil) (EV BoxedNil BoxedNilValue) m).

(*
** Create a fresh address for a function and initializes
** it with the given values.
*)
Definition freshF (m : Mem) (v : string) (b : IRE) : (address * Mem) :=
  let f := freshaux m in
    (f, UpdateF f v b m).

(*
** Substitution by closed Lir expressions
*)
Reserved Notation "'[' x ':=' s ']' t" (at level 20, x constr).

Fixpoint substitution (var : string) (y : IRE)  (e : IRE) : IRE :=
 match e with
 | IRENil => e
 | IRENum n => e
 | IREPlus e1 e2 => IREPlus ([var := y] e1) ([var := y] e2)
 | IRENew => e
 | IRETAddr a => e
 | IREFAddr a => e
 | IREGet e1 e2 => IREGet ([var := y] e1) ([var := y] e2)
 | IRESet e1 e2 e3 => IRESet ([var := y] e1) ([var := y] e2) ([var := y] e3)
 | IREVar var' => if string_dec var var' then y else e
 | IRELet var' t v body => if string_dec var var' then
                             IRELet var' t ([var := y] v) body
                           else
                             IRELet var' t ([var := y] v) ([var := y] body)
 | IREFun var' body  => if string_dec var var' then e
                    else IREFun var' ([var := y] body)
 | IREApp e1 e2 => IREApp ([var := y] e1) ([var := y] e2)
 | IREBox tg e  => IREBox tg ([var := y] e)
 | IREUnbox tg e  => IREUnbox tg ([var := y] e)
end
where "'[' x ':=' s ']' t" := (substitution x s t)
.

(*
** Extending an environment preserves typing
*)
Lemma inclusion_typing : forall Γ Γ' e te,
  Γ |= e : te ->
  inclusion Γ Γ' ->
  Γ' |= e : te.
Proof.
  intros * Hty Hin.
  generalize dependent Γ'.
  induction Hty; eauto using IRTyping, inclusion_update.
Qed.

(*
** Particular case when extending the empty environment
*)
Lemma typing_empty : forall Γ e te, MEmpty |= e : te -> Γ |= e : te.
Proof.
  eauto using inclusion_typing, inclusion_empty.
Qed.

(*
** Substitution preserves typing
*)
Lemma subst_typing : forall e2 Γ var tv te e1,
  (var |=> tv; Γ) |= e2 : te ->
  MEmpty |= e1 : tv ->
       Γ |= ([var := e1] e2) : te.
Proof.
  induction e2; intros * HT2 HT1;
  simpl; inversion HT2; subst;
  breakStrDec;
  eauto 6 using inclusion_typing, inclusion_shadow, inclusion_permute,
    IRTyping, typing_empty, InNotEq.
  - replace te with tv by congruence.
    eauto using typing_empty.
Qed.

(*
** Evaluation steps for Lir expressions
*)
Reserved Notation "m '/' e --> m1 '/' e1"
(at level 40, e at level 39, m1 at level 39, e1 at level 39).
Reserved Notation "m '/' e --> 'fail'"
(at level 40, e at level 39).

Inductive step : Mem -> IRE -> Mem -> IRE -> Prop :=
| StPlus1 : forall m e1 e2 m' e1',
    m / e1 --> m' / e1' ->
    m / IREPlus e1 e2 --> m' / IREPlus e1' e2
| StPlus2 : forall m e1 e2 m' e2',
    Value e1 ->
    m / e2 --> m' / e2' ->
    m /  IREPlus e1 e2 --> m' /  IREPlus e1 e2'
| StPlus : forall m n1 n2,
    m /  IREPlus (IRENum n1) (IRENum n2) --> m /  IRENum (n1 + n2)
| StNew : forall m m' free,
    (free, m') = freshT m ->
    m / IRENew --> m' / IRETAddr free
| StGet1 : forall m e1 e2 m' e1',
    m /e1 --> m' /e1' ->
    m / IREGet e1 e2 --> m' / IREGet e1' e2
| StGet2 : forall m e1 e2 m' e2',
    Value e1 ->
    m /e2 --> m' /e2' ->
    m / IREGet e1 e2 --> m' / IREGet e1 e2'
| StGet : forall m a idx,
    Value idx ->
    m / IREGet (IRETAddr a) idx --> m / queryT a idx m
| StSet1 : forall m e1 e2 e3 m' e1',
    m / e1 --> m' / e1' ->
    m / IRESet e1 e2 e3 --> m' / IRESet e1' e2 e3
| StSet2 : forall m e1 e2 e3 m' e2',
    Value e1 ->
    m / e2 --> m' / e2' ->
    m / IRESet e1 e2 e3 --> m' / IRESet e1 e2' e3
| StSet3 : forall m e1 e2 e3 m' e3',
    Value e1 -> Value e2 ->
    m / e3 --> m' / e3' ->
    m / IRESet e1 e2 e3 --> m' / IRESet e1 e2 e3'
| StSet : forall m a idx v,
    Value idx ->
    forall Vv : Value v,
    m / IRESet (IRETAddr a) idx v -->
            UpdateT a (ToIndex idx) (EV v Vv) m / IRENil
| StLet1 : forall var t body m e m' e',
    m / e --> m' / e' ->
    m / IRELet var t e body --> m' / IRELet var t e' body
| StLet : forall var t e body m,
    Value e ->
    m / IRELet var t e body --> m / [var := e] body
| StFun : forall m m' v b free,
    (free, m') = freshF m v b ->
    m / IREFun v b --> m' / IREFAddr free
| StApp1 : forall m e1 e2 m' e1',
    m / e1 --> m' / e1' ->
    m / IREApp e1 e2 --> m' / IREApp e1' e2
| StApp2 : forall m e1 e2 m' e2',
    Value e1 ->
    m / e2 --> m' / e2' ->
    m / IREApp e1 e2 --> m' / IREApp e1 e2'
| StApp : forall m a var body v,
    Value v ->
    (var, body) = queryF a m ->
    m / IREApp (IREFAddr a) v --> m / IRELet var IRTStar v body
| StBox1 : forall m t e m' e',
    m / e --> m' / e' ->
    m / IREBox t e --> m' / IREBox t e'
| StUnbox1 : forall m t e m' e',
    m / e --> m' / e' ->
    m / IREUnbox t e --> m' / IREUnbox t e'
| StUnbox : forall m t v,
    Value v ->
    m / IREUnbox t (IREBox t v) --> m / v

where "m / e --> m1 / e1" := (step m e m1 e1).

(*
** Fail evaluation for Lir expressions
*)
Inductive stepF : Mem -> IRE -> Prop :=
| StPlus1F : forall m e1 e2,
    m / e1 --> fail ->
    m / IREPlus e1 e2 --> fail
| StPlus2F : forall m e1 e2,
    Value e1 ->
    m / e2 --> fail ->
    m /  IREPlus e1 e2 --> fail
| StGet1F : forall m e1 e2,
    m /e1 --> fail ->
    m / IREGet e1 e2 --> fail
| StGet2F : forall m e1 e2,
    Value e1 ->
    m /e2 --> fail ->
    m / IREGet e1 e2 --> fail
| StSet1F : forall m e1 e2 e3,
    m / e1 --> fail ->
    m / IRESet e1 e2 e3 --> fail
| StSet2F : forall m e1 e2 e3,
    Value e1 ->
    m / e2 --> fail ->
    m / IRESet e1 e2 e3 --> fail
| StSet3F : forall m e1 e2 e3,
    Value e1 -> Value e2 ->
    m / e3 --> fail ->
    m / IRESet e1 e2 e3 --> fail
| StLet1F : forall var t e body m,
    m / e --> fail ->
    m / IRELet var t e body --> fail
| StApp1F : forall m e1 e2,
    m / e1 --> fail ->
    m / IREApp e1 e2 --> fail
| StApp2F : forall m e1 e2,
    Value e1 ->
    m / e2 --> fail ->
    m / IREApp e1 e2 --> fail
| StBox1F : forall m t e,
    m / e --> fail ->
    m / IREBox t e --> fail
| StUnbox1F : forall m t e,
    m / e --> fail ->
    m / IREUnbox t e --> fail
| StUnboxF : forall m t t' v,
    t <> t' ->
    Value v ->
    m / IREUnbox t (IREBox t' v) --> fail

 where "m / e --> 'fail'" := (stepF m e)
.

(*
** Ensures that all elements of tables in a memory have type '*'
** and that all "functions" are correctly typed
*)
Inductive mem_correct : Mem -> Prop :=
| MCE : mem_correct EmptyMem
| MCT : forall a idx v m,
     MEmpty |= EV2Val v : IRTStar ->
     mem_correct m ->
     mem_correct (UpdateT a idx v m)
| MCF : forall a var body m,
     var |=> IRTStar; MEmpty |= body : IRTStar ->
     mem_correct m ->
     mem_correct (UpdateF a var body m)
.

(*
** All expressions stored in memory tables are values
*)
Lemma MCValue : forall m a n, Value (queryT a n m).
Proof.
  intros.
  induction m; eauto using Value.
  destruct e. simpl.
  breakIndexDec; trivial.
Qed.

(*
** All expressions stored in a table of a correct memory have
** type '*'
*)
Lemma MCTy : forall m a n Γ,
    mem_correct m -> Γ |= (queryT a n m) : IRTStar.
Proof.
  induction 1; simpl; breakIndexDec;
    eauto using typing_empty, IRTyping.
Qed.

(*
** All functions stored in a correct memory have correct types.
*)
Lemma MCTyF : forall m a var body Γ,
    (var, body) = queryF a m ->
    mem_correct m ->
    var |=> IRTStar; Γ |= body : IRTStar.
Proof.
  intros * HEq HMC.
  induction HMC; simpl in HEq; breakIndexDec; eauto;
   injection HEq; intros; subst;
    unfold BoxedNil;
    eauto using IRTyping, inclusion_typing, inclusion_update, inclusion_empty.
Qed.

(*
** Table allocation preserves memory correctness
*)
Lemma mem_correct_freshT : forall m m' free,
  mem_correct m -> (free,m') = freshT m -> mem_correct m'.
Proof.
  unfold freshT. inversion 2.
  eauto using mem_correct, IRTyping.
Qed.

(*
** Function allocation preserves memory correctness
*)
Lemma mem_correct_freshF : forall m m' var body free,
  var |=> IRTStar; MEmpty |= body : IRTStar ->
  mem_correct m ->
  (free,m') = freshF m var body ->
  mem_correct m'.
Proof.
  unfold freshF.
  inversion 3; subst.
  eauto using mem_correct.
Qed.

(*
** Executing an evaluation step preserves memory
** correctness
*)
Lemma memPreservation : forall (m m' : Mem) e e' t,
  mem_correct m ->
  MEmpty |= e : t ->
  m / e --> m' / e' ->
  mem_correct m'.
Proof.
  intros * ? HTy ?.
  generalize dependent e'.
  remember MEmpty as Γ.
  induction HTy; inversion 1; subst;
  eauto using mem_correct_freshT, mem_correct_freshF, mem_correct.
Qed.

(*
** A well-typed box has the correct type of element inside it.
*)
Lemma boxTyping : forall e t,
  MEmpty |= IREBox t e : IRTStar -> MEmpty |= e : Tag2Type t.
Proof. inversion 1; trivial. Qed.

(*
** Preservation of types for Lir expressions
*)
Lemma expPreservation : forall m e t m' e',
  mem_correct m ->
  MEmpty |= e : t ->
  m / e --> m' / e' ->
  MEmpty |= e' : t.
Proof.
  intros * Hmc HT.
  generalize dependent e'.
  remember MEmpty as Γ.
  induction HT; inversion 1; subst;
  eauto using IRTyping, MCTy, boxTyping, MCTyF, subst_typing.
Qed.

(*
** Main preservation theorem for Lir
** (type preservation of memory and expression)
*)
Theorem Preservation : forall m e t m' e',
  mem_correct m ->
  MEmpty |= e : t ->
  m / e --> m' / e' ->
  mem_correct m' /\ MEmpty |= e' : t.
Proof. intuition; eauto using memPreservation,expPreservation. Qed.

(*
** Values cannot be reduced
*)
Theorem value_normal : forall m e m' v,
    m / e --> m' / v ->
    Value e ->
    False.
Proof.
  intros * Hst HV.
  generalize dependent m'.
  generalize dependent v.
  induction HV; inversion 1; subst; eauto.
Qed.

Theorem value_normalF : forall m e,
    m / e --> fail ->
    Value e ->
    False.
Proof.
  induction 1; inversion 1; subst; auto.
Qed.

Ltac open_value rule :=
  match goal with
    | [ Ht : MEmpty |= ?e : _,
        Hv : Value ?e |- _] =>
          eapply rule in Ht; trivial; decompose [ex or and] Ht
    end.

(*
** Regular steps and fail steps are excludent.
*)
Theorem failNfail : forall e m e' m' T,
    MEmpty |= e : T ->
    m / e --> m' / e' ->
    m / e --> fail ->
    False.
Proof.
  intros * HTy St HStF.
  generalize dependent T.
  induction St; intros; inversion HTy; inversion HStF; subst;
  eauto using value_normal, value_normalF, Value.
Qed.

Lemma DeterministicStepM : forall m e m1 e1 m2 e2,
    m / e --> m1 / e1 ->
    m / e --> m2 / e2 ->
    m1 = m2.
Proof.
  intros * HSt1.
  generalize dependent e2.
  induction HSt1; inversion 1; subst; eauto;
   try (exfalso; eauto using value_normal, Value; fail);
   try congruence.
   f_equal. f_equal. eauto using Value_unique.
Qed.

Theorem DeterministicStep : forall m e m1 e1 m2 e2,
    m / e --> m1 / e1 ->
    m / e --> m2 / e2 ->
    e1 = e2.
Proof.
  intros * HSt1.
  generalize dependent e2.
  induction HSt1; inversion 1; subst; eauto;
   try (exfalso; eauto using value_normal, Value; fail);
   f_equal; eauto; congruence.
Qed.

(*
** Progress for Lir terms
*)
Theorem Progress : forall m e t,
    MEmpty |= e : t  ->
    Value e \/
    (m / e --> fail \/ exists m' e', m / e --> m' / e').
Proof.
  intros * Hty.
  remember MEmpty as Γ.
  induction Hty; subst;

  (* variables *)
  try match goal with
  | [H : In MEmpty _ = _ |- _] => inversion H
   end;

  (* break induction hypotheses *)
  repeat match goal with
  | [H : _ -> _ \/ (_ \/ _) |- _] =>
      decompose [or ex and] (H eq_refl); clear H
  end;
  subst;

  (* trivial steps and failures *)
  try (right; auto using stepF; fail);

  (* trivial values *)
  auto using Value;

  (* break values *)
  repeat open_value valint;
  try open_value valtbl;
  try open_value valfun;
  try open_value valbox;
  try match goal with
    | [ Ht : MEmpty |= ?e : _,
        Hv : Value ?e |- _] => eapply vallam in Ht; trivial;
          decompose [ex or and] Ht
  end; subst;

  (* try cases that became easy after breaking values *)
  try (unshelve (right; right; eauto using step, eq_refl); trivial; fail).

  - (* cannot find the correct sequence with StSet3 ? *)
    right. right. eexists. eexists.
    eapply StSet3; eauto.

  - (* App *)
    right. right.
    match goal with [a: address |- _] => destruct (queryF a m) eqn:? end.
    eauto using step, Value.

  - (* unboxing has to handle success vs. failure *)
    match goal with | [t1:Tag, t2:Tag |- _] => destruct (dec_Tag t1 t2) end;
    right; subst; eauto using step, stepF.
Qed.

(*
** Multistep
*)
Reserved Notation "m '/' e -->* m1 '/' e1"
(at level 40, e at level 39, m1 at level 39, e1 at level 39).
Reserved Notation "m '/' e -->* 'fail'"
(at level 40, e at level 39).

Inductive multistep : Mem -> IRE -> Mem -> IRE -> Prop :=
| MStRefl : forall m e, m / e -->* m / e
| MStMStep : forall m e m' e' m'' e'',
    m / e --> m' / e' ->
    m' / e' -->* m'' / e'' ->
    m / e -->* m'' / e''

where "m / e -->* m1 / e1" := (multistep m e m1 e1)
.

Inductive multistepF : Mem -> IRE -> Prop :=
| MStStepF : forall m e m' e',
    m / e -->* m' / e' ->
    m' / e' --> fail ->
    m / e -->* fail

where "m / e -->* 'fail'" := (multistepF m e)
.

Lemma multistepF1 : forall m e, m / e --> fail -> m / e -->* fail.
Proof.
  eauto using multistep, multistepF.
Qed.

(*
** Multistep is transitive
*)
Lemma multiTrans : forall m0 e0 m1 e1 m2 e2,
    m0 / e0 -->* m1 / e1 ->
    m1 / e1 -->* m2 / e2 ->
    m0 / e0 -->* m2 / e2.
Proof.
  induction 1; eauto using multistep.
Qed.

(*
** Multistep subsumes step
*)
Lemma multistep1 : forall m0 e0 m1 e1,
    m0 / e0 --> m1 / e1 ->
    m0 / e0 -->* m1 / e1.
Proof. eauto using multistep. Qed.

Theorem Soundness : forall m e t m' e',
    mem_correct m ->
    MEmpty |= e : t  ->
    m / e -->* m' / e' ->
    Value e' \/
   (m' / e' --> fail \/ exists m'' e'', m' / e' --> m'' / e'').
Proof.
  induction 3; eauto using Progress, expPreservation, memPreservation.
Qed.

(*
** Preservation for multistep
*)
Lemma multipreservation : forall m1 e1 m2 e2 t,
    MEmpty |= e1 : t ->
    mem_correct m1 ->
    m1 / e1 -->* m2 / e2 ->
    MEmpty |= e2 : t.
Proof.
  intros * Hty HM HSt.
  induction HSt; trivial.
  apply IHHSt;
  eapply Preservation; eauto using Preservation.
Qed.

Ltac finishmExp :=
  intros * Hmt;
  induction Hmt; eauto using step,multistep.

Lemma CongPlus1 : forall e2 m e m' e',
    m / e -->* m' / e' ->  m / IREPlus e e2 -->* m' / IREPlus e' e2.
Proof. intros e2. finishmExp. Qed.

Lemma CongPlus2 : forall e1, Value e1 -> forall m e m' e',
    m / e -->* m' / e' ->  m / IREPlus e1 e -->* m' / IREPlus e1 e'.
Proof. intros e1 HV; finishmExp. Qed.

Lemma CongGet1 : forall e2 m e m' e',
    m / e -->* m' / e' ->  m / IREGet e e2 -->* m' / IREGet e' e2.
Proof. intros e2; finishmExp. Qed.

Lemma CongGet2 : forall e1, Value e1 -> forall m e m' e',
    m / e -->* m' / e' ->  m / IREGet e1 e -->* m' / IREGet e1 e'.
Proof. intros e1 HV; finishmExp. Qed.

Lemma CongSet1 : forall e2 e3 m e m' e',
    m / e -->* m' / e' ->  m / IRESet e e2 e3 -->* m' / IRESet e' e2 e3.
Proof. intros e2 e3; finishmExp. Qed.

Lemma CongSet2 : forall e1, Value e1 -> forall e3 m e m' e',
    m / e -->* m' / e' ->  m / IRESet e1 e e3 -->* m' / IRESet e1 e' e3.
Proof. intros e1 HV e3; finishmExp. Qed.

Lemma CongSet3 : forall e1 e2, Value e1 -> Value e2 -> forall m e m' e',
    m / e -->* m' / e' ->  m / IRESet e1 e2 e -->* m' / IRESet e1 e2 e'.
Proof. intros e1 e2 HV1 HV2; finishmExp. Qed.

Lemma CongLet : forall var t body m e m' e',
    m / e -->* m' / e' ->
    m / IRELet var t e body -->* m' / IRELet var t e' body.
Proof. finishmExp. Qed.

Lemma CongApp1 : forall e2 m e m' e',
    m / e -->* m' / e' ->  m / IREApp e e2 -->* m' / IREApp e' e2.
Proof. intros e2. finishmExp. Qed.

Lemma CongApp2 : forall e1, Value e1 -> forall m e m' e',
    m / e -->* m' / e' ->  m / IREApp e1 e -->* m' / IREApp e1 e'.
Proof. intros e1 HV; finishmExp. Qed.

Lemma CongBox : forall m e m' e' g,
    m / e -->* m' / e' -> m / IREBox g e -->* m' / IREBox g e'.
Proof. finishmExp. Qed.

Lemma CongUnbox : forall m e m' e' g,
    m / e -->* m' / e' -> m / IREUnbox g e -->* m' / IREUnbox g e'.
Proof. finishmExp. Qed.


(** * 6.887 Formal Reasoning About Programs, Spring 2016 - Pset 3 *)

Require Import Frap Pset3Sig.

Set Implicit Arguments.

(*Lemma forall pm pm', applyRules pm pm' l,*)

Lemma l1: forall  (l : list rule) (x : var) (b : bool), forall (pm pm': fmap var bool), applyRules pm pm' l $? x = Some b -> pm' $? x = None -> exists r: rule, ((r.(Conclusion).(AssumedPredicate)), (r.(Conclusion).(AssumedToBe))) = (x, b) /\ In r l /\ assumptionsHold pm (Assumptions r) = true.
Proof.
  induct l.
  unfold applyRules.
  assert (forall (b : bool), None = Some b -> False).
  intros. equality.
  simplify.
  specialize (H b).
  contradiction H.
  rewrite <- H0.
  rewrite -> H1.
  equality.
  simplify.

  cases (AssumedPredicate (Conclusion a) ==v x).
  cases b.
  intros.

  (*unfold In.
  SearchAbout (_ :: _).
  exact(in_eq (A:=rule) a l).*)

  assert ((applyRule pm pm' a) $? x = None).
  admit.

  cases (AssumedToBe (Conclusion a)).
  exists a.
  propositional.
  invert e.
  invert Heq.
  equality.

  admit. (* prove assumptions hold *)

  (* TODO figure out syntax *)
  specialize (IHl x true pm (applyRule pm pm' a) H H1).
  assert (forall r, In r l -> a = r \/ In r l).
  intros.
  right. assumption.
  destruct IHl.
  specialize (H2 x0).
  exists x0.
  propositional.

  cases (AssumedToBe (Conclusion a)).
  exists a.
  propositional.
  invert e.
  rewrite -> Heq.
  assert ( False).
  admit.
  contradiction H1.

  (* again assumptions hold*)
  admit.

  exists a.
  propositional.
  invert e.
  invert Heq.
  equality.

  (* again assmptions*)
  admit.

  specialize (IHl x b pm (applyRule pm pm' a)).
  specialize (IHl H).

  assert (applyRule pm pm' a $? x = None).
  unfold applyRule.
  (*can't figure out how to do cases on assumptionsHold pm asn :( :( *)
  cases a.
  cases (assumptionsHold pm Assumptions).
  SearchAbout (fmap).
  rewrite (lookup_add_ne (pm') (k:=AssumedPredicate Conclusion) (k':=x) (AssumedToBe Conclusion)).
  assumption.
  admit.

  apply H0.
  specialize (IHl H1).
  destruct IHl.
  exists x0.
  propositional.

Qed.

Theorem predicate_abstraction_simulates : forall pc state action
  (pc0 : pc) (st0 : state)
  (actionOf : pc -> action -> pc -> Prop)
  (doAction : action -> state -> state -> Prop)
  (pa : predicate_abstraction state action),
  predicate_abstraction_sound doAction pa
  -> simulates (paR pa)
               (actionSys pc0 st0 actionOf doAction)
               (predicate_abstract pc0 actionOf pa).
Proof.
  simplify.
  econstructor.
  intros.
  simplify.
  propositional.
  exists (pc0, $0).
  propositional.
  invert H1; simplify.
  eapply PaR.
  simplify.
  invert H0.

  (*begin proof of second thing*)
  simplify.
  invert H1.
  destruct st2.
  exists (pc2, match (Rules pa) $? act with
            | None => $0
            | Some rs => applyRules f $0 rs
                end).
  propositional.
  eapply PaR.
  simplify.
  unfold predicate_abstraction_sound in H.

  cases (Rules pa $? act).
  cases (Predicates pa $? x).

  assert (exists r : rule, ((r.(Conclusion).(AssumedPredicate)), (r.(Conclusion).(AssumedToBe))) = (x, b) /\ In r l /\ assumptionsHold f (Assumptions r) = true) .
  eapply (l1 l f (pm':=$0)).

  apply H1.

  rewrite (lookup_empty (A:=var) bool x).
  equality.

  destruct H4.
  specialize (H act l x0).
  specialize (H Heq).
  destruct H4.
  destruct H5.
  specialize (H H5).
  specialize (H st3 st4).
  (*prove this as lemma 2*)

  assert (assumptionsAccurate (Predicates pa) (Assumptions x0) st3). admit.
  invert H4.
  unfold assumptionsAccurate in H.
  unfold assertionAccurate in H.

  specialize (H H7).
  specialize (H H3).
  invert H1.
  rewrite Heq0 in H.
  apply H.

  SearchAbout $0.
  (*prove as lemma1*)
  assert (exists r : rule, ((r.(Conclusion).(AssumedPredicate)), (r.(Conclusion).(AssumedToBe))) = (x, b) /\ In r l /\ assumptionsHold f (Assumptions r) = true) .
  eapply (l1 l f (pm':=$0)).
  apply H1.
  rewrite (lookup_empty (A:=var) bool x).
  equality.

  destruct H4.
  specialize (H act l x0).
  specialize (H Heq).
  destruct H4.
  destruct H5.
  specialize (H H5).
  specialize (H st3 st4).

  specialize (H4 H1).
  invert H4.
  specialize (H act l x0).
  specialize (H Heq).
  destruct H5.
  specialize (H H5).
  specialize (H st3 st4).
  (*prove as lemma2*)
  assert (assumptionsAccurate (Predicates pa) (Assumptions x0) st3).
  admit.
  specialize (H H6).
  specialize (H H3).
  invert H4.
  apply H1.

  (*rewrite (lookup_empty (A:=var) bool x) in H1.*)
  assert (forall (b : bool), None = Some b -> False).
  intros. equality.
  specialize (H4 b).
  contradiction H4.
  destruct H4.

  econstructor.
  invert H0.
  apply H2.
Qed.

(* Optional part: using predicate abstraction for another example *)

Import Program2 ZArith.

(* This is not the right abstraction. :-) *)
Definition sys_pa : predicate_abstraction state action := {|
  Predicates := $0;
  Rules := $0 $+ (LockOK, [])
              $+ (AssignA, [])
              $+ (IfFalse, [])
              $+ (IfTrue, [])
              $+ (UnlockOK, [])
              $+ (IncA, [])
              $+ (WhileFalse, [])
              $+ (WhileTrue, [])
|}.

Opaque Zplus. (* Important to keep Coq from trying too hard to help and
               * unfolding the definition of addition for integers! *)

Theorem sys_ok : forall np npo,
  invariantFor (sys np npo) (fun st => fst st = Done -> (snd st).(HasLock) = false).
Proof.
Admitted.


(*===========================================================================
    Model for x86 memory

    Note that operations are partial, as not all memory is mapped
    A more refined model would incorporate R/W/X permissions, on the
    appropriate granularity.

    BEWARE of "punning" this partiality for the purpose of defining
    separating conjunction: we will at some point wish to talk about *separate*
    regions of memory not all of which are accessible under given permissions,
    and the re-use of partiality for separation would preclude this.
  ===========================================================================*)
Require Import ssreflect ssrfun ssrnat ssrbool finfun eqtype fintype seq.
Require Import bitsrep bitsops cursor reader writer.
Require Export pmap.
Local Open Scope update_scope.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* 32-bit addressable memory *)
(*=Mem *)
Definition Mem := PMAP BYTE 32.
(*=End *)
Definition PTR := DWORD.
Identity Coercion PTRtoDWORD : PTR >-> DWORD.

(* Initially, no memory is mapped *)
Definition initialMemory : Mem := @EmptyPMap BYTE 32.

(* Memory from p to just below p' in m consists exactly of the bytes in xs *)
Fixpoint memIs (m:Mem) (p p':PTR) xs :=
  if xs is x::xs then m p = Some x /\ memIs m (incB p) p' xs else p=p'.

(* Map some memory, filling it with ones (to be more visible!) *)
Definition reserveMemory (m: Mem) (p:PTR) (c: DWORD) : Mem :=
  bIterFrom p c (fun p m => m !p := ones 8) m.

(* Returns bytes with most-significant first *)
Definition DWORDToBytes (d: DWORD) : BYTE*BYTE*BYTE*BYTE := split4 8 8 8 8 d.

Definition isMapped (p:PTR) (ms: Mem) : bool := ms p.

Instance MemUpdateOpsDWORD : UpdateOps Mem PTR DWORD :=
  fun m p v =>
  let '(b3,b2,b1,b0) := DWORDToBytes v in
  m !p:=b0 !incB p:=b1 !incB(incB p):=b2 !incB(incB(incB p)):=b3.

(*
Instance MemUpdateDWORD : Update Mem DWORD DWORD.
Proof.
apply Build_Update.
move => m p v w.
rewrite /update /MemUpdateOpsDWORD.
destruct (DWORDToBytes w) as [[[b3 b2] b1] b0].
destruct (DWORDToBytes v) as [[[b7 b6] b5] b4].
rewrite (update_diff _ _ p).
rewrite (update_diff _ _ p).
rewrite (update_diff _ _ p).
rewrite update_same.
rewrite (update_diff _ _ (incB p)).
rewrite (update_diff _ _ (incB p)).
rewrite update_same.
rewrite (update_diff _ _ (incB (incB p)) _ b2).
rewrite update_same.
rewrite update_same.
done.
apply incBDistinct.
apply incBDistinct.
apply incBincBDistinct.
apply incBDistinct.
apply incBincBDistinct.
apply incBincBincBDistinct.

move => m p q v w pq.
rewrite /update /MemUpdateOpsDWORD.
destruct (DWORDToBytes w) as [[[b3 b2] b1] b0].
destruct (DWORDToBytes v) as [[[b7 b6] b5] b4].

rewrite (update_diff _ (incB (incB p))).  Implicit update_diff. rewrite update_same.
simpl.
Definition updateBYTE (p:DWORD) (b:BYTE) (ms: Mem) : option Mem :=
  if isMapped p ms then Some (ms !p := b) else None.

*)

(*---------------------------------------------------------------------------
   We define a type of "readers of T", such that

   read m p = readerFail if memory at p in m is inaccessible for reading T
   read m p = readerWrap if we tried to read beyond the end of memory
   read m p = readerOk x q if memory between p inclusive and q exclusive represents x:X
  ---------------------------------------------------------------------------*)
Inductive readerResult T :=
  readerOk (x: T) (q: DWORDCursor) | readerWrap | readerFail.
Implicit Arguments readerOk [T].
Implicit Arguments readerWrap [T].
Implicit Arguments readerFail [T].

Fixpoint readMem T (r:Reader T) (m:Mem) (pos:DWORDCursor) : readerResult T :=
  match r with
  | readerRetn x => readerOk x pos
  | readerNext rd =>
    if pos is mkCursor p
    then if m p is Some x then readMem (rd x) m (next p) else readerFail
    else readerWrap
  | readerSkip rd =>
    if pos is mkCursor p
    then if m p is Some x then readMem rd m (next p) else readerFail
    else readerWrap
  | readerCursor rd =>
    readMem (rd pos) m pos
  end.

(* Example of interpretation of writer on sequences *)
Fixpoint writeMemTm (w:WriterTm unit) (m:Mem) (pos: DWORDCursor) :
    option (DWORDCursor * Mem) :=
  match w with
  | writerRetn _ => Some (pos, m)
  | writerNext byte w =>
    if pos is mkCursor p
    then
      if isMapped p m
      then writeMemTm w (m!p:=byte) (next p)
      else None
    else None
  | writerSkip w =>
    if pos is mkCursor p
    then
      if isMapped p m
      then writeMemTm w (m!p:=#0) (next p)
      else None
    else None
  | writerCursor w =>
    writeMemTm (w pos) m pos
  | writerFail =>
    None
  end.

Definition writeMem {T} (w:Writer T) (m:Mem) (pos: DWORDCursor) (t: T):
    option (DWORDCursor * Mem) :=
  writeMemTm (w t) m pos.

Require Import Coq.Strings.String.
Import Ascii.
Fixpoint enumMemToString (xs: seq (DWORD * BYTE)) :=
  (if xs is (p,b)::xs then toHex p ++ ":=" ++ toHex b ++ ", " ++ enumMemToString xs
  else "")%string.

Definition memToString (m:Mem) := enumMemToString (enumPMap m).

Example m: Mem := (@EmptyPMap _ _) ! #5 := (#12:BYTE) !#8 := (#15:BYTE).


Require Import String.

Require Import core.utils.Utils.
Require Import core.Metamodel.
Require Import core.Model.
Require Import Engine.

Require Import Bool.
Require Import core.Syntax.
Require Import Arith.
Require Import Semantics.
Require Import ByRuleSemantics.
Require Import Certification.

Scheme Equality for list.

Section ByRuleSemanticsCertification.

Context {tc: TransformationConfiguration} {mtc: ModelingTransformationConfiguration tc}.

Lemma allModelElementsOfTypeInModel :
  forall (c: SourceModelClass) (sm : SourceModel),
  incl (allModelElementsOfType c sm) (allModelElements sm).
Proof.
  unfold allModelElementsOfType, incl.
  intros.
  apply filter_In in H.
  destruct H.
  assumption.
Qed.

Lemma allModelElementsOfTypesInModel :
  forall (sp : list SourceModelElement) (l: list SourceModelClass) (sm : SourceModel),
  In sp (allModelElementsOfTypes l sm) -> incl sp (allModelElements sm).
Proof.
  intros.
  unfold allModelElementsOfTypes in H.
  apply in_map_iff in H. destruct H. destruct H.
  rewrite <- H.
  apply allModelElementsOfTypeInModel.
Qed.

Lemma InAllTuplesOfTypes :
  forall (a : SourceModelElement) (sp: list SourceModelElement) (s: SourceModelClass) (l : list SourceModelClass) (sm: SourceModel),
  In (a :: sp) (allTuplesOfTypes (s :: l) sm)
  -> In (sp) (allTuplesOfTypes l sm).
Proof.
  intros.
  unfold allTuplesOfTypes, prod_cons in H.
  simpl in H.
  apply in_flat_map in H. destruct H. destruct H.
  apply in_map_iff in H0.
  crush.
Qed.

Lemma allTuplesOfTypesInModel :
  forall (sp : list SourceModelElement) (l: list SourceModelClass) (sm : SourceModel),
  In sp (allTuplesOfTypes l sm) -> incl sp (allModelElements sm).
Proof.
  intros.
  unfold allTuplesOfTypes in H.
  generalize dependent sp.
  induction l; intros.
  - simpl in H. destruct H.
    + rewrite <- H. unfold incl. intros. inversion H0.
    + contradiction.
  - destruct sp.
    + unfold incl. intros. inversion H0.
    + simpl in H.
      unfold prod_cons in H.
      apply in_flat_map in H. repeat destruct H.
      apply in_map_iff in H0. repeat destruct H0.
      unfold incl.
      intros.
      simpl in H0.
      destruct H0.
      * pose allModelElementsOfTypeInModel.
        unfold incl in i.
        apply i with (c:=a).
        rewrite <- H0.
        assumption.
      * unfold incl in IHl.
        simpl in IHl.
        generalize H0.
        apply IHl.
        assumption.
Qed.

Lemma allTuplesByRuleInModel :
  forall (sp : list SourceModelElement) (tr: Transformation) (sm : SourceModel),
  In sp (allTuplesByRule tr sm) -> incl sp (allModelElements sm).
Proof.
  intros.
  unfold allTuplesByRule in H.
  apply in_flat_map in H. destruct H. destruct H.
  apply allTuplesOfTypesInModel with (l:=(Rule_getInTypes x)).
  assumption.
Qed.

Lemma allTuplesOfTypesLength :
  forall (sp: list SourceModelElement) (l : list SourceModelClass) (sm : SourceModel),
  In sp (allTuplesOfTypes l sm) -> Datatypes.length sp = Datatypes.length l.
Proof.
  intros.
  generalize dependent sp.
  induction l; intros.
  - simpl in H. destruct H. rewrite <- H. reflexivity. contradiction.
  - unfold allTuplesOfTypes in H. simpl in H.
    unfold prod_cons in H.
    apply in_flat_map in H.
    destruct H. destruct H.
    apply in_map_iff in H0.
    destruct H0. destruct H0.
    unfold allTuplesOfTypes, prod_cons in IHl.
    apply IHl in H1.
    simpl.
    rewrite <- H1.
    rewrite <- H0.
    reflexivity.
Qed.

Lemma maxArityLength :
  forall (tr: Transformation) (r: Rule),
  In r (Transformation_getRules tr) ->
  Datatypes.length (Rule_getInTypes r) <= maxArity tr.
Proof.
  intros.
  unfold maxArity.
  apply max_list_upperBound.
  apply in_map_iff.
  exists (Rule_getInTypes r).
  split. reflexivity.
  apply in_map_iff.
  exists r.
  split. reflexivity.
  assumption.
Qed.

Lemma In_by_rule :
  forall (sp: list SourceModelElement) (tr: Transformation) (sm: SourceModel),
  In sp (allTuplesByRule tr sm) -> In sp (allTuples tr sm).
Proof.
  intros.
  apply allTuples_incl_length.
  * apply allTuplesByRuleInModel with (tr:=tr).
    assumption.
  * unfold allTuplesByRule in H.
    apply in_flat_map in H. destruct H. destruct H.
    apply allTuplesOfTypesLength in H0.
    rewrite H0.
    apply maxArityLength.
    assumption.
Qed.

Lemma In_allTuplesOfTypes_inv :
  forall (a: SourceModelElement) (sp: list SourceModelElement)
  (s: SourceModelClass) (l: list SourceModelClass)
  (sm: SourceModel),
  hasType s a = true
  -> In sp (allTuplesOfTypes l sm)
  -> In a (allModelElements sm)
  -> In (a :: sp) (allTuplesOfTypes (s :: l) sm).
Proof.
  intros.
  unfold allTuplesOfTypes.
  simpl.
  unfold allTuplesOfTypes in H0.
  apply prod_cons_in_inv with (se:=a) (ss:=sp).
  - unfold allModelElementsOfType, hasType.
    apply filter_In.
    split.
    + assumption.
    + apply H.
  - assumption.
Qed.

Lemma In_by_rule_match :
  forall (sp: list SourceModelElement) (tr: Transformation) (sm: SourceModel) (r: Rule),
  In sp (allTuples tr sm) /\ hd_error (matchPattern tr sm sp) = return r
  -> In sp (allTuplesOfTypes (Rule_getInTypes r) sm).
Proof.
  intros.
  destruct H.
  apply allTuples_incl in H.
  apply hd_error_In in H0.
  unfold matchPattern in H0.
  apply filter_In in H0.
  destruct H0.
  unfold matchRuleOnPattern in H1.
  destruct (checkTypes sp (Rule_getInTypes r)) eqn:dct.
  2: { inversion H1. }
  1: {
    remember (Rule_getInTypes r) as l.
    clear H1 H0 Heql.
    generalize dependent l.
    induction sp; intros.
    - simpl in dct.
      destruct l.
      + simpl.
        left.
        reflexivity.
      + inversion dct.
    - destruct l.
      + simpl in dct. inversion dct.
      + simpl in dct.
        destruct (toModelClass s a) eqn:dtmc.
        2: { inversion dct. }
        1: {
          apply In_allTuplesOfTypes_inv.
          - unfold hasType.
            rewrite dtmc.
            reflexivity.
          - apply IHsp.
            + apply incl_cons_inv in H.
              destruct H.
              assumption.
            + assumption.
          - apply incl_cons_inv in H.
            destruct H.
            assumption.
        }
  }
Qed.

Lemma In_by_rule_instantiate :
  forall (sp: list SourceModelElement) (tr: Transformation) (sm: SourceModel),
  In sp (allTuples tr sm) /\ instantiatePattern tr sm sp <> nil -> In sp (allTuplesByRule tr sm).
Proof.
  intros.
  destruct H.
  unfold allTuplesByRule.
  apply in_flat_map.
  destruct (hd_error (matchPattern tr sm sp)) eqn:dst.
  2: {
    destruct (matchPattern tr sm sp) eqn:hdst.
    - unfold instantiatePattern in H0.
      rewrite hdst in H0.
      simpl in H0.
      unfold not in H0.
      contradiction H0.
      reflexivity.
    - inversion dst.
  }
  1: {
    exists r.
    split.
    + apply hd_error_In in dst.
      apply tr_matchPattern_in in dst.
      destruct dst.
      assumption.
    + apply In_by_rule_match with (tr:=tr).
      split.
      assumption.
      assumption.
  }
Qed.

Lemma In_by_rule_apply :
forall (sp: list SourceModelElement) (tr: Transformation) (sm: SourceModel),
In sp (allTuples tr sm) /\ applyPattern tr sm sp <> nil -> In sp (allTuplesByRule tr sm).
Proof.
  intros.
  destruct H.
  unfold allTuplesByRule.
  apply in_flat_map.
  destruct (hd_error (matchPattern tr sm sp)) eqn:dst.
  2: {
    destruct (matchPattern tr sm sp) eqn:hdst.
    - unfold applyPattern in H0.
      rewrite hdst in H0.
      simpl in H0.
      unfold not in H0.
      contradiction H0.
      reflexivity.
    - inversion dst.
  }
  1: {
    exists r.
    split.
    + apply hd_error_In in dst.
      apply tr_matchPattern_in in dst.
      destruct dst.
      assumption.
    + apply In_by_rule_match with (tr:=tr).
      split.
      assumption.
      assumption.
  }
Qed.

Theorem tr_execute_in_elements :
  forall (tr: Transformation) (sm : SourceModel) (te : TargetModelElement),
  In te (allModelElements (execute tr sm)) <->
  (exists (sp : list SourceModelElement),
      In sp (allTuples tr sm) /\
      In te (instantiatePattern tr sm sp)).
Proof.
  intros.
  unfold execute. simpl.
  rewrite in_flat_map.
  split.
  * intros.
    destruct H. destruct H.
    exists x.
    split.
    + apply In_by_rule. assumption.
    + assumption.
  * intros.
    destruct H. destruct H.
    exists x.
    split.
    + apply In_by_rule_instantiate.
      split.
      - assumption.
      - unfold not. intros. rewrite H1 in H0. contradiction.
    + assumption.
Qed.

Theorem tr_execute_in_links :
  forall (tr: Transformation) (sm : SourceModel) (tl : TargetModelLink),
    In tl (allModelLinks (execute tr sm)) <->
    (exists (sp : list SourceModelElement),
        In sp (allTuples tr sm) /\
        In tl (applyPattern tr sm sp)).
Proof.
  intros.
  unfold execute. simpl.
  rewrite in_flat_map.
  split.
  * intros.
    destruct H. destruct H.
    exists x.
    split.
    + apply In_by_rule. assumption.
    + assumption.
  * intros.
    destruct H. destruct H.
    exists x.
    split.
    + apply In_by_rule_apply.
      split.
      - assumption.
      - unfold not. intros.
        rewrite H1 in H0. contradiction.
    + assumption.
Qed.

Theorem tr_execute_in :
  forall (tr: Transformation) (sm : SourceModel) (te : TargetModelElement) (tl : TargetModelLink),
    (In te (allModelElements (execute tr sm)) <-> In te (allModelElements (Semantics.execute tr sm)))
    /\ (In tl (allModelLinks (execute tr sm)) <-> In tl (allModelLinks (Semantics.execute tr sm))).
Proof.
  intros.
  split.
  - rewrite tr_execute_in_elements.
    rewrite Certification.tr_execute_in_elements.
    split. trivial. trivial.
  - rewrite tr_execute_in_links.
    rewrite Certification.tr_execute_in_links.
    split. trivial. trivial.
Qed.

Instance ByRuleEngine :
  TransformationEngine :=
{
  SourceModelElement := SourceModelElement;
  SourceModelClass := SourceModelClass;
  SourceModelLink := SourceModelLink;
  SourceModelReference := SourceModelReference;
  TargetModelElement := TargetModelElement;
  TargetModelClass := TargetModelClass;
  TargetModelLink := TargetModelLink;
  TargetModelReference := TargetModelReference;

  Transformation := Transformation;
  Rule := Rule;
  OutputPatternElement := OutputPatternElement;
  OutputPatternLink := OutputPatternLink;

  TraceLink := TraceLink;

  getRules := Transformation_getRules;

  getInTypes := Rule_getInTypes;
  getGuardExpr := Rule_getGuardExpr;
  getOutputPattern := Rule_getOutputPatternElements;

  getOutputLinks := OutputPatternElement_getOutputLinks;

  execute := execute;

  matchPattern := matchPattern;
  matchRuleOnPattern := matchRuleOnPattern;

  instantiatePattern := instantiatePattern;
  instantiateRuleOnPattern := instantiateRuleOnPattern;
  instantiateIterationOnPattern := instantiateIterationOnPattern;
  instantiateElementOnPattern := instantiateElementOnPattern;

  applyPattern := applyPattern;
  applyRuleOnPattern := applyRuleOnPattern;
  applyIterationOnPattern := applyIterationOnPattern;
  applyElementOnPattern := applyElementOnPattern;
  applyLinkOnPattern := applyLinkOnPattern;

  evalOutputPatternElementExpr := evalOutputPatternElementExpr;
  evalIteratorExpr := evalIteratorExpr;

  resolveAll := resolveAllIter;
  resolve := resolveIter;

  tr_execute_in_elements := tr_execute_in_elements;
  tr_execute_in_links := tr_execute_in_links;

  tr_matchPattern_in := tr_matchPattern_in;
  tr_instantiatePattern_in := tr_instantiatePattern_in;
  tr_instantiateRuleOnPattern_in := tr_instantiateRuleOnPattern_in;
  tr_instantiateIterationOnPattern_in := tr_instantiateIterationOnPattern_in;

  tr_applyPattern_in := tr_applyPattern_in;
  tr_applyRuleOnPattern_in := tr_applyRuleOnPattern_in;
  tr_applyIterationOnPattern_in := tr_applyIterationOnPattern_in;
  tr_applyElementOnPattern_in := tr_applyElementOnPattern_in;

  (*tr_matchPattern_None := tr_matchPattern_None;

  tr_matchRuleOnPattern_None := tr_matchRuleOnPattern_None;

  tr_instantiatePattern_non_None := tr_instantiatePattern_non_None;
  tr_instantiatePattern_None := tr_instantiatePattern_None;

  tr_instantiateRuleOnPattern_non_None := tr_instantiateRuleOnPattern_non_None;

  tr_instantiateIterationOnPattern_non_None := tr_instantiateIterationOnPattern_non_None;

  tr_instantiateElementOnPattern_None := tr_instantiateElementOnPattern_None;
  tr_instantiateElementOnPattern_None_iterator := tr_instantiateElementOnPattern_None_iterator;

  tr_applyPattern_non_None := tr_applyPattern_non_None;
  tr_applyPattern_None := tr_applyPattern_None;

  tr_applyRuleOnPattern_non_None := tr_applyRuleOnPattern_non_None;

  tr_applyIterationOnPattern_non_None := tr_applyIterationOnPattern_non_None;

  tr_applyElementOnPattern_non_None := tr_applyElementOnPattern_non_None;

  tr_applyLinkOnPattern_None := tr_applyLinkOnPattern_None;
  tr_applyLinkOnPattern_None_iterator := tr_applyLinkOnPattern_None_iterator;

  tr_maxArity_in := tr_maxArity_in;

  tr_instantiateElementOnPattern_Leaf := tr_instantiateElementOnPattern_Leaf;
  tr_applyLinkOnPattern_Leaf := tr_applyLinkOnPattern_Leaf;
  tr_matchRuleOnPattern_Leaf := tr_matchRuleOnPattern_Leaf;

  tr_resolveAll_in := tr_resolveAllIter_in;
  tr_resolve_Leaf := tr_resolveIter_Leaf';*)
}.

End ByRuleSemanticsCertification.


Module Type ConfigType.
  Parameter S : Set.
  Parameter E : Type.
  Inductive Config :=
  | U : Config
  | P : Config -> Config -> Config
  | N : S -> Config -> Config.
End ConfigType.

Module DefaultConfig <: ConfigType.
  Axiom S : Set.
  Axiom  E : Type.
  Inductive Config :=
  | U : Config
  | P : Config -> Config -> Config
  | N : S -> Config -> Config.
End DefaultConfig.


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 A1 A2 B1 B2 C1 C2 P : Universe, ((wd_ A1 A2 /\ (wd_ C1 C2 /\ (wd_ B1 B2 /\ (wd_ A2 P /\ (wd_ A1 P /\ (col_ P B1 B2 /\ (col_ P C1 C2 /\ (col_ A1 B1 B2 /\ col_ A2 B1 B2)))))))) -> col_ A1 A2 P)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Reals.Rdefinitions.
Require Import ChargeTactics.Lemmas.
Require Import TLA.TLA.
Require Import TLA.EnabledLemmas.
Require Import TLA.ProofRules.
Require Import Examples.System2.
Require Import Examples.UpperLowerSecond.
Require Import Examples.UpperLowerFirst.

Local Open Scope string_scope.
Local Open Scope HP_scope.

Module Type UpperLowerParams.
  Parameter ub : R.
  Parameter d : R.
  Parameter d_gt_0 : (d > 0)%R.
  Parameter amin : R.
  Parameter amin_lt_0 : (amin < 0)%R.
  Parameter ubv : R.
  Axiom ubv_gt_amin_d : (ubv >= -amin*d)%R.
  Parameter ub_ubv :
    (ubv*d + ubv*ubv*(0 - /2)*(/amin) <= ub)%R.
End UpperLowerParams.

Module UpperLower (Import P : UpperLowerParams).

  Module Y <: UpperLowerSecondParams.
    Definition ub := P.ub.
    Definition d := P.d.
    Definition d_gt_0 := P.d_gt_0.
    Definition amin := P.amin.
    Definition amin_lt_0 := P.amin_lt_0.
    Definition ubv := P.ubv.
    Definition ub_ubv := P.ub_ubv.
  End Y.

  Module V <: UpperLowerFirstParams.
    Definition ub := P.ubv.
    Definition d := P.d.
    Definition d_gt_0 := P.d_gt_0.
  End V.

  Module Position := UpperLowerSecond Y.
  Module Vel := UpperLowerFirst V.

  Definition Next : ActionFormula :=
    SysCompose Vel.Next Position.Next.

  Definition IndInv : StateFormula :=
    Vel.IndInv //\\ Position.IndInv.

  Lemma Vel_IndInv_Position_Assumption :
    Vel.IndInv //\\ TimeBound V.d |-- Position.Next_Assumption.
  Proof.
    rewrite Vel.IndInv_impl_Inv.
    unfold Position.Next_Assumption, Vel.Safe, V.ub,
    Position.Monitor.Next_Assumption, Position.Params.ubv, Y.ubv.
    rewrite <- Rename_ok by eauto with rw_rename.
    solve_linear.
  Qed.

  Lemma TimedPreserves_Next :
    |-- TimedPreserves d IndInv Next.
  Proof with (refine _).
    unfold IndInv, Next. unfold SysCompose.
    rewrite SysCompose_simpl.
    rewrite <- TimedPreserves_And...
    charge_split.
    { apply TimedPreserves_intro.
      rewrite <- Vel.TimedPreserves_Next.
      charge_tauto. }
    { apply TimedPreserves_intro.
      rewrite <- Position.TimedPreserves_Next.
      rewrite Vel_IndInv_Position_Assumption.
      charge_tauto. }
  Qed.

  Definition Constraint :=
    P.amin <= "a" <= --P.amin.

  Lemma SysNeverStuck_Discr :
    |-- Enabled ((0 <= "T"! <= d //\\ Sys_D Next) //\\
                  next Constraint).
  Proof.
    enable_ex_st.
    pose proof P.amin_lt_0. pose proof P.d_gt_0.
    pose proof P.ubv_gt_amin_d.
    unfold Vel.V.ub, Vel.V.d, V.ub, V.d.
    unfold Position.Params.amin.
    unfold Y.amin.
    destruct (RIneq.Rgt_dec (st "y") R0);
      destruct (RIneq.Rgt_dec (st "v") R0).
    { exists amin; do 2 eexists; exists d; solve_linear. }
    { do 3 eexists; exists d; solve_linear. }
    { do 3 eexists; exists d; solve_linear. }
    { exists (-amin)%R; do 2 eexists; exists d; solve_linear. }
  Qed.

  Theorem SysNeverStuck_Next : |-- SysNeverStuck d IndInv Next.
  Proof.
    eapply SysNeverStuck_Sys';
    [ refine _ | pose proof d_gt_0 ; solve_linear | | ].
    { pose proof SysNeverStuck_Discr.
      etransitivity; [ apply H; clear H |
                       apply Proper_Enabled_lentails ].
      charge_tauto. }
    { admit. (** Provable, but we won't worry about it *) }
  Qed.

  Definition Safe : StateFormula :=
    Vel.Safe //\\ Position.Safe.

  Lemma IndInv_impl_Safe : IndInv //\\ TimeBound d |-- Safe.
  Proof with (eauto with rw_rename).
    charge_split.
    { rewrite <- Vel.IndInv_impl_Inv.
      unfold IndInv, TimeBound, V.d.
      charge_tauto. }
    { rewrite <- Position.IndInv_impl_Safe.
      unfold Y.d, IndInv.
      rewrite <- Vel_IndInv_Position_Assumption.
      unfold V.d. charge_tauto. }
  Qed.

  Lemma UpperLower_safe :
    |-- (IndInv //\\ TimeBound d) //\\ []Next -->> []Safe.
  Proof.
    rewrite <- IndInv_impl_Safe.
    eapply Inductively.Preserves_Inv.
    3: apply TimedPreserves_Next.
    - compute; tauto.
    - apply always_tauto. charge_tauto.
  Qed.

End UpperLower.


Welcome to Coq 8.4pl4 (August 2014)

Coq < Section Math010.

Coq < Require Import Arith.
[Loading ML file z_syntax_plugin.cmxs ... done]
[Loading ML file quote_plugin.cmxs ... done]
[Loading ML file newring_plugin.cmxs ... done]

Coq < Load CpdtTactics.

Coq < Goal forall x, x * 1 = x.
1 subgoal

  ============================
   forall x : nat, x * 1 = x

Unnamed_thm < crush.
No more subgoals.

Unnamed_thm < Qed.
crush.

Unnamed_thm is defined


Require Import os_code_defs.
Require Import code_notations.
Require Import os_ucos_h.

Open Scope code_scope.

Definition OSTimeDly_impl :=
      Void ·OSTimeDly·(⌞ticks @ Int16u⌟)··{
             ⌞ ⌟;

             If (ticks′ >ₑ ′0)
             {
               ENTER_CRITICAL;ₛ
               If (OSTCBCur′→OSTCBPrio ==ₑ ′OS_IDLE_PRIO){
                 EXIT_CRITICAL;ₛ
                 RETURN
               };ₛ
               IF ((OSTCBCur′→OSTCBStat  ==ₑ ′OS_STAT_RDY) &&ₑ (OSTCBCur′→OSTCBDly  ==ₑ ′0)){
                 OSRdyTbl′[OSTCBCur′→OSTCBY] =ₑ OSRdyTbl′[OSTCBCur′→OSTCBY]&ₑ(∼OSTCBCur′→OSTCBBitX);ₛ
                 If (OSRdyTbl′[OSTCBCur′→OSTCBY] ==ₑ ′0)
                 {
                   OSRdyGrp′ =ₑ OSRdyGrp′ &ₑ (∼OSTCBCur′→OSTCBBitY)
                 };ₛ
                 OSTCBCur′→OSTCBDly =ₑ ticks′;ₛ
                 EXIT_CRITICAL;ₛ
                 OS_Sched()
               }ELSE{
                 EXIT_CRITICAL
               }
             };ₛ
             RETURN
           }·.

Definition OSTimeGet_impl :=
       Int32u ·OSTimeGet·(⌞⌟)··{
              ⌞
                ticks @ Int32u
              ⌟;

              ENTER_CRITICAL;ₛ
              ticks′ =ₑ OSTime′;ₛ
              EXIT_CRITICAL;ₛ
              RETURN ticks′
       }·.

Close Scope code_scope.


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University

  This file is part of Velisarios.

  Velisarios 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.

  Velisarios 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 Velisarios.  If not, see <http://www.gnu.org/licenses/>.

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Export generic_tactics.
Require Export list_util1.

Section Quorum.

  Context { pn  : @Node }.

  Definition nat_n (n : nat) : Set := {m : nat | m <? n = true}.

  Record bijective {A B} (f : A -> B) :=
    {
      bij_inv : B -> A;
      bij_id1 : forall x : A, bij_inv (f x) = x;
      bij_id2 : forall y : B, f (bij_inv y) = y;
    }.
  Arguments bij_inv [A] [B] [f] _ _.

  Lemma nat_n_deq: forall n, Deq (nat_n n).
  Proof.
    introv; introv.
    destruct x as [n1 p1], y as [n2 p2].
    destruct (deq_nat n1 n2);[left|right].

    - subst.
      f_equal.
      apply UIP_dec.
      apply bool_dec.

    - introv xx; inversion xx; tcsp.
  Defined.

  Definition injective {A B} (F : A -> B) :=
    forall n m, F n = F m -> n = m.

  Class Quorum_context :=
    MkQuorumContext
      {
        node_type     : Set;
        num_nodes     : nat;
        node_deq      : Deq node_type;
        node2nat      : node_type -> nat_n num_nodes;
        node_bij      : bijective node2nat;
        node2name     : node_type -> name;
        node2name_inj : injective node2name;
      }.

  Context { quorum_context : Quorum_context }.

  Definition mk_nat_n {x n : nat} (p : x < n) : nat_n n :=
    exist _ x (leb_correct _ _ p).

  Definition nodes : list node_type :=
    mapin
      (seq 0 num_nodes)
      (fun n i => bij_inv node_bij (mk_nat_n (seq_0_lt i))).

  Lemma nodes_no_repeats : no_repeats nodes.
  Proof.
    apply no_repeats_mapin; eauto 3 with list.
    introv d.
    assert (node2nat (bij_inv node_bij (mk_nat_n (seq_0_lt i)))
            = node2nat (bij_inv node_bij (mk_nat_n (seq_0_lt j))))
      as h by (allrw; auto).
    repeat rewrite (bij_id2 _ node_bij) in h.
    clear d.
    unfold mk_nat_n in h.
    inversion h; auto.
  Qed.

  Lemma length_nodes : length nodes = num_nodes.
  Proof.
    introv; unfold nodes; autorewrite with list; auto.
  Qed.

  Lemma nodes_prop : forall (x : node_type), In x nodes.
  Proof.
    introv.
    unfold nodes.
    apply in_mapin.

    remember (node2nat x) as nx.
    destruct nx as [nx condnx].

    pose proof (leb_complete _ _ condnx) as c.

    assert (In nx (seq O num_nodes)) as i.
    { apply in_seq; omega. }

    exists nx i; simpl.

    unfold mk_nat_n.
    unfold bij_inv.
    destruct node_bij.
    pose proof (bij_id3 x) as h.
    rewrite <- Heqnx in h; subst; simpl.

    f_equal; f_equal.
    apply UIP_dec; apply bool_dec.
  Qed.

  Lemma num_nodes_list_le :
    forall (l : NRlist node_type), length l <= num_nodes.
  Proof.
    introv.
    apply (le_trans _ (length nodes));[|rewrite length_nodes;auto].

    assert (subset l nodes) as ss.
    { introv j; apply nodes_prop. }

    pose proof (no_repeats_implies_remove_repeats_eq node_deq l (nrl_no_repeats _ l)) as e.

    apply (subset_implies_eq_length_remove_repeats node_deq) in ss.
    rewrite e in ss.
    eapply le_trans;[exact ss|].
    eauto with list.
  Qed.

  Lemma overlapping_quorums :
    forall (l1 l2 : NRlist node_type) n m,
      n <= length l1
      -> m <= length l2
      -> exists good,
          (n + m) - num_nodes <= length good
          /\ no_repeats good
          /\ subset good l1
          /\ subset good l2.
  Proof.
    introv len1 len2.

    exists (keep node_deq l1 l2).
    dands; eauto 3 with list;[].

    destruct (le_lt_dec ((n + m) - num_nodes) (length (keep node_deq l1 l2))) as [d|d]; auto.
    assert False; tcsp.

    assert (no_repeats (remove_repeats node_deq (l1 ++ l2))) as nr by eauto 3 with list.

    pose proof (num_nodes_list_le (MkNRlist _ (remove_repeats node_deq (l1 ++ l2)) nr)) as q.
    simpl in *.
    rewrite remove_repeats_app in q.
    rewrite app_length in q.
    rewrite (no_repeats_implies_remove_repeats_eq _ l2) in q; auto; eauto 3 with list.
    rewrite (no_repeats_implies_remove_repeats_eq _ l1) in q; auto; eauto 3 with list.

    pose proof (split_length_as_keep_remove_list node_deq l1 l2) as w; try omega.
  Qed.

  Lemma overlapping_quorums_same_size :
    forall (l1 l2 : NRlist node_type) n,
      n <= length l1
      -> n <= length l2
      -> exists l,
          (2 * n) - num_nodes <= length l
          /\ no_repeats l
          /\ subset l l1
          /\ subset l l2.
  Proof.
    introv len1 len2.

    assert (n + n = 2 * n) as eqn by omega.

    pose proof (overlapping_quorums l1 l2 n n) as q.
    rewrite eqn in q.
    repeat (autodimp q hyp); try omega.
  Qed.

  Lemma overlapping_quorums_different_sizes :
    forall (l1 l2 : NRlist node_type) n m,
      num_nodes - n < m
      -> n <= length l1
      -> m <= length l2
      -> exists good,
          1 <= length good
          /\ no_repeats good
          /\ subset good l1
          /\ subset good l2.
  Proof.
    introv cond len1 len2.
    pose proof (overlapping_quorums l1 l2 n m) as q.
    repeat (autodimp q hyp).
    exrepnd.
    exists good; dands; auto; try omega.
  Qed.

End Quorum.

Arguments bij_inv [A] [B] [f] _ _.


Require Import Coq.Strings.String Coq.Lists.List Coq.Program.Program.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.
Require Import Fiat.Common.List.ListFacts.
Require Import Fiat.Common.Enumerable.
Require Import Fiat.Common.LogicFacts.
Require Import Fiat.Common.Equality.

Set Implicit Arguments.

Local Open Scope string_like_scope.
Local Open Scope type_scope.

Section cfg.
  Context {Char} {HSLM : StringLikeMin Char} {predata : @parser_computational_predataT Char} {HEC : Enumerable Char}.

  Class paren_balanced_hiding_dataT :=
    { is_open : Char -> bool;
      is_close : Char -> bool;
      is_bin_op : Char -> bool }.

  Context {pdata : paren_balanced_hiding_dataT}.

  Context (G : grammar Char).

  (**
<<
pb' ch n "" = (n == 0)
pb' ch n (ch :: s) = n > 0 && pb' ch n s
pb' ch n ('(' :: s) = pb' ch (n + 1) s
pb' ch n (')' :: s) = n > 0 && pb' ch (n - 1) s
pb' ch n (_ :: s) = pb' ch n s

pb = pb' '+' 0
>>
*)

  Definition pb_check_level (hiding : bool) (ch : Char) (start_level : nat) : bool
    := if is_bin_op ch
       then if hiding
            then Compare_dec.gt_dec start_level 0 : bool
            else true
       else if is_open ch
            then true
            else if is_close ch
                 then (Compare_dec.gt_dec start_level 0 : bool)
                 else true.

  Definition pb_new_level (ch : Char) (start_level : nat) : nat
    := if is_bin_op ch
       then start_level
       else if is_open ch
            then (S start_level)
            else if is_close ch
                 then (pred start_level)
                 else start_level.

  (** We can check the level for a function [Char -> bool] by enumerating through all the booleans *)
  Definition pb_check_level_fun (hiding : bool) (P : Char -> bool) (start_level : nat) : bool
    := List.fold_right
         andb
         true
         (List.map
            (fun ch => pb_check_level hiding ch start_level)
            (List.filter
               P
               (enumerate Char))).

  Lemma pb_check_level_fun_correct hiding P start_level
  : pb_check_level_fun hiding P start_level
    <-> (forall ch, P ch -> pb_check_level hiding ch start_level).
  Proof.
    unfold pb_check_level_fun.
    setoid_rewrite fold_right_andb_map_in_iff.
    setoid_rewrite filter_In.
    setoid_rewrite (fun x => @and_TrueP_L (In x (enumerate Char)) (P x = true) (enumerate_correct x)).
    reflexivity.
  Qed.

  Definition pb_new_level_fun (P : Char -> bool) (start_level : nat) : list nat
    := List.uniquize
         EqNat.beq_nat
         (List.map
            (fun ch => pb_new_level ch start_level)
            (List.filter
               P
               (enumerate Char))).

  Lemma pb_new_level_fun_correct P start_level new_level
  : pb_new_level_fun P start_level = [new_level]
    <-> ((exists ch, P ch) /\ forall ch, P ch -> new_level = pb_new_level ch start_level).
  Proof.
    unfold pb_new_level_fun.
    rewrite (uniquize_singleton (beq := EqNat.beq_nat) bl lb).
    setoid_rewrite in_map_iff.
    setoid_rewrite filter_In.
    setoid_rewrite (fun x => @and_TrueP_L (In x (enumerate Char)) (P x = true) (enumerate_correct _)).
    split; intro H;
    repeat match goal with
             | _ => split
             | _ => intro
             | _ => progress subst
             | _ => progress destruct_head ex
             | _ => progress split_and
             | _ => progress split_iff
             | [ H : forall x, _ = x -> _ |- _ ] => specialize (H _ eq_refl)
             | [ H : forall x, x = _ -> _ |- _ ] => specialize (H _ eq_refl)
             | [ H : forall x, _ -> _ = _ |- _ ] => unique pose proof (fun x H' => eq_sym (H x H'))
             | _ => solve [ eauto ]
           end.
  Qed.

  Section generic.
    Context (transform_valid : nonterminals_listT -> nonterminal_carrierT -> nonterminals_listT).

    Inductive generic_pb'_productions : nonterminals_listT -> productions Char -> Type :=
    | PBNil : forall valid,
                 generic_pb'_productions valid nil
    | PBCons : forall valid pat pats,
                  generic_pb'_production valid 0 pat
                  -> generic_pb'_productions valid pats
                  -> generic_pb'_productions valid (pat::pats)
    with generic_pb'_production : nonterminals_listT -> nat -> production Char -> Type :=
    | PBProductionNil : forall valid,
                           generic_pb'_production valid 0 nil
    | PBProductionConsNonTerminal : forall valid start_level nt its,
                                       is_valid_nonterminal valid (of_nonterminal nt)
                                       -> generic_pb'_productions (transform_valid valid (of_nonterminal nt)) (Lookup G nt)
                                       -> generic_pb'_production valid start_level its
                                       -> generic_pb'_production valid start_level (NonTerminal nt :: its)
    | PBProductionConsTerminal : forall valid start_level new_level P its,
                                   (forall ch, is_true (P ch) -> pb_check_level false ch start_level)
                                   -> (forall ch, is_true (P ch) -> pb_new_level ch start_level = new_level)
                                    -> generic_pb'_production valid new_level its
                                    -> generic_pb'_production valid start_level (Terminal P :: its).
  End generic.

  Definition minimal_pb'_productions := generic_pb'_productions remove_nonterminal.
  Definition minimal_pb'_production := generic_pb'_production remove_nonterminal.

  Definition pb'_productions := generic_pb'_productions (fun valid _ => valid).
  Definition pb'_production := generic_pb'_production (fun valid _ => valid).

  Lemma pb_check_level_le {ch b} {n n'} (Hle : n <= n')
  : pb_check_level b ch n -> pb_check_level b ch n'.
  Proof.
    unfold pb_check_level.
    do 2 edestruct Compare_dec.gt_dec; trivial; try omega; simpl.
    destruct b;
    edestruct is_bin_op; trivial;
    edestruct is_close;
    edestruct is_open;
    unfold is_true;
    trivial.
  Qed.

  Global Instance pb_new_level_Proper {ch}
  : Proper (le ==> le) (pb_new_level ch).
  Proof.
    intros ???.
    unfold pb_new_level.
    edestruct is_bin_op; trivial;
    edestruct is_close;
    edestruct is_open;
    unfold is_true;
    trivial;
    omega.
  Qed.

  Global Instance pb_new_level_flip_Proper {ch}
  : Proper (Basics.flip le ==> Basics.flip le) (pb_new_level ch).
  Proof.
    unfold Basics.flip, pb_new_level.
    intros ???.
    edestruct is_bin_op; trivial;
    edestruct is_close;
    edestruct is_open;
    unfold is_true;
    trivial;
    omega.
  Qed.
End cfg.

Global Arguments paren_balanced_hiding_dataT : clear implicits.