(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*   Assia.Mahboubi@inria.fr, Laurence.Rideau@inria.fr       *)
(*  Laurent.Thery@inria.fr  &all    2006                     *)
(*************************************************************)

(* WARNING : Not to be compiled!!!

This defines the type of algebraic numbers at the current level (=dimension)
and operations on bounds given
Coef : Set.
Rat : Set
cInfo :Set.
cell_point : Set.

Pol := Pol1 Coef

Rpoint

*)

  (************************************************************)
  (****             Type definitions                       ****)
  (************************************************************)

 Definition Alg := mkAlg Rat Coef cInfo.
 Definition Rpoint := mkRpoint Rat Coef cInfo.
 Definition cell_point_up := next_path Rat Coef cInfo path.

 (************************************************************)
 (******         Misc. for sign_tables handling        *******)
 (************************************************************)

(* to add the sign of a pol to a list of signs at a tagged root*)
 Definition add_cst_sign
   (l:list (Rpoint*(list (Pol*Sign))))(P:Pol)(sign:Sign):=
   let add_sign := fun w => (fst w, (P,sign)::(snd w)) in
     map add_sign l.

(* to add the sign of a pol at the end of a list of signs *)
 Definition add_to_cst_list
   (l:list (Rpoint*(list (Pol*Sign))))(sign :list (Pol*Sign)):=
   let add_list := fun w => (fst w,  (snd w) @ sign) in
     map add_list l.

  (************************************************************)
  (***      Bounds on the value of P at a cell_point_up      **)
  (**************************g**********************************)

  Definition Pol_value_bound (z:cell_point_up)(P:Pol):=
    let (z',r):=z in
      match r with
	|Minf m => cvalue_bound z' (Pol_partial_eval P m)
	|Between b => cvalue_bound z' (Pol_partial_eval P b)
	|Root r => cvalue_bound z' (Pol_partial_eval P r)
	|Alg_root alg =>
	  let (a,b,_,_,_):= alg in
	  let g:= fix Pol_eval_int(P:Pol):(Rat*Rat):=
	    match P with
	      |Pc c => cvalue_bound z' c
	      |PX P i p =>
		let (c,d):= Pol_eval_int P in
		let (e,f):= rpow_int a b (Npos i) in
	        let (g,h):= rprod_int c d e f in
		let (k,l):= cvalue_bound z' p in
		  radd_int g h k l
	    end in
	    g P
      end.

  (************************************************************)
  (***        Refinement of algebraic numbers encodings     ***)
  (************************************************************)

 Definition alg_refine(z:path)(alg:Alg)(n:nat):=
   let (a, b, P, Pbar, blist):= alg in
   let mid := rdiv (radd a b) (2#1) in
   let Pmid := Pol_partial_eval P mid in
   let Pbarmid := Pol_partial_eval Pbar mid in
     match
       (snd (snd
	 (csign_at (cmk_Info Pmid Pbarmid (cdeg Pbarmid) None None) z n)))
       with
       |None => None
       |Some Eq => Some (z,(Root Coef cInfo mid))
       |Some _ =>
	 let (b',b''):= Pol_bern_split blist a b mid in
	 let Vb' :=
	   op_sign_changes
	   (map (fun x => snd (snd (csign_at x z n))) b') in
	   match Vb' with
	     |None => None
	     |Some 1 => Some (z, (Alg_root (Five a mid P Pbar b')))
	     |Some _ => Some (z, (Alg_root (Five a mid P Pbar b'')))
	   end
     end.

 (** keeps only the relevant half of each int in every algebraic coordinate **)
 Definition cell_refine(z:cell_point_up)(n:nat) :=
   let (z',r):= z in
     let z':= ccell_refine z' n in
       match z' with
	 |None => None
	 |Some z' =>
	   match r with
	     |Minf m => Some (z', Minf Coef cInfo m)
	     |Between b => Some (z', Between Coef cInfo b)
	     |Root r => Some (z', Root Coef cInfo r)
	     |Alg_root alg => alg_refine z' alg n
	   end
   end.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj3synthconj5 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus lv0 lv1) (lv2)).
Admitted.
QuickChick conj3synthconj5.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj6eqsynthconj1 : forall  (lv0 : natural), (@eq natural (lv0) (mult lv0 Zero)).
Admitted.
QuickChick conj6eqsynthconj1.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj7eqsynthconj3 : forall  (lv0 : natural), (@eq natural (lv0) (plus Zero (plus Zero lv0))).
Admitted.
QuickChick conj7eqsynthconj3.


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 Bprimeprimeprime : 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_ Bprime Bprimeprimeprime /\ (wd_ Bprimeprimeprime T /\ (wd_ B Bprimeprimeprime /\ (wd_ T Bprimeprime /\ (wd_ B Bprimeprime /\ (wd_ A Bprimeprimeprime /\ (wd_ T Bprime /\ (col_ B Bprimeprimeprime T /\ (col_ A B Bprimeprimeprime /\ (col_ T Bprimeprimeprime 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.


Require Import compcert.common.AST.

(*THREADS*)
Module Type ThreadID.
  Parameter tid: Set.
  (*I don't like the fact that this breaks abstraction*)
  (*This is added for the hybrid machine. A better way of
     handeling this is making the machine have multiple semantics.
    Instead of the sum of two semantics. *)
  Parameter tid2nat: tid -> nat.
  Axiom eq_tid_dec: forall (i j: tid), {i=j} + {i<>j}.
End ThreadID.

Module NatTID <: ThreadID.
  Definition tid:= nat.
  Definition tid2nat: tid -> nat:= id.
  Lemma eq_tid_dec: forall (i j: tid), {i=j} + {i<>j}.
  Proof. intros; apply Peano_dec.eq_nat_dec. Qed.
End NatTID.

(*SCHEDULERS*)
Module Type Scheduler.
  Declare Module TID: ThreadID.
  Import TID.
  Parameter schedule : Type.
  Parameter empty : schedule.
  Parameter Empty : schedule -> bool.
  Parameter schedPeek: schedule -> option tid.
  Parameter schedSkip: schedule -> schedule.
  Parameter buildSched: list tid -> schedule.
  Parameter sch_dec: forall (sch sch': schedule), {sch = sch'} + {sch <> sch'}.
  Parameter end_of_sch: forall U, U = schedSkip U <-> schedPeek U = None.
End Scheduler.

Module ListScheduler (TID:ThreadID) <: Scheduler with Module TID:= TID.
  Module TID:= TID.
  Import TID.
  Definition schedule:= list tid.
  Definition empty : schedule := nil.
  Definition schedPeek (sc:schedule):= @List.hd_error tid sc.
  Definition Empty : schedule -> bool := fun sch => if schedPeek sch then false else true.
  Definition schedSkip (sc:schedule): schedule:= @List.tl tid sc.
  Definition buildSched (ls : list tid) : schedule := ls.
  Lemma sch_dec: forall (sch sch': schedule), {sch = sch'} + {sch <> sch'}.
  Proof.
    induction sch.
    - intro sch'; destruct sch'; [left | right]; auto; apply List.nil_cons.
    - intro sch'; destruct sch'; [right|].
      + intros HH. apply (@List.nil_cons _ a sch); symmetry; assumption.
      + destruct (TID.eq_tid_dec a t).
        destruct (IHsch sch').
        * subst; left; auto.
        * subst; right. intros HH; apply n. inversion HH; auto.
        * right. intros HH; apply n. inversion HH; auto.
  Qed.
  Lemma end_of_sch: forall U, U = schedSkip U <-> schedPeek U = None.
  Proof.
    unfold schedPeek, schedSkip.
    split; simpl; intros HH; destruct U; inversion HH; try reflexivity.
    simpl in HH.
    contradict HH.
    generalize t; clear; induction U.
    - intros t HH. apply (@List.nil_cons _ t nil). symmetry; assumption.
    - intros t HH. inversion HH. apply (IHU a); assumption.
  Qed.
End ListScheduler.


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** Some facts and definitions about classical logic

Table of contents:

1. Propositional degeneracy = excluded-middle + propositional extensionality

2. Classical logic and proof-irrelevance

2.1. CC |- prop. ext. + A inhabited -> (A = A->A) -> A has fixpoint

2.2. CC |- prop. ext. + dep elim on bool -> proof-irrelevance

2.3. CIC |- prop. ext. -> proof-irrelevance

2.4. CC |- excluded-middle + dep elim on bool -> proof-irrelevance

2.5. CIC |- excluded-middle -> proof-irrelevance

3. Weak classical axioms

3.1. Weak excluded middle

3.2. Gödel-Dummett axiom and right distributivity of implication over
     disjunction

3 3. Independence of general premises and drinker's paradox

4. Principles equivalent to classical logic

4.1 Classical logic = principle of unrestricted minimization

4.2 Classical logic = choice of representatives in a partition of bool
*)

(************************************************************************)
(** * Prop degeneracy = excluded-middle + prop extensionality      *)
(**
 i.e.        [(forall A, A=True \/ A=False)
                         <->
       (forall A, A\/~A) /\ (forall A B, (A<->B) -> A=B)]
*)

(** [prop_degeneracy] (also referred to as propositional completeness)
    asserts (up to consistency) that there are only two distinct formulas *)
Definition prop_degeneracy := forall A:Prop, A = True \/ A = False.

(** [prop_extensionality] asserts that equivalent formulas are equal *)
Definition prop_extensionality := forall A B:Prop, (A <-> B) -> A = B.

(** [excluded_middle] asserts that we can reason by case on the truth
    or falsity of any formula *)
Definition excluded_middle := forall A:Prop, A \/ ~ A.

(** We show [prop_degeneracy <-> (prop_extensionality /\ excluded_middle)] *)

Lemma prop_degen_ext : prop_degeneracy -> prop_extensionality.
Proof.
  intros H A B [Hab Hba].
  destruct (H A); destruct (H B).
    rewrite H1; exact H0.
    absurd B.
      rewrite H1; exact (fun H => H).
      apply Hab; rewrite H0; exact I.
    absurd A.
      rewrite H0; exact (fun H => H).
      apply Hba; rewrite H1; exact I.
    rewrite H1; exact H0.
Qed.

Lemma prop_degen_em : prop_degeneracy -> excluded_middle.
Proof.
  intros H A.
  destruct (H A).
    left; rewrite H0; exact I.
    right; rewrite H0; exact (fun x => x).
Qed.

Lemma prop_ext_em_degen :
  prop_extensionality -> excluded_middle -> prop_degeneracy.
Proof.
  intros Ext EM A.
  destruct (EM A).
    left; apply (Ext A True); split;
     [ exact (fun _ => I) | exact (fun _ => H) ].
    right; apply (Ext A False); split; [ exact H | apply False_ind ].
Qed.

(** A weakest form of propositional extensionality: extensionality for
    provable propositions only *)

Require Import PropExtensionalityFacts.

Definition provable_prop_extensionality := forall A:Prop, A -> A = True.

Lemma provable_prop_ext :
  prop_extensionality -> provable_prop_extensionality.
Proof.
  exact PropExt_imp_ProvPropExt.
Qed.

(************************************************************************)
(** * Classical logic and proof-irrelevance *)

(************************************************************************)
(** ** CC |- prop ext + A inhabited -> (A = A->A) -> A has fixpoint *)

(** We successively show that:

   [prop_extensionality]
     implies equality of [A] and [A->A] for inhabited [A], which
     implies the existence of a (trivial) retract from [A->A] to [A]
        (just take the identity), which
     implies the existence of a fixpoint operator in [A]
        (e.g. take the Y combinator of lambda-calculus)

*)

Local Notation inhabited A := A (only parsing).

Lemma prop_ext_A_eq_A_imp_A :
  prop_extensionality -> forall A:Prop, inhabited A -> (A -> A) = A.
Proof.
  intros Ext A a.
  apply (Ext (A -> A) A); split; [ exact (fun _ => a) | exact (fun _ _ => a) ].
Qed.

Record retract (A B:Prop) : Prop :=
  {f1 : A -> B; f2 : B -> A; f1_o_f2 : forall x:B, f1 (f2 x) = x}.

Lemma prop_ext_retract_A_A_imp_A :
  prop_extensionality -> forall A:Prop, inhabited A -> retract A (A -> A).
Proof.
  intros Ext A a.
  rewrite (prop_ext_A_eq_A_imp_A Ext A a).
  exists (fun x:A => x) (fun x:A => x).
  reflexivity.
Qed.

Record has_fixpoint (A:Prop) : Prop :=
  {F : (A -> A) -> A; Fix : forall f:A -> A, F f = f (F f)}.

Lemma ext_prop_fixpoint :
  prop_extensionality -> forall A:Prop, inhabited A -> has_fixpoint A.
Proof.
  intros Ext A a.
  case (prop_ext_retract_A_A_imp_A Ext A a); intros g1 g2 g1_o_g2.
  exists (fun f => (fun x:A => f (g1 x x)) (g2 (fun x => f (g1 x x)))).
  intro f.
  pattern (g1 (g2 (fun x:A => f (g1 x x)))) at 1.
  rewrite (g1_o_g2 (fun x:A => f (g1 x x))).
  reflexivity.
Qed.

(** Remark: [prop_extensionality] can be replaced in lemma [ext_prop_fixpoint]
    by the weakest property [provable_prop_extensionality].
*)

(************************************************************************)
(** ** CC |- prop_ext /\ dep elim on bool -> proof-irrelevance  *)

(** [proof_irrelevance] asserts equality of all proofs of a given formula *)
Definition proof_irrelevance := forall (A:Prop) (a1 a2:A), a1 = a2.

(** Assume that we have booleans with the property that there is at most 2
    booleans (which is equivalent to dependent case analysis). Consider
    the fixpoint of the negation function: it is either true or false by
    dependent case analysis, but also the opposite by fixpoint. Hence
    proof-irrelevance.

    We then map equality of boolean proofs to proof irrelevance in all
    propositions.
*)

Section Proof_irrelevance_gen.

  Variable bool : Prop.
  Variable true : bool.
  Variable false : bool.
  Hypothesis bool_elim : forall C:Prop, C -> C -> bool -> C.
  Hypothesis
    bool_elim_redl : forall (C:Prop) (c1 c2:C), c1 = bool_elim C c1 c2 true.
  Hypothesis
    bool_elim_redr : forall (C:Prop) (c1 c2:C), c2 = bool_elim C c1 c2 false.
  Let bool_dep_induction :=
  forall P:bool -> Prop, P true -> P false -> forall b:bool, P b.

  Lemma aux : prop_extensionality -> bool_dep_induction -> true = false.
  Proof.
    intros Ext Ind.
    case (ext_prop_fixpoint Ext bool true); intros G Gfix.
    set (neg := fun b:bool => bool_elim bool false true b).
    generalize (eq_refl (G neg)).
    pattern (G neg) at 1.
    apply Ind with (b := G neg); intro Heq.
    rewrite (bool_elim_redl bool false true).
    change (true = neg true); rewrite Heq; apply Gfix.
    rewrite (bool_elim_redr bool false true).
    change (neg false = false); rewrite Heq; symmetry ;
      apply Gfix.
  Qed.

  Lemma ext_prop_dep_proof_irrel_gen :
    prop_extensionality -> bool_dep_induction -> proof_irrelevance.
  Proof.
    intros Ext Ind A a1 a2.
    set (f := fun b:bool => bool_elim A a1 a2 b).
    rewrite (bool_elim_redl A a1 a2).
    change (f true = a2).
    rewrite (bool_elim_redr A a1 a2).
    change (f true = f false).
    rewrite (aux Ext Ind).
    reflexivity.
  Qed.

End Proof_irrelevance_gen.

(** In the pure Calculus of Constructions, we can define the boolean
    proposition bool = (C:Prop)C->C->C but we cannot prove that it has at
    most 2 elements.
*)

Section Proof_irrelevance_Prop_Ext_CC.

  Definition BoolP := forall C:Prop, C -> C -> C.
  Definition TrueP : BoolP := fun C c1 c2 => c1.
  Definition FalseP : BoolP := fun C c1 c2 => c2.
  Definition BoolP_elim C c1 c2 (b:BoolP) := b C c1 c2.
  Definition BoolP_elim_redl (C:Prop) (c1 c2:C) :
    c1 = BoolP_elim C c1 c2 TrueP := eq_refl c1.
  Definition BoolP_elim_redr (C:Prop) (c1 c2:C) :
    c2 = BoolP_elim C c1 c2 FalseP := eq_refl c2.

  Definition BoolP_dep_induction :=
    forall P:BoolP -> Prop, P TrueP -> P FalseP -> forall b:BoolP, P b.

  Lemma ext_prop_dep_proof_irrel_cc :
    prop_extensionality -> BoolP_dep_induction -> proof_irrelevance.
  Proof.
    exact (ext_prop_dep_proof_irrel_gen BoolP TrueP FalseP BoolP_elim BoolP_elim_redl
      BoolP_elim_redr).
  Qed.

End Proof_irrelevance_Prop_Ext_CC.

(** Remark: [prop_extensionality] can be replaced in lemma
    [ext_prop_dep_proof_irrel_gen] by the weakest property
    [provable_prop_extensionality].
*)

(************************************************************************)
(** ** CIC |- prop. ext. -> proof-irrelevance                   *)

(** In the Calculus of Inductive Constructions, inductively defined booleans
    enjoy dependent case analysis, hence directly proof-irrelevance from
    propositional extensionality.
*)

Section Proof_irrelevance_CIC.

  Inductive boolP : Prop :=
    | trueP : boolP
    | falseP : boolP.
  Definition boolP_elim_redl (C:Prop) (c1 c2:C) :
    c1 = boolP_ind C c1 c2 trueP := eq_refl c1.
  Definition boolP_elim_redr (C:Prop) (c1 c2:C) :
    c2 = boolP_ind C c1 c2 falseP := eq_refl c2.
  Scheme boolP_indd := Induction for boolP Sort Prop.

  Lemma ext_prop_dep_proof_irrel_cic : prop_extensionality -> proof_irrelevance.
  Proof.
    exact (fun pe =>
      ext_prop_dep_proof_irrel_gen boolP trueP falseP boolP_ind boolP_elim_redl
      boolP_elim_redr pe boolP_indd).
  Qed.

End Proof_irrelevance_CIC.

(** Can we state proof irrelevance from propositional degeneracy
  (i.e. propositional extensionality + excluded middle) without
  dependent case analysis ?

  Berardi [[Berardi90]] built a model of CC interpreting inhabited
  types by the set of all untyped lambda-terms. This model satisfies
  propositional degeneracy without satisfying proof-irrelevance (nor
  dependent case analysis). This implies that the previous results
  cannot be refined.

  [[Berardi90]] Stefano Berardi, "Type dependence and constructive
  mathematics", Ph. D. thesis, Dipartimento Matematica, Università di
  Torino, 1990.
*)

(************************************************************************)
(** ** CC |- excluded-middle + dep elim on bool -> proof-irrelevance *)

(** This is a proof in the pure Calculus of Construction that
    classical logic in [Prop] + dependent elimination of disjunction entails
    proof-irrelevance.

    Reference:

    [[Coquand90]] T. Coquand, "Metamathematical Investigations of a
    Calculus of Constructions", Proceedings of Logic in Computer Science
    (LICS'90), 1990.

    Proof skeleton: classical logic + dependent elimination of
    disjunction + discrimination of proofs implies the existence of a
    retract from [Prop] into [bool], hence inconsistency by encoding any
    paradox of system U- (e.g. Hurkens' paradox).
*)

Require Import Hurkens.

Section Proof_irrelevance_EM_CC.

  Variable or : Prop -> Prop -> Prop.
  Variable or_introl : forall A B:Prop, A -> or A B.
  Variable or_intror : forall A B:Prop, B -> or A B.
  Hypothesis or_elim : forall A B C:Prop, (A -> C) -> (B -> C) -> or A B -> C.
  Hypothesis
    or_elim_redl :
    forall (A B C:Prop) (f:A -> C) (g:B -> C) (a:A),
      f a = or_elim A B C f g (or_introl A B a).
  Hypothesis
    or_elim_redr :
    forall (A B C:Prop) (f:A -> C) (g:B -> C) (b:B),
      g b = or_elim A B C f g (or_intror A B b).
  Hypothesis
    or_dep_elim :
    forall (A B:Prop) (P:or A B -> Prop),
      (forall a:A, P (or_introl A B a)) ->
      (forall b:B, P (or_intror A B b)) -> forall b:or A B, P b.

  Hypothesis em : forall A:Prop, or A (~ A).
  Variable B : Prop.
  Variables b1 b2 : B.

  (** [p2b] and [b2p] form a retract if [~b1=b2] *)

  Let p2b A := or_elim A (~ A) B (fun _ => b1) (fun _ => b2) (em A).
  Let b2p b := b1 = b.

  Lemma p2p1 : forall A:Prop, A -> b2p (p2b A).
  Proof.
    unfold p2b; intro A; apply or_dep_elim with (b := em A);
      unfold b2p; intros.
    apply (or_elim_redl A (~ A) B (fun _ => b1) (fun _ => b2)).
    destruct (b H).
  Qed.

  Lemma p2p2 : b1 <> b2 -> forall A:Prop, b2p (p2b A) -> A.
  Proof.
    intro not_eq_b1_b2.
    unfold p2b; intro A; apply or_dep_elim with (b := em A);
      unfold b2p; intros.
    assumption.
    destruct not_eq_b1_b2.
    rewrite <- (or_elim_redr A (~ A) B (fun _ => b1) (fun _ => b2)) in H.
    assumption.
  Qed.

  (** Using excluded-middle a second time, we get proof-irrelevance *)

  Theorem proof_irrelevance_cc : b1 = b2.
  Proof.
    refine (or_elim _ _ _ _ _ (em (b1 = b2))); intro H.
    trivial.
    apply (NoRetractFromSmallPropositionToProp.paradox B p2b b2p (p2p2 H) p2p1).
  Qed.

End Proof_irrelevance_EM_CC.

(** Hurkens' paradox still holds with a retract from the _negative_
    fragment of [Prop] into [bool], hence weak classical logic,
    i.e. [forall A, ~A\/~~A], is enough for deriving a weak version of
    proof-irrelevance. This is enough to derive a contradiction from a
    [Set]-bound weak excluded middle wih an impredicative [Set]
    universe. *)

Section Proof_irrelevance_WEM_CC.

  Variable or : Prop -> Prop -> Prop.
  Variable or_introl : forall A B:Prop, A -> or A B.
  Variable or_intror : forall A B:Prop, B -> or A B.
  Hypothesis or_elim : forall A B C:Prop, (A -> C) -> (B -> C) -> or A B -> C.
  Hypothesis
    or_elim_redl :
    forall (A B C:Prop) (f:A -> C) (g:B -> C) (a:A),
      f a = or_elim A B C f g (or_introl A B a).
  Hypothesis
    or_elim_redr :
    forall (A B C:Prop) (f:A -> C) (g:B -> C) (b:B),
      g b = or_elim A B C f g (or_intror A B b).
  Hypothesis
    or_dep_elim :
    forall (A B:Prop) (P:or A B -> Prop),
      (forall a:A, P (or_introl A B a)) ->
      (forall b:B, P (or_intror A B b)) -> forall b:or A B, P b.

  Hypothesis wem : forall A:Prop, or (~~A) (~ A).

  Local Notation NProp := NoRetractToNegativeProp.NProp.
  Local Notation El := NoRetractToNegativeProp.El.

  Variable B : Prop.
  Variables b1 b2 : B.

  (** [p2b] and [b2p] form a retract if [~b1=b2] *)

  Let p2b (A:NProp) := or_elim (~~El A) (~El A) B (fun _ => b1) (fun _ => b2) (wem (El A)).
  Let b2p b : NProp := exist (fun P=>~~P -> P) (~~(b1 = b)) (fun h x => h (fun k => k x)).

  Lemma wp2p1 : forall A:NProp, El A -> El (b2p (p2b A)).
  Proof.
    intros A. unfold p2b.
    apply or_dep_elim with  (b := wem (El A)).
    + intros nna a.
      rewrite <- or_elim_redl.
      cbn. auto.
    + intros n x.
      destruct (n x).
  Qed.

  Lemma wp2p2 : b1 <> b2 -> forall A:NProp, El (b2p (p2b A)) -> El A.
  Proof.
    intro not_eq_b1_b2.
    intros A. unfold p2b.
    apply or_dep_elim with  (b := wem (El A)).
    + cbn.
      intros x _.
      destruct A. cbn in x |- *.
      auto.
    + intros na.
      rewrite <- or_elim_redr. cbn.
      intros h. destruct (h not_eq_b1_b2).
  Qed.

  (** By Hurkens's paradox, we get a weak form of proof irrelevance. *)

  Theorem wproof_irrelevance_cc : ~~(b1 = b2).
  Proof.
    intros h.
    unshelve (refine (let NB := exist (fun P=>~~P -> P) B _ in _)).
    { exact (fun _ => b1). }
    pose proof (NoRetractToNegativeProp.paradox NB p2b b2p (wp2p2 h) wp2p1) as paradox.
    unshelve (refine (let F := exist (fun P=>~~P->P) False _ in _)).
    { auto. }
    exact (paradox F).
  Qed.

End Proof_irrelevance_WEM_CC.

(************************************************************************)
(** ** CIC |- excluded-middle -> proof-irrelevance               *)

(**
    Since, dependent elimination is derivable in the Calculus of
    Inductive Constructions (CCI), we get proof-irrelevance from classical
    logic in the CCI.
*)

Section Proof_irrelevance_CCI.

  Hypothesis em : forall A:Prop, A \/ ~ A.

  Definition or_elim_redl (A B C:Prop) (f:A -> C) (g:B -> C)
    (a:A) : f a = or_ind f g (or_introl B a) := eq_refl (f a).
  Definition or_elim_redr (A B C:Prop) (f:A -> C) (g:B -> C)
    (b:B) : g b = or_ind f g (or_intror A b) := eq_refl (g b).
  Scheme or_indd := Induction for or Sort Prop.

  Theorem proof_irrelevance_cci : forall (B:Prop) (b1 b2:B), b1 = b2.
  Proof.
    exact (proof_irrelevance_cc or or_introl or_intror or_ind or_elim_redl
      or_elim_redr or_indd em).
  Qed.

End Proof_irrelevance_CCI.

(** The same holds with weak excluded middle. The proof is a little
    more involved, however. *)

Section Weak_proof_irrelevance_CCI.

  Hypothesis wem : forall A:Prop, ~~A \/ ~ A.

  Theorem wem_proof_irrelevance_cci : forall (B:Prop) (b1 b2:B), ~~b1 = b2.
  Proof.
    exact (wproof_irrelevance_cc or or_introl or_intror or_ind or_elim_redl
      or_elim_redr or_indd wem).
  Qed.

End Weak_proof_irrelevance_CCI.

(** Remark: in the Set-impredicative CCI, Hurkens' paradox still holds with
    [bool] in [Set] and since [~true=false] for [true] and [false]
    in [bool] from [Set], we get the inconsistency of
    [em : forall A:Prop, {A}+{~A}] in the Set-impredicative CCI.
*)

(** * Weak classical axioms *)

(** We show the following increasing in the strength of axioms:
 - weak excluded-middle
 - right distributivity of implication over disjunction and Gödel-Dummett axiom
 - independence of general premises and drinker's paradox
 - excluded-middle
*)

(** ** Weak excluded-middle *)

(** The weak classical logic based on [~~A \/ ~A] is referred to with
    name KC in [[ChagrovZakharyaschev97]]

   [[ChagrovZakharyaschev97]] Alexander Chagrov and Michael
   Zakharyaschev, "Modal Logic", Clarendon Press, 1997.
*)

Definition weak_excluded_middle :=
  forall A:Prop, ~~A \/ ~A.

(** The interest in the equivalent variant
    [weak_generalized_excluded_middle] is that it holds even in logic
    without a primitive [False] connective (like Gödel-Dummett axiom) *)

Definition weak_generalized_excluded_middle :=
  forall A B:Prop, ((A -> B) -> B) \/ (A -> B).

(** ** Gödel-Dummett axiom *)

(** [(A->B) \/ (B->A)] is studied in [[Dummett59]] and is based on [[Gödel33]].

    [[Dummett59]] Michael A. E. Dummett. "A Propositional Calculus
    with a Denumerable Matrix", In the Journal of Symbolic Logic, Vol
    24 No. 2(1959), pp 97-103.

    [[Gödel33]] Kurt Gödel. "Zum intuitionistischen Aussagenkalkül",
    Ergeb. Math. Koll. 4 (1933), pp. 34-38.
 *)

Definition GodelDummett := forall A B:Prop, (A -> B) \/ (B -> A).

Lemma excluded_middle_Godel_Dummett : excluded_middle -> GodelDummett.
Proof.
  intros EM A B. destruct (EM B) as [HB|HnotB].
  left; intros _; exact HB.
  right; intros HB; destruct (HnotB HB).
Qed.

(** [(A->B) \/ (B->A)] is equivalent to [(C -> A\/B) -> (C->A) \/ (C->B)]
    (proof from [[Dummett59]]) *)

Definition RightDistributivityImplicationOverDisjunction :=
  forall A B C:Prop, (C -> A\/B) -> (C->A) \/ (C->B).

Lemma Godel_Dummett_iff_right_distr_implication_over_disjunction :
  GodelDummett <-> RightDistributivityImplicationOverDisjunction.
Proof.
  split.
    intros GD A B C HCAB.
    destruct (GD B A) as [HBA|HAB]; [left|right]; intro HC;
      destruct (HCAB HC) as [HA|HB]; [ | apply HBA | apply HAB | ]; assumption.
    intros Distr A B.
    destruct (Distr A B (A\/B)) as [HABA|HABB].
      intro HAB; exact HAB.
      right; intro HB; apply HABA; right; assumption.
      left; intro HA; apply HABB; left; assumption.
Qed.

(** [(A->B) \/ (B->A)] is stronger than the weak excluded middle *)

Lemma Godel_Dummett_weak_excluded_middle :
  GodelDummett -> weak_excluded_middle.
Proof.
  intros GD A. destruct (GD (~A) A) as [HnotAA|HAnotA].
    left; intro HnotA; apply (HnotA (HnotAA HnotA)).
    right; intro HA; apply (HAnotA HA HA).
Qed.

(** ** Independence of general premises and drinker's paradox *)

(** Independence of general premises is the unconstrained, non
    constructive, version of the Independence of Premises as
    considered in [[Troelstra73]].

    It is a generalization to predicate logic of the right
    distributivity of implication over disjunction (hence of
    Gödel-Dummett axiom) whose own constructive form (obtained by a
    restricting the third formula to be negative) is called
    Kreisel-Putnam principle [[KreiselPutnam57]].

    [[KreiselPutnam57]], Georg Kreisel and Hilary Putnam. "Eine
    Unableitsbarkeitsbeweismethode für den intuitionistischen
    Aussagenkalkül". Archiv für Mathematische Logik und
    Graundlagenforschung, 3:74- 78, 1957.

    [[Troelstra73]], Anne Troelstra, editor. Metamathematical
    Investigation of Intuitionistic Arithmetic and Analysis, volume
    344 of Lecture Notes in Mathematics, Springer-Verlag, 1973.
*)

Definition IndependenceOfGeneralPremises :=
  forall (A:Type) (P:A -> Prop) (Q:Prop),
    inhabited A -> (Q -> exists x, P x) -> exists x, Q -> P x.

Lemma
  independence_general_premises_right_distr_implication_over_disjunction :
  IndependenceOfGeneralPremises -> RightDistributivityImplicationOverDisjunction.
Proof.
  intros IP A B C HCAB.
  destruct (IP bool (fun b => if b then A else B) C true) as ([|],H).
    intro HC; destruct (HCAB HC); [exists true|exists false]; assumption.
    left; assumption.
    right; assumption.
Qed.

Lemma independence_general_premises_Godel_Dummett :
  IndependenceOfGeneralPremises -> GodelDummett.
Proof.
  destruct Godel_Dummett_iff_right_distr_implication_over_disjunction.
  auto using independence_general_premises_right_distr_implication_over_disjunction.
Qed.

(** Independence of general premises is equivalent to the drinker's paradox *)

Definition DrinkerParadox :=
  forall (A:Type) (P:A -> Prop),
    inhabited A -> exists x, (exists x, P x) -> P x.

Lemma independence_general_premises_drinker :
  IndependenceOfGeneralPremises <-> DrinkerParadox.
Proof.
  split.
    intros IP A P InhA; apply (IP A P (exists x, P x) InhA); intro Hx; exact Hx.
    intros Drinker A P Q InhA H; destruct (Drinker A P InhA) as (x,Hx).
      exists x; intro HQ; apply (Hx (H HQ)).
Qed.

(** Independence of general premises is weaker than (generalized)
    excluded middle

Remark: generalized excluded middle is preferred here to avoid relying on
the "ex falso quodlibet" property (i.e. [False -> forall A, A])
*)

Definition generalized_excluded_middle :=
  forall A B:Prop, A \/ (A -> B).

Lemma excluded_middle_independence_general_premises :
  generalized_excluded_middle -> DrinkerParadox.
Proof.
  intros GEM A P x0.
  destruct (GEM (exists x, P x) (P x0)) as [(x,Hx)|Hnot].
    exists x; intro; exact Hx.
    exists x0; exact Hnot.
Qed.

(** * Axioms equivalent to classical logic *)

(** ** Principle of unrestricted minimization *)

Require Import Coq.Arith.PeanoNat.

Definition Minimal (P:nat -> Prop) (n:nat) : Prop :=
  P n /\ forall k, P k -> n<=k.

Definition Minimization_Property (P : nat -> Prop) : Prop :=
  forall n, P n -> exists m, Minimal P m.

Section Unrestricted_minimization_entails_excluded_middle.

  Hypothesis unrestricted_minimization: forall P, Minimization_Property P.

  Theorem unrestricted_minimization_entails_excluded_middle : forall A, A\/~A.
  Proof.
    intros A.
    pose (P := fun n:nat => n=0/\A \/ n=1).
    assert (P 1) as h.
    { unfold P. intuition. }
    assert (P 0 <-> A) as p₀.
    { split.
      + intros [[_ h₀]|[=]]. assumption.
      + unfold P. tauto. }
    apply unrestricted_minimization in h as ([|[|m]] & hm & hmm).
    + intuition.
    + right.
      intros HA. apply p₀, hmm, PeanoNat.Nat.nle_succ_0 in HA. assumption.
    + destruct hm as [([=],_) | [=] ].
  Qed.

End Unrestricted_minimization_entails_excluded_middle.

Require Import Wf_nat.

Section Excluded_middle_entails_unrestricted_minimization.

  Hypothesis em : forall A, A\/~A.

  Theorem excluded_middle_entails_unrestricted_minimization :
    forall P, Minimization_Property P.
  Proof.
    intros P n HPn.
    assert (dec : forall n, P n \/ ~ P n) by auto using em.
    assert (ex : exists n, P n) by (exists n; assumption).
    destruct (dec_inh_nat_subset_has_unique_least_element P dec ex) as (n' & HPn' & _).
    exists n'. assumption.
  Qed.

End Excluded_middle_entails_unrestricted_minimization.

(** However, minimization for a given predicate does not necessarily imply
    decidability of this predicate *)

Section Example_of_undecidable_predicate_with_the_minimization_property.

  Variable s : nat -> bool.

  Let P n := exists k, n<=k /\ s k = true.

  Example undecidable_predicate_with_the_minimization_property :
    Minimization_Property P.
  Proof.
    unfold Minimization_Property.
    intros h hn.
    exists 0. split.
    + unfold P in *. destruct hn as (k&hk₁&hk₂).
      exists k. split.
      * rewrite <- hk₁.
        apply PeanoNat.Nat.le_0_l.
      * assumption.
    + intros **. apply PeanoNat.Nat.le_0_l.
  Qed.

End Example_of_undecidable_predicate_with_the_minimization_property.

(** ** Choice of representatives in a partition of bool *)

(** This is similar to Bell's "weak extensional selection principle"  in [[Bell]]

   [[Bell]] John L. Bell, Choice principles in intuitionistic set theory, unpublished.
*)

Require Import RelationClasses.

Local Notation representative_boolean_partition :=
  (forall R:bool->bool->Prop,
    Equivalence R -> exists f, forall x, R x (f x) /\ forall y, R x y -> f x = f y).

Theorem representative_boolean_partition_imp_excluded_middle :
  representative_boolean_partition -> excluded_middle.
Proof.
  intros ReprFunChoice P.
  pose (R (b1 b2 : bool) := b1 = b2 \/ P).
  assert (Equivalence R).
  { split.
    - now left.
    - destruct 1. now left. now right.
    - destruct 1, 1; try now right. left; now transitivity y. }
  destruct (ReprFunChoice R H) as (f,Hf). clear H.
  destruct (Bool.bool_dec (f true) (f false)) as [Heq|Hneq].
  + left.
     destruct (Hf false) as ([Hfalse|HP],_); try easy.
     destruct (Hf true) as ([Htrue|HP],_); try easy.
     congruence.
  + right. intro HP.
     destruct (Hf true) as (_,H). apply Hneq, H. now right.
Qed.

Theorem excluded_middle_imp_representative_boolean_partition :
  excluded_middle -> representative_boolean_partition.
Proof.
  intros EM R H.
  destruct (EM (R true false)).
  - exists (fun _ => true).
    intros []; firstorder.
  - exists (fun b => b).
    intro b. split.
    + reflexivity.
    + destruct b, y; intros HR; easy || now symmetry in HR.
Qed.

Theorem excluded_middle_iff_representative_boolean_partition :
  excluded_middle <-> representative_boolean_partition.
Proof.
  split; auto using excluded_middle_imp_representative_boolean_partition,
                    representative_boolean_partition_imp_excluded_middle.
Qed.


Require Import Coq.ZArith.ZArith. Local Open Scope Z_scope.
Require Import Coq.micromega.Lia.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import coqutil.Tactics.fwd coqutil.Tactics.Tactics.
Require Import coqutil.Datatypes.ZList.
Require Import coqutil.Map.Interface coqutil.Map.Properties.
Require Import coqutil.Word.Interface coqutil.Word.Properties coqutil.Word.Bitwidth.
Require Import coqutil.Word.LittleEndianList.
Require Import coqutil.Map.OfListWord.
Require Import bedrock2.Lift1Prop.
Require Import bedrock2.ZnWords.
Require Import bedrock2.Map.Separation bedrock2.Map.SeparationLogic.
Require Import bedrock2.PurifySep.

Import ZList.List.ZIndexNotations.
Local Open Scope zlist_scope.

(* TODO move *)
Module List.
  Section WithA.
    Context [A: Type].

    Lemma split_at: forall n (l: list A), l = l[:n] ++ l[n:].
    Proof.
      intros. unfold List.upto, List.from. symmetry. apply List.firstn_skipn.
    Qed.

    Lemma len_nil: len (@nil A) = 0.
    Proof. intros. reflexivity. Qed.

    Lemma len_cons: forall a (l: list A), len (a :: l) = 1 + len l.
    Proof. intros. simpl (List.length (a :: l)). lia. Qed.

    Lemma len_app: forall (l1 l2: list A), len (l1 ++ l2) = len l1 + len l2.
    Proof. intros. rewrite List.app_length. lia. Qed.
  End WithA.
End List.

Undelimit Scope sep_scope.

(* PredTp equals `Z -> mem -> Prop` if the predicate takes any number of values
   and its size depends on these values.
   PredTp equals `V1 -> ... -> Vn -> Z -> mem -> Prop` for some `V1..Vn` if the
   predicate takes `n` values, but its size does not depend on these values. *)
Definition PredicateSize{PredTp: Type}(pred: PredTp) := Z.
Existing Class PredicateSize.

(* Derives the size of a value-independent predicate applied to a value *)
#[export] Hint Extern 4 (PredicateSize (?pred ?v)) =>
  lazymatch constr:(_: PredicateSize pred) with
  | ?sz => exact sz
  end
: typeclass_instances.

(* Note: Not using a Section here because `Hint Extern` declared inside a Section cannot
   be exported) *)

Definition sepapp{key value}{mem: map.map key value}
  (P1 P2: Z -> mem -> Prop){P1size: PredicateSize P1}: Z -> mem -> Prop :=
  fun addr => sep (P1 addr) (P2 (addr + P1size)).

#[export] Hint Extern 1 (PredicateSize (sepapp ?P1 ?P2)) =>
  lazymatch constr:(_: PredicateSize P1) with
  | ?sz1 => lazymatch constr:(_: PredicateSize P2) with
            | ?sz2 => exact (sz1 + sz2)
            end
  end
: typeclass_instances.

(* Every memory predicate with a given start address and size should satisfy
   this bounds check.
   By wrapping any memory predicate in this range_ok predicate, we can assert
   that it indeed satisfies this bounds check.
   The NULL pointer may not be used as an address, but arrays whose last byte
   is just at 2^width-1 are allowed.
   This guarantees that the size of an array always fits into a word, and in
   particular, that two adjacent arrays whose size fits into a word can be
   combined into an array whose size fits into a word as well, without requiring
   any Z inequalities as preconditions. *)
Definition range_ok{width}{word: word width}{mem: map.map word Byte.byte}
  (pred: Z -> mem -> Prop){size: PredicateSize pred}: Z -> mem -> Prop :=
  fun start => sep (emp (0 < start /\ start + size <= 2 ^ width)) (pred start).

#[export] Hint Extern 1 (PredicateSize (range_ok ?pred)) =>
  lazymatch constr:(_: PredicateSize pred) with
  | ?sz => exact sz
  end
: typeclass_instances.

(* Note: Instead of wrapping a predicate pred inside range_ok, we could also
   assert `checks_range pred`:

    Definition checks_range(pred: Z -> mem -> Prop){size: PredicateSize pred}: Prop :=
      forall start m, pred start m -> 0 < start /\ start + size <= 2 ^ width.

   But in order to create predicates that satisfy checks_range, we'd still need
   range_ok, so we might as well just use only range_ok (or occasianally, assert
   `range_ok pred = pred`). *)

Lemma range_ok_idemp{width}{word: word width}{word_ok: word.ok word}
  {mem: map.map word Byte.byte}{mem_ok: map.ok mem}
  (pred: Z -> mem -> Prop){size: PredicateSize pred}:
  range_ok (range_ok pred) = range_ok pred.
Proof.
  unfold range_ok. extensionality addr. eapply iff1ToEq. split; intros.
  - eapply sep_emp_l in H. eapply proj2 in H. exact H.
  - eapply sep_emp_l. split. 2: exact H. eapply sep_emp_l in H.
    eapply proj1 in H. exact H.
Qed.

Lemma sepapp_range_ok{width}{word: word width}{word_ok: word.ok word}
  {mem: map.map word Byte.byte}{mem_ok: map.ok mem}
  (P1 P2: Z -> mem -> Prop){P1size: PredicateSize P1}{P2size: PredicateSize P2}:
  sepapp (range_ok P1) (range_ok P2) = range_ok (sepapp (range_ok P1) (range_ok P2)).
Proof.
  unfold range_ok, sepapp. extensionality start. eapply iff1ToEq.
  reify_goal.
  cancel_seps_at_indices 1%nat 2%nat. 1: reflexivity.
  cancel_seps_at_indices 2%nat 3%nat. 1: reflexivity.
  cbn [seps]. split; intros.
  - eapply sep_emp_l in H. destruct H. destruct H0. subst x.
    eapply sep_emp_l. split. 1: lia.
    eapply sep_emp_l. split. 1: lia.
    split. 2: lia. reflexivity.
  - eapply sep_emp_l in H. destruct H. eapply sep_emp_l in H0. destruct H0. destruct H1.
    subst x.
    eapply sep_emp_l. split. 1: lia. split. 2: lia. reflexivity.
Qed.

Definition pure_at_raw{key value}{mem: map.map key value}(P: Prop)(addr: Z):
  mem -> Prop := emp P.
#[export] Hint Extern 1 (PredicateSize (pure_at_raw ?P)) => exact 0 : typeclass_instances.
#[export] Hint Opaque pure_at_raw : typeclass_instances. (* to avoid confusion with hole *)

Definition pure_at{width}{word: word width}{mem: map.map word Byte.byte}(P: Prop):
  Z -> mem -> Prop := range_ok (pure_at_raw P).
#[export] Hint Extern 1 (PredicateSize (pure_at _)) => exact 0 : typeclass_instances.
#[export] Hint Opaque pure_at : typeclass_instances.

Definition hole_raw{key value}{mem: map.map key value}(n addr: Z): mem -> Prop := emp True.
#[export] Hint Extern 1 (PredicateSize (hole_raw ?n)) => exact n : typeclass_instances.
#[export] Hint Opaque hole_raw : typeclass_instances.

Definition hole{width}{word: word width}{mem: map.map word Byte.byte}(n: Z):
  Z -> mem -> Prop := range_ok (hole_raw n).
#[export] Hint Extern 1 (PredicateSize (hole ?n)) => exact n : typeclass_instances.
#[export] Hint Opaque hole : typeclass_instances.

Definition array_raw{width}{word: word width}{mem: map.map word Byte.byte}{T: Type}
  (elem: T -> Z -> mem -> Prop){elemSize: PredicateSize elem}:
  list T -> Z -> mem -> Prop :=
  fix rec xs :=
    match xs with
    | nil => pure_at_raw True
    | cons h tl => sepapp (elem h) (rec tl)
    end.

#[export] Hint Extern 1 (PredicateSize (@array_raw ?width ?word ?mem ?T ?elem ?elemSize ?vs)) =>
  exact (len vs * elemSize) : typeclass_instances.

(* Note: 0 <= elemSize is required to ensure that start+elemSize does not become
   negative, and making the inequality strict is convenient because then range_ok
   implies that n fits into a word (which would not be the case if elemSize=0
   because upper-bounding n*0=0 has no effect. *)
Definition array{width}{BW: Bitwidth width}{word: word width}
  {mem: map.map word Byte.byte}{T: Type}
  (elem: T -> Z -> mem -> Prop){elemSize: PredicateSize elem}
  (n: Z)(vs: list T): Z -> mem -> Prop :=
  sepapp (pure_at (len vs = n /\ 0 < elemSize)) (range_ok (array_raw elem vs)).

(* Note: We don't pass a list ?vs to the pattern, because the length is already given by n *)
#[export] Hint Extern 1
  (PredicateSize (@array ?width ?BW ?word ?mem ?T ?elem ?elemSize ?n)) =>
  exact (n * elemSize) : typeclass_instances.

Section WithMem.
  Context {width}{word: word width}{word_ok: word.ok word}.
  Context {mem: map.map word Byte.byte}{mem_ok: map.ok mem}.

  Lemma sep_assoc_eq: forall (p q r: mem -> Prop),
      sep (sep p q) r = sep p (sep q r).
  Proof.
    intros. eapply iff1ToEq. eapply sep_assoc.
  Qed.

  Lemma sepapp_pure_at_raw_True_l: forall (p: Z -> mem -> Prop),
      sepapp (pure_at_raw True) p = p.
  Proof.
    unfold sepapp, pure_at_raw. intros. extensionality addr. eapply iff1ToEq.
    rewrite Z.add_0_r. eapply sep_emp_True_l.
  Qed.

  Lemma sepapp_pure_at_raw_True_r: forall (p: Z -> mem -> Prop) {sz: PredicateSize p},
      sepapp p (pure_at_raw True) = p.
  Proof.
    unfold sepapp, pure_at_raw. intros. extensionality addr. eapply iff1ToEq.
    eapply sep_emp_True_r.
  Qed.

  Lemma sepapp_assoc(P1 P2 P3: Z -> mem -> Prop)
    {sz1: PredicateSize P1}{sz2: PredicateSize P2}:
    sepapp (sepapp P1 P2) P3 = sepapp P1 (sepapp P2 P3).
  Proof.
    unfold sepapp. extensionality addr.
    rewrite sep_assoc_eq. rewrite Z.add_assoc.
    reflexivity.
  Qed.
End WithMem.

Section ArrayLemmas.
  Context {width}{BW: Bitwidth width}{word: word width}{word_ok: word.ok word}.
  Context {mem: map.map word Byte.byte}{mem_ok: map.ok mem}.
  Context {T: Type}(elem: T -> Z -> mem -> Prop){elemSize: PredicateSize elem}.

  Lemma purify_array: forall n vs a,
      purify (array elem n vs a)
        (len vs = n /\
         0 < elemSize /\
         0 < a /\
         a + n * elemSize <= 2 ^ width).
  Proof.
    unfold purify, array, sepapp, pure_at, pure_at_raw, range_ok. intros.
    rewrite ?sep_assoc_eq in H.
    repeat (eapply sep_emp_l in H; destruct H as (? & H)). lia.
  Qed.

  Lemma array_raw_app xs ys:
    array_raw elem (xs ++ ys) = sepapp (array_raw elem xs) (array_raw elem ys).
  Proof.
    induction xs.
    - simpl. symmetry. apply sepapp_pure_at_raw_True_l.
    - change (array_raw elem ((a :: xs) ++ ys)) with
        (sepapp (elem a) (array_raw elem (xs ++ ys))).
      rewrite IHxs.
      change (array_raw elem (a :: xs)) with (sepapp (elem a) (array_raw elem xs)).
      rewrite <- sepapp_assoc. extensionality addr. unfold sepapp. f_equal.
      f_equal. change (len (a :: xs)) with (Z.of_nat (S (length xs))). lia.
  Qed.

  (* given a goal of the form (iff1 LHS RHS), where LHS and RHS only consist
     of sep and emp, turns it into purely propositional goals *)
  Ltac de_emp :=
    intro m'; split; intros Hm;
      rewrite ?sep_assoc_eq in Hm;
      rewrite ?sep_assoc_eq;
      repeat match goal with
        | H: sep (emp _) _ _ |- _ => eapply sep_emp_l in H; destruct H
        | H: emp _ _ |- _ => destruct H
        end;
      subst;
      repeat match goal with
        | |- sep (emp _) _ _ => eapply sep_emp_l
        | |- _ /\ _ => split
        | |- emp _ map.empty => refine (conj eq_refl _)
        end.

  Lemma array_split(i: Z)(n: Z)(vs: list T):
    0 <= i <= n ->
    array elem n vs = sepapp (array elem i vs[:i]) (array elem (n-i) vs[i:]).
  Proof.
    intros.
    extensionality addr. etransitivity.
    { eapply f_equal2. 2: reflexivity. apply (List.split_at i). }
    unfold array. rewrite array_raw_app.
    unfold sepapp, pure_at, pure_at_raw, range_ok.
    rewrite ?Z.add_0_r.
    eapply assume_pure_of_sides_of_sep_eq.
    1,2: purify_rec.
    intros.
    assert (len vs[:i] + len vs[i:] = len vs). {
      rewrite (List.split_at i vs) at 3. rewrite List.len_app. reflexivity.
    }
    rewrite List.len_app in *.
    rewrite List.len_upto by lia.
    eapply iff1ToEq. cancel. cbn [seps].
    de_emp; lia.
  Qed.

  Lemma array_cons(n: Z)(v: T)(vs: list T):
    array elem n (v :: vs) = sepapp (range_ok (elem v)) (array elem (n-1) vs).
  Proof.
    intros.
    change (v :: vs) with ([|v|] ++ vs).
    extensionality addr.
    eapply assume_pure_of_sides_of_sep_eq.
    { eapply purify_array. }
    { unfold sepapp. eapply purify_sep_skip_l. eapply purify_array. }
    intros.
    rewrite List.len_app, List.len_cons, List.len_nil in *.
    rewrite (array_split 1) by lia.
    unfold sepapp. rewrite Z.mul_1_l.
    f_equal.
    unfold array. simpl (len ([|v|] ++ vs)[:1]).
    simpl (array_raw elem ([|v|] ++ vs)[:1]).
    unfold sepapp, pure_at, range_ok, pure_at_raw.
    rewrite Z.add_0_r. eapply iff1ToEq.
    cancel. cbn [seps]. de_emp; lia.
  Qed.

  Lemma array_merge(n1 n2: Z)(vs1 vs2: list T):
    sepapp (array elem n1 vs1) (array elem n2 vs2) =
      sepapp (pure_at (len vs1 = n1 /\ len vs2 = n2))
             (array elem (n1 + n2) (vs1 ++ vs2)).
  Proof.
  Admitted.

End ArrayLemmas.

#[export] Hint Resolve purify_array : purify.

Definition nbits_to_nbytes(nbits: Z): Z := (Z.max 0 nbits + 7) / 8.

Lemma nbits_to_nbytes_nonneg: forall nbits, 0 <= nbits_to_nbytes nbits.
Proof. intros. unfold nbits_to_nbytes. Z.to_euclidean_division_equations. lia. Qed.

Lemma nbits_to_nbytes_8: forall n, 0 <= n -> nbits_to_nbytes (8 * n) = n.
Proof.
  intros. unfold nbits_to_nbytes. Z.to_euclidean_division_equations. lia.
Qed.

(*
Fixpoint le_combine_z(bytes: list Z): Z :=
  match bytes with
  | nil => 0
  | h :: t => Z.lor h (Z.shiftl (le_combine_z t) 8)
  end.
*)
Definition le_combine_z(bytes: list Z): Z :=
  le_combine (List.map Byte.byte.of_Z bytes).

(* Just for internal use, as long as uint is not defined yet.
   Prefer `array (uint 8)`, because it takes a `list Z` instead of a `list byte`,
   so fewer conversions are needed, and generic array lemmas can be reused. *)
Definition bytearray{width}{word: word width}{mem: map.map word Byte.byte}
  (bs: list Byte.byte)(addr: Z)(m: mem): Prop :=
  m = map.of_list_word_at (word.of_Z addr) bs.

#[export] Hint Extern 1 (PredicateSize (bytearray ?bs)) =>
  exact (len bs) : typeclass_instances.

Definition uint{width}{BW: Bitwidth width}{word: word width}{mem: map.map word Byte.byte}
  (nbits: Z)(v: Z): Z -> mem -> Prop :=
  sepapp (pure_at (0 <= v < 2 ^ nbits))
    (range_ok (bytearray (LittleEndianList.le_split (Z.to_nat (nbits_to_nbytes nbits)) v))).

#[export] Hint Extern 1 (PredicateSize (uint ?nbits)) =>
  let sz := lazymatch isZcst nbits with
            | true => eval cbv in (nbits_to_nbytes nbits)
            | false => constr:(nbits_to_nbytes nbits)
            end in
  exact sz
: typeclass_instances.

Lemma purify_uint{width: Z}{BW: Bitwidth width}{word: word width}{word_ok: word.ok word}
  {mem: map.map word Byte.byte}{mem_ok: map.ok mem}: forall a v nbits,
    purify (mem := mem) (uint nbits v a)
      (0 <= v < 2 ^ nbits /\
       0 < a /\
       a + nbits_to_nbytes nbits <= 2 ^ width).
Proof.
  unfold purify, uint, pure_at, pure_at_raw, range_ok, sepapp. intros.
  rewrite !sep_assoc_eq in H.
  repeat (eapply sep_emp_l in H; destruct H as (? & H)).
  rewrite length_le_split in H2.
  pose proof nbits_to_nbytes_nonneg nbits.
  lia.
Qed.

#[export] Hint Resolve purify_uint : purify.

Section ScalarsLemmas.
  Context {width}{BW: Bitwidth width}{word: word width}{word_ok: word.ok word}.
  Context {mem: map.map word Byte.byte}{mem_ok: map.ok mem}.

  (* Note: rhs is weaker because it doesn't guarantee len bs = L nor that all
     bs are between 0 and 256, so sometimes, one might want to keep the array
     statement around, and pose a new hypothesis about the same memory with the uint *)
  Lemma bytes_to_uint: forall L (bs: list Z) addr,
      impl1 (array (uint 8) L bs addr) (uint (8 * L) (le_combine_z bs) addr).
  Proof.
    intros.
    unfold array, impl1. unfold uint at 2. unfold sepapp.
    unfold pure_at, pure_at_raw, range_ok.
    intro m.
    rewrite Z.add_0_r.
    rewrite length_le_split.
    intros.
    repeat (rewrite ?sep_assoc_eq in H; eapply sep_emp_l in H; destruct H as (? & H)).
    fwd.
    rewrite nbits_to_nbytes_8 by lia.
    rewrite ?sep_assoc_eq. eapply sep_emp_l. split; [assumption | ].
    rewrite ?sep_assoc_eq. eapply sep_emp_l. split. {
      clear -H word_ok mem_ok.
      revert m addr H. induction bs; intros.
      - unfold le_combine_z, le_combine. simpl. lia.
      - unfold le_combine_z. rewrite List.len_cons.
        rewrite List.map_cons. unfold le_combine. fold le_combine.
        simpl in H. unfold sepapp in H.
        destruct H as (m1 & m2 & Sp & H1 & H2).
        eapply purify_uint in H1. fwd.
        specialize (IHbs _ _ H2).
        rewrite Byte.byte.unsigned_of_Z.
        unfold Byte.byte.wrap. rewrite Z.mod_small by assumption.
        unfold le_combine_z in *.
        rewrite BitOps.or_to_plus.
        2: {
          eapply Z.bits_inj_0.
          intro i.
          rewrite Z.land_spec.
          assert (i < 0 \/ 0 <= i < 8 \/ 8 <= i) as C by lia.
          destruct C as [C | [C | C ] ].
          - rewrite Z.testbit_neg_r by assumption. reflexivity.
          - rewrite Z.shiftl_spec by lia.
            rewrite (Z.testbit_neg_r _ (i - 8)) by lia.
            apply Bool.andb_false_r.
          - rewrite (@prove_Zeq_bitwise.testbit_above 8) by lia. reflexivity.
        }
        rewrite Z.shiftl_mul_pow2 by lia.
        replace (8 * (1 + len bs)) with (8 + 8 * len bs) by lia.
        rewrite Z.pow_add_r by lia. lia.
    }
    rewrite ?sep_assoc_eq. eapply sep_emp_l. split. 1: lia.
    unfold le_combine_z.
    replace (Z.to_nat (len bs)) with (length (List.map Byte.byte.of_Z bs)).
    2: {
      rewrite List.map_length. lia.
    }
    rewrite split_le_combine.
    revert addr m H0 H2p0 H2p1 H. clear H1p1.
    induction bs; intros.
    - simpl. unfold array_raw, pure_at_raw, emp in H. fwd.
      unfold bytearray. symmetry. eapply map.of_list_word_nil.
    - unfold bytearray in *. cbn.
      rewrite map.of_list_word_at_cons.
      unfold array_raw, sepapp in H. destruct H as (m1 & m2 & Sp & Hm1 & Hm2).
      unfold uint, sepapp, pure_at, pure_at_raw, range_ok in Hm1.
      repeat (rewrite ?sep_assoc_eq in Hm1; eapply sep_emp_l in Hm1;
              destruct Hm1 as (? & Hm1)).
      change (Z.to_nat (nbits_to_nbytes 8)) with 1%nat in Hm1.
      unfold le_split, bytearray in Hm1.
      rewrite map.of_list_word_singleton in Hm1.
      unfold map.split in Sp. fwd. subst m1.
      rewrite map.putmany_comm by assumption.
      rewrite <- map.put_putmany_commute.
      rewrite map.putmany_empty_r. rewrite Z.add_0_r. f_equal.
      rewrite List.len_cons in *.
      replace (word.add (word.of_Z addr) (word.of_Z 1)) with
        (word.of_Z (word := word) (addr + 1)).
      2: {
        eapply word.unsigned_inj.
        destruct width_cases as [E | E]; rewrite E in *; ZnWords.
      }
      eapply IHbs; try lia. exact Hm2.
  Qed.

End ScalarsLemmas.
Declare Scope sepapp_scope.
Infix "*+" := sepapp (at level 36, left associativity) : sepapp_scope.


Require Import SpecCert.Formalism.
Require Import SpecCert.Smm.Delta.Invariant.
Require Import SpecCert.x86.

Lemma enable_interrupt_inv:
  preserve_inv EnableInterrupt.
Proof.
  unfold preserve_inv.
  unfold inv.
  unfold smramc_inv, smram_code_inv, smrr_inv, cache_clean_inv.
  intros a a' [Hsmramc [Hsmram [Hsmrr Hclean]]] Hpre Hpost.
  unfold x86_postcondition, enable_interrupt_post, enable_interrupt in Hpost.
  rewrite Hpost.
  simpl.
  do 3 (try split); trivial.
Qed.


(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model Uniproc model *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
Definition noid r : relation events := r ⊓ !id.
Definition RR r := r ⊓ [R] ⋅ top ⋅ [R].
Definition RW r := r ⊓ [R] ⋅ top ⋅ [W].
Definition WR r := r ⊓ [W] ⋅ top ⋅ [R].
Definition WW r := r ⊓ [W] ⋅ top ⋅ [W].
Definition obsco := WW po_loc ⊔ (rf ⋅ RW po_loc ⊔ (noid (WR po_loc ⋅ rf°) ⊔ noid (rf ⋅ (RR po_loc ⋅ rf°)))).
Definition cobase := obsco ⊔ co0.
Definition co := cobase^+.
Definition fr := noid (rf° ⋅ co).
Definition mfence : relation events := (*failed: try fencerel MFENCE with 0*) 0.
Definition lfence : relation events := (*failed: try fencerel LFENCE with 0*) 0.
Definition sfence : relation events := (*failed: try fencerel SFENCE with 0*) 0.
Definition dmb_st : relation events := (*failed: try fencerel DMB.ST with 0*) 0.
Definition dsb_st : relation events := (*failed: try fencerel DSB.ST with 0*) 0.
Definition dmb : relation events := (*failed: try fencerel DMB with 0*) 0.
Definition dsb : relation events := (*failed: try fencerel DSB with 0*) 0.
Definition isb : relation events := (*failed: try fencerel ISB with 0*) 0.
Definition ctrlisb : relation events := (*failed: try ctrlcfence ISB with 0*) 0.
Definition sync : relation events := (*failed: try fencerel SYNC with 0*) 0.
Definition lwsync : relation events := (*failed: try fencerel LWSYNC with 0*) 0.
Definition eieio : relation events := (*failed: try fencerel EIEIO with 0*) 0.
Definition isync : relation events := (*failed: try fencerel ISYNC with 0*) 0.
Definition ctrlisync : relation events := (*failed: try ctrlcfence ISYNC with 0*) 0.
Definition DMB_ISH := (*failed: try DMB.ISH with emptyset_0*) emptyset_0.
Definition DMB_ISHLD := (*failed: try DMB.ISHLD with emptyset_0*) emptyset_0.
Definition DMB_ISHST := (*failed: try DMB.ISHST with emptyset_0*) emptyset_0.
Definition DSB_ISH := (*failed: try DSB.ISH with emptyset_0*) emptyset_0.
Definition DSB_ISHLD := (*failed: try DSB.ISHLD with emptyset_0*) emptyset_0.
Definition DSB_ISHST := (*failed: try DSB.ISHST with emptyset_0*) emptyset_0.
Definition DMB_SY := (*failed: try DMB.SY with emptyset_0*) emptyset_0.
Definition DMB_ST := (*failed: try DMB.ST with emptyset_0*) emptyset_0.
Definition DMB_LD := (*failed: try DMB.LD with emptyset_0*) emptyset_0.
Definition DSB_SY := (*failed: try DSB.SY with emptyset_0*) emptyset_0.
Definition DSB_ST := (*failed: try DSB.ST with emptyset_0*) emptyset_0.
Definition DSB_LD := (*failed: try DSB.LD with emptyset_0*) emptyset_0.
Definition DMB_OSH := (*failed: try DMB.OSH with emptyset_0*) emptyset_0.
Definition DSB_OSH := (*failed: try DSB.OSH with emptyset_0*) emptyset_0.
Definition DMB_OSHLD := (*failed: try DMB.OSHLD with emptyset_0*) emptyset_0.
Definition DSB_OSHLD := (*successful: try DSB.OSH with emptyset_0*) DSB_OSH.
Definition DMB_OSHST := (*failed: try DMB.OSHST with emptyset_0*) emptyset_0.
Definition DSB_OSHST := (*failed: try DSB.OSHST with emptyset_0*) emptyset_0.
Definition ISB := (*failed: try ISB with emptyset_0*) emptyset_0.
Definition A := (*failed: try A with emptyset_0*) emptyset_0.
Definition L := (*failed: try L with emptyset_0*) emptyset_0.
Definition Q := (*failed: try Q with emptyset_0*) emptyset_0.
Definition NoRet := (*failed: try NoRet with emptyset_0*) emptyset_0.
Definition dmb_ish := fencerel DMB_ISH.
Definition dmb_ishld := fencerel DMB_ISHLD.
Definition dmb_ishst := fencerel DMB_ISHST.
Definition dmb_fullsy := fencerel DMB_SY.
Definition dmb_fullst := fencerel DMB_ST.
Definition dmb_fullld := fencerel DMB_LD.
Definition dmb_sy := dmb_fullsy ⊔ dmb_ish.
Definition dmb_st_0 := dmb_fullst ⊔ dmb_ishst.
Definition dmb_ld := dmb_fullld ⊔ dmb_ishld.
Definition dsb_sy := fencerel DSB_SY.
Definition dsb_st_0 := fencerel DSB_ST.
Definition dsb_ld := fencerel DSB_LD.
Definition isb_0 := fencerel ISB.
Definition ctrlisb_0 := (*successful: try ctrlcfence ISB with 0*) ctrlcfence ISB.
Definition ctrlcfence_0 := ctrlisb_0 ⊔ ctrlisync.
Definition uniproc := irreflexive co.
Definition witness_conditions := True.
Definition model_conditions := uniproc.
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW noid RR RW WR WW obsco cobase co fr mfence lfence sfence dmb_st dsb_st dmb dsb isb ctrlisb sync lwsync eieio isync ctrlisync DMB_ISH DMB_ISHLD DMB_ISHST DSB_ISH DSB_ISHLD DSB_ISHST DMB_SY DMB_ST DMB_LD DSB_SY DSB_ST DSB_LD DMB_OSH DSB_OSH DMB_OSHLD DSB_OSHLD DMB_OSHST DSB_OSHST ISB A L Q NoRet dmb_ish dmb_ishld dmb_ishst dmb_fullsy dmb_fullst dmb_fullld dmb_sy dmb_st_0 dmb_ld dsb_sy dsb_st_0 dsb_ld isb_0 ctrlisb_0 ctrlcfence_0 uniproc witness_conditions model_conditions : cat.

Definition valid (c : candidate) := model_conditions c.

(* End of translation of model Uniproc model *)


Require Import Coq.omega.Omega.
Require Import Platform.AutoSep Platform.Wrap Platform.StringOps Platform.Malloc Platform.ArrayOps Platform.Buffers Platform.Bags.
Require Import Platform.SinglyLinkedList Platform.ListSegment Platform.RelDb.

Set Implicit Arguments.

Local Hint Extern 1 (@eq W _ _) => words.

(** * Inserting into a table *)

Opaque mult.
Local Infix ";;" := SimpleSeq : SP_scope.

Section Insert.
  Variable A : Type.
  Variable invPre : A -> vals -> HProp.
  Variable invPost : A -> vals -> W -> HProp.

  Variable tptr : W.
  Variable sch : schema.
  Variable bufSize : W.

  (* "WHERE" clause *)
  Variable es : list exp.

  (* Precondition and postcondition *)
  Definition invar :=
    Al a : A, Al bs,
    PRE[V] array8 bs (V "buf") * table sch tptr * mallocHeap 0
      * [| length bs = wordToNat (V "len") |] * [| inputOk V es |] * invPre a V
    POST[R] array8 bs (V "buf") * invPost a V R.

  (* Write the value of an expression into a new row's buffer. *)
  Definition writeExp (col : nat) (e : exp) : chunk :=
    match e with
      | Const s => StringWrite "ibuf" "ilen" "ipos" "overflowed" s
        (fun (p : list B * A) V => array8 (fst p) (V "buf") * mallocHeap 0 * table sch tptr
          * Ex cols, (V "row" ==*> V "ibuf", V "ilen") * array (posl cols) (V "row" ^+ $8)
          * array (lenl cols) (V "row" ^+ $8 ^+ $ (length sch * 4))
          * [| length (fst p) = wordToNat (V "len") |] * [| length cols = length sch |]
          * [| V "row" <> 0 |] * [| freeable (V "row") (2 + length sch + length sch) |]
          * [| V "ibuf" <> 0 |] * [| freeable8 (V "ibuf") (wordToNat (V "ilen")) |]
          * [| inBounds (V "ilen") (firstn col cols) |] * [| inputOk V es |] * invPre (snd p) V)%Sep
        (fun _ (p : list B * A) V R => array8 (fst p) (V "buf") * invPost (snd p) V R)%Sep
      | Input start len =>
        "tmp" <- "ilen" - "ipos";;
        If ("tmp" < len) {
        "overflowed" <- 1
        } else {
          Call "array8"!"copy"("ibuf", "ipos", "buf", start, len)
          [Al a : A, Al bs, Al bsI,
            PRE[V] array8 bs (V "buf") * table sch tptr
              * [| V "ipos" <= V "ilen" |]%word
              * array8 bsI (V "ibuf") * [| length bsI = wordToNat (V "ilen") |] * [| V "ibuf" <> 0 |]
              * [| freeable8 (V "ibuf") (wordToNat (V "ilen")) |]
              * Ex cols, (V "row" ==*> V "ibuf", V "ilen") * array (posl cols) (V "row" ^+ $8)
              * array (lenl cols) (V "row" ^+ $8 ^+ $ (length sch * 4))
              * [| length bs = wordToNat (V "len") |] * [| length cols = length sch |]
              * [| V "row" <> 0 |] * [| freeable (V "row") (2 + length sch + length sch) |]
              * [| V "ibuf" <> 0 |] * [| freeable8 (V "ibuf") (wordToNat (V "ilen")) |]
              * [| inBounds (V "ilen") (firstn col cols) |] * [| inputOk V es |]
              * [| V len <= V "ilen" ^- V "ipos" |]%word
              * invPre a V * mallocHeap 0
            POST[R] array8 bs (V "buf") * invPost a V R];;
          "ipos" <- "ipos" + len
        }
    end%SP.

  Definition winv' (col : nat) :=
    Al a : A, Al bs, Al bsI,
      PRE[V] array8 bs (V "buf") * table sch tptr * mallocHeap 0
        * array8 bsI (V "ibuf") * [| length bsI = wordToNat (V "ilen") |]
        * [| V "ipos" <= V "ilen" |]
        * Ex cols, (V "row" ==*> V "ibuf", V "ilen") * array (posl cols) (V "row" ^+ $8)
        * array (lenl cols) (V "row" ^+ $8 ^+ $ (length sch * 4))
        * [| length bs = wordToNat (V "len") |] * [| length cols = length sch |]
        * [| V "row" <> 0 |] * [| freeable (V "row") (2 + length sch + length sch) |]
        * [| V "ibuf" <> 0 |] * [| freeable8 (V "ibuf") (wordToNat (V "ilen")) |]
        * [| inBounds (V "ilen") (firstn col cols) |] * [| inputOk V es |] * invPre a V
      POST[R] array8 bs (V "buf") * invPost a V R.

  Definition winv (col : nat) := winv' col true (fun w => w).

  Fixpoint writeExps (col : nat) (es : list exp) {struct es} : chunk :=
    match es with
      | nil => Skip
      | e :: es' =>
        (* Save the current position as the start of the current column. *)
        "tmp" <- "row" + 8;;
        "tmp" + (4 * col)%nat *<- "ipos";;

        (* Check if the current item is small enough to fit in the buffer. *)
        "tmp" <- "ilen" - "ipos";;
        If ("tmp" < lengthOf e) {
          (* It doesn't fit.  Save the "safe" length 0.  [writeExp] will set "overflowed" later. *)
          "tmp" <- "row" + 8;;
          "tmp" <- "tmp" + (length sch * 4)%nat;;
          "tmp" + (4 * col)%nat *<- 0
        } else {
          (* Good, it fits.  Save the proper length. *)
          "tmp" <- "row" + 8;;
          "tmp" <- "tmp" + (length sch * 4)%nat;;
          "tmp" + (4 * col)%nat *<- lengthOf e
        };;
        Assert [winv' (S col)];;
        writeExp (S col) e;;
        writeExps (S col) es'
    end%SP.

  Definition Insert' : chunk := (
    "ibuf" <-- Call "buffers"!"bmalloc"(bufSize)
    [Al a : A, Al bs,
      PRE[V, R] R =?>8 (wordToNat bufSize * 4) * [| R <> 0 |] * [| freeable R (wordToNat bufSize) |]
        * array8 bs (V "buf") * table sch tptr * mallocHeap 0
        * [| length bs = wordToNat (V "len") |] * [| inputOk V es |] * invPre a V
      POST[R'] array8 bs (V "buf") * invPost a V R'];;

    "row" <-- Call "malloc"!"malloc"(0, (2 + length sch + length sch)%nat)
    [Al a : A, Al bs, Al bsI,
      PRE[V, R] array8 bsI (V "ibuf") * [| length bsI = (wordToNat bufSize * 4)%nat |] * [| V "ibuf" <> 0 |]
        * [| freeable (V "ibuf") (wordToNat bufSize) |]
        * R =?> (2 + length sch + length sch)%nat * [| R <> 0 |]
        * [| freeable R (2 + length sch + length sch)%nat |]
        * array8 bs (V "buf") * table sch tptr * mallocHeap 0
        * [| length bs = wordToNat (V "len") |] * [| inputOk V es |] * invPre a V
      POST[R'] array8 bs (V "buf") * invPost a V R'];;

    "row" *<- "ibuf";;
    "ipos" <- 0;;
    "ilen" <- (4 * bufSize)%word;;
    "row"+4 *<- "ilen";;

    Note [expand_allocated 8];;

    writeExps O es;;

    "tmp" <-- Call "malloc"!"malloc"(0, 2)
    [Al a : A, Al bs,
      PRE[V, R] R =?> 2 * [| R <> 0 |] * [| freeable R 2 |]
        * row sch (V "row") * array8 bs (V "buf") * table sch tptr * mallocHeap 0
        * [| length bs = wordToNat (V "len") |] * [| inputOk V es |] * invPre a V
      POST[R'] array8 bs (V "buf") * invPost a V R'];;

    "tmp" *<- "row";;
    "tmp"+4 *<- $[tptr];;
    tptr *<- "tmp"
  )%SP.

  Section writeExps_correct.
    Variable mn : string.
    Variable im : LabelMap.t assert.
    Variable H : importsGlobal im.
    Variable ns : list string.
    Variable res : nat.

    Hypothesis not_rp : ~In "rp" ns.
    Hypothesis included : incl baseVars ns.
    Hypothesis reserved : (res >= 10)%nat.
    Hypothesis wellFormed : wfExps ns es.

    Hypothesis weakenPre : (forall a V V', (forall x, x <> "ibuf" -> x <> "row" -> x <> "ilen" -> x <> "tmp"
      -> x <> "ipos" -> x <> "overflowed" -> sel V x = sel V' x)
    -> invPre a V ===> invPre a V').

    Hypothesis weakenPost : (forall a V V' R, (forall x, x <> "ibuf" -> x <> "row" -> x <> "ilen" -> x <> "tmp"
      -> x <> "ipos" -> x <> "overflowed" -> sel V x = sel V' x)
    -> invPost a V R = invPost a V' R).

    Hypothesis copy : "array8"!"copy" ~~ im ~~> ArrayOps.copyS.

    Lemma writeExp_correct_vcs : forall e col pre,
      wfExp ns e
      -> In e es
      -> (forall specs st,
        interp specs (pre st)
        -> interp specs (winv col ns res st))
      -> vcs (VerifCond (toCmd (writeExp col e) mn (im := im) H ns res pre)).
      destruct e; wrap0.

      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
      v.
    Qed.

    Lemma writeExp_correct_post : forall e col pre,
      wfExp ns e
      -> In e es
      -> (forall specs st,
        interp specs (pre st)
        -> interp specs (winv col ns res st))
      -> forall specs st,
        interp specs (Postcondition (toCmd (writeExp col e) mn (im := im) H ns res pre) st)
        -> interp specs (winv col ns res st).
      destruct e; wrap0.

      v.
      v.
      v.
    Qed.

    Hypothesis length_es : length es = length sch.
    Hypothesis goodSize_sch : goodSize (length sch).

    Ltac split_IH := intros;
      match goal with
        | [ IH : forall pre : settings * state -> PropX _ _, _ |- _ ] =>
          generalize (fun a b c d e => proj1 (IH a b c d e));
            generalize (fun a b c d e => proj2 (IH a b c d e));
              clear IH; intros
      end;
      match goal with
        | [ H : incl (_ :: _) _ |- _ ] => apply incl_peel in H; destruct H
      end.

    Ltac basic_eauto :=
      match goal with
        | [ |- forall x, _ ] => idtac
        | [ |- Logic.ex _ ] => idtac
        | _ => simpl in *; eauto
      end.

    Lemma inBounds_move : forall ilen n m ls,
      inBounds ilen (firstn (S (n - S m)) ls)
      -> (S m <= n)%nat
      -> inBounds ilen (firstn (n - m) ls).
      intros; replace (n - m) with (S (n - S m)) by omega; auto.
    Qed.

    Hint Immediate inBounds_move.

    Lemma inBounds_wiggle : forall ilen n m col ls,
      inBounds ilen (firstn m ls)
      -> col = m - S n
      -> (S n <= m)%nat
      -> inBounds ilen (match ls with nil => nil | x :: ls' => x :: firstn (n + col) ls' end).
      intros; subst; replace m with (S (n + (m - S n))) in * |- by omega; auto.
    Qed.

    Hint Immediate inBounds_wiggle.

    Hint Rewrite Minus.le_plus_minus_r using (simpl in *; omega) : sepFormula.

    Ltac use_IH :=
      match goal with
        | [ col := ?E |- _ ] =>
          match goal with
            | [ |- appcontext[writeExps (S col)] ] =>
              change (writeExps (S col)) with (writeExps (S E))
          end; rewrite moveS by assumption;
          match goal with
            | [ H : forall x : settings * state -> PropX _ _, _ |- _ ] =>
              apply H; basic_eauto
          end

        | [ H : interp _ (Postcondition (toCmd (writeExps (S ?col) _) _ _ _ _ _) _),
            H' : forall a, wfExps _ _ -> _ |- _ ] =>
          unfold col in H; rewrite moveS in H by (simpl in *; omega);
            eapply H' in H; basic_eauto

        | _ => eapply writeExp_correct_vcs; basic_eauto
        | [ H : interp _ (Postcondition _ _) |- _ ] => eapply writeExp_correct_post in H; basic_eauto
      end; pre.

    Ltac we := repeat use_IH; t; my_descend.
    Ltac swe := solve [ we ].
    Ltac awe := abstract we.

    Lemma writeExps_correct : forall es0 pre,
      wfExps ns es0
      -> incl es0 es
      -> (length es0 <= length es)%nat
      -> let col := length es - length es0 in
        (forall specs st,
          interp specs (pre st)
          -> interp specs (winv col ns res st))
        -> vcs (VerifCond (toCmd (writeExps col es0) mn (im := im) H ns res pre))
        /\ (forall specs st,
          interp specs (Postcondition (toCmd (writeExps col es0) mn (im := im) H ns res pre) st)
          -> interp specs (winv (length es0 + col) ns res st)).
      induction es0.

      wrap0.

      split_IH.
      wrap0.
      wrap0.

      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
      awe.
    Qed.
  End writeExps_correct.

  Notation InsertVcs := (fun im ns res =>
    (~In "rp" ns) :: incl baseVars ns
    :: (forall a V V', (forall x, x <> "ibuf" -> x <> "row" -> x <> "ilen" -> x <> "tmp"
      -> x <> "ipos" -> x <> "overflowed" -> sel V x = sel V' x)
      -> invPre a V ===> invPre a V')
    :: (forall a V V' R, (forall x, x <> "ibuf" -> x <> "row" -> x <> "ilen" -> x <> "tmp"
      -> x <> "ipos" -> x <> "overflowed" -> sel V x = sel V' x)
      -> invPost a V R = invPost a V' R)
    :: (res >= 10)%nat
    :: (bufSize >= natToW 2)
    :: goodSize (2 + length sch + length sch)
    :: goodSize (4 * wordToNat bufSize)
    :: wfExps ns es
    :: "buffers"!"bmalloc" ~~ im ~~> bmallocS
    :: "malloc"!"malloc" ~~ im ~~> mallocS
    :: "array8"!"copy" ~~ im ~~> ArrayOps.copyS
    :: (length es = length sch)
    :: goodSize (length sch)
    :: nil).

  Hint Immediate incl_refl.

  Require Import Coq.Arith.Div2.

  Lemma div2_double : forall n, div2 (n + n) = n.
    apply div2_double'.
  Qed.

  Hint Rewrite div2_double : sepFormula.

  Lemma four_duh : forall n,
    goodSize (4 * wordToNat bufSize)
    -> n = wordToNat bufSize * 4
    -> n = wordToNat (natToW 4 ^* bufSize).
    intros; subst.
    rewrite wordToNat_wmult.
    change (wordToNat (natToW 4)) with 4; omega.
    auto.
  Qed.

  Hint Immediate four_duh.

  Lemma inBounds_nil : forall n, inBounds n nil.
    intros; hnf; auto.
  Qed.

  Hint Immediate inBounds_nil.

  Lemma firstn_all : forall A (ls : list A) n,
    n = length ls
    -> firstn n ls = ls.
    intros; subst; induction ls; simpl; intuition.
  Qed.

  Hint Rewrite firstn_all using congruence : sepFormula.

  Ltac writeExps' :=
    try match goal with
          | [ H : ?E = _ |- match ?E with None => _ | _ => _ end ] =>
            rewrite H; post
        end;
    edestruct writeExps_correct; repeat rewrite Minus.minus_diag, Plus.plus_0_r in *;
      try match goal with
            | [ |- vcs _ ] => eauto
            | [ H : interp _ (Postcondition _ _), H' : _ |- _ ] => apply H' in H
          end; eauto; try rewrite Minus.minus_diag in *.

  Ltac writeExps :=
    match goal with
      | [ |- context[writeExps] ] => writeExps'
      | [ _ : context[writeExps] |- _ ] => writeExps'
    end.

  Lemma prove_freeable8 : forall p size,
    freeable p (wordToNat size)
    -> goodSize (4 * wordToNat size)
    -> freeable8 p (wordToNat (natToW 4 ^* size)).
    intros; rewrite wordToNat_wmult; change (wordToNat (natToW 4)) with 4; hnf; eauto.
  Qed.

  Hint Immediate prove_freeable8.

  Ltac i := abstract (try writeExps; t).

  Definition Insert : chunk.
    refine (WrapC Insert'
      invar
      invar
      InsertVcs
      _ _); abstract (wrap0; i).
  Defined.

End Insert.


(* -*- coq-prog-args: ("-top" "HTS.Overture" "-type-in-type") -*-  *)
Require Export ModelStructure.Overture.
Set Universe Polymorphism.

Axiom dummy_pfibrant_type : Type.
Class PFibrant {A: Type} (P: A -> Type) := { dummy_pfibrant_value : dummy_pfibrant_type }.

Axiom PFibrant_irrelevance : ∀ {A: Type} {P: A -> Type} (p q: PFibrant P),
    p ≡ q.

Notation "'Fibrant' A" := (PFibrant (λ _:unit, A)) (at level 30) : Fib_scope.
Notation "'PFibrant2' P" := (PFibrant (λ w, P w.1 w.2)) (at level 30) : Fib_scope.
Notation "'PFibrant3' P" := (PFibrant (λ w, P w.1 w.2.1 w.2.2)) (at level 30) : Fib_scope.
Open Scope Fib_scope.

Record FType := {
  FType_T : Type;
  FType_F : Fibrant FType_T
}.

Arguments Build_FType _ {_}.

Coercion FType_T : FType >-> Sortclass.
Global Existing Instance FType_F.

Axiom fibrant_Type : Fibrant Type.
(* Axiom fibrant_FType : Fibrant FType. *)

Axiom pfibrant_compose
  : forall A (B: A -> Type) {FibB: PFibrant B} A' (f: A' -> A), PFibrant (B o f).

Axiom pfibrant_forall : ∀ {A: Type} {B: A -> Type} {C: ∀ x, B x -> Type},
    PFibrant2 C -> PFibrant (λ x, ∀ y, C x y).

Axiom pfibrant_sigma : ∀ {A: Type} {B: A -> Type} {C: ∀ x, B x -> Type},
    PFibrant2 C -> PFibrant (λ x, ∃ y, C x y).

Instance fibrant_pfibrant A (B: A -> Type) {FibP: PFibrant B}
  : ∀ x, Fibrant (B x)
  := λ x, pfibrant_compose A B unit (λ _, x).

Instance fibrant_sigma A (B: A -> Type)
  : PFibrant B -> Fibrant (sigT B).
Proof.
  intros.
  ref (@pfibrant_sigma unit (λ _, A) (λ _ x, B x) _).
Defined.

Instance pfibrant_constant A B {FibB: Fibrant B}
  : PFibrant (λ _:A, B) | 50
  := pfibrant_compose unit (λ _, B) A (λ _, tt).

Instance pfibrant2_fibrant A (B: A -> Type) (C: forall x, B x -> Type) (H: PFibrant2 C)
  : forall x y, Fibrant (C x y).
intros x y; exact (@fibrant_pfibrant _ _ H (x; y)).
Defined.

Instance pfibrant2_pfibrant A (B: A -> Type) (C: forall x, B x -> Type) (H: PFibrant2 C)
  : forall x, PFibrant (C x) | 50.
intros x. exact (pfibrant_compose (sigT B) _ _ (λ y : B x, (x; y))).
Defined.

Instance pfibrant2_pfibrant_constant A B (C: A -> B -> Type) (H: PFibrant2 C)
  : forall x, PFibrant (C x).
intros x. exact (pfibrant_compose (sigT (λ _, B)) _ _ (λ y, (x; y))).
Defined.

Instance pfibrant2_pfibrant'_constant A B (C: A -> B -> Type) (H: PFibrant2 C)
  : forall y, PFibrant (λ x, C x y) | 50.
intros y. exact (pfibrant_compose _ _ _ (λ x, (x; y))).
Defined.

Module Export Paths.
  Private Inductive paths {A : Type} {FibA: Fibrant A} (a : A) : A -> Type :=
    idpath : paths a a.

  Arguments idpath {A FibA a} , [A FibA] a.

  Definition paths_ind (A : Type) {FibA: Fibrant A} (a : A)
             (P : forall a0 : A, paths a a0 -> Type) {FibP: PFibrant (λ w, P w.1 w.2)}
             (f: P a idpath) (y : A) (p : paths a y) : P y p
    := match p as p0 in (paths _ y0) return (P y0 p0) with
       | idpath => f
       end.
  Arguments paths_ind [A] [_] a P [_] f y p.

  Definition paths_rec (A : Type) {FibA: Fibrant A} (a : A) (P : A -> Type)
             {FibP: PFibrant P} (f : P a) (y : A) (p : paths a y)
    : P y :=
    match p in (paths _ y0) return (P y0) with
    | idpath => f
    end.

  Axiom pfibrant_paths : PFibrant (λ (X: ∃ (A: FType) (x: A), A), @paths X.1 _ X.2.1 X.2.2).

  Instance pfibrant_paths_constant (A: Type) {FibA: Fibrant A}
    : PFibrant2 (@paths A _).
  ref (@pfibrant_compose _ _ pfibrant_paths _ (λ w, (Build_FType A; w.1; w.2))).
  Defined.

  Definition inverse {A : Type} {FibA: Fibrant A} {x y : A} (p : paths x y) : paths y x
    := @paths_rec A _ x (fun y => paths y x) _ idpath y p.

  Definition paths_rec' A {FibA: Fibrant A} a y P {FibP: PFibrant P} (X : P y)
             (H : @paths A FibA a y) : P a
    := @paths_rec A FibA y P FibP X _ (inverse H).

  (* Declare ML Module "myrewrite". *)
End Paths.

Arguments paths_rec [A] [_] a P [_] f y p.

Notation "x = y :> A" := (@paths A _ x y) : type_scope.
Notation "x = y" := (x = y :> _) : type_scope.

Notation "f == g" := (forall x, f x = g x) (at level 70, no associativity) : type_scope.

Axiom path_funext: forall {A} {FibA: Fibrant A} {P: A -> Type} {FibP: PFibrant P}
                          {FibAP: Fibrant (∀ y : A, P y)} {f g : forall x : A, P x},
    f == g -> f = g.

Instance pfibrant_paths_FlFr A (P: A -> Type) {FibP: forall x, Fibrant (P x)}
         (f g: ∀ x, P x)
  : PFibrant (λ x, f x = g x) | 100.
Proof.
  ref (@pfibrant_compose _ _ pfibrant_paths _ (λ x, (Build_FType (P x); f x; g x))).
Defined.

Tactic Notation "rew" open_constr(H)
  := rewrite H; auto with typeclass_instances.
Tactic Notation "rewi" open_constr(H)
  := rewrite <- H; auto with typeclass_instances.

(* Lemma paths_rew_test A {FibA: Fibrant A} a y P {FibP: PFibrant P} (X : P a) (H : a = y :> A) : P y. *)
(* Proof. rewi H. Defined. *)

Lemma paths_rew_r_test A {FibA: Fibrant A} a y P {FibP: PFibrant P} (X : P y) (H : a = y :> A) : P a.
Proof. rew H. Defined.

Definition Eq_to_paths {A : Type} {x y : A} {FibA: Fibrant A} (p : x ≡ y) : x = y :=
  match p with
    | refl => idpath
  end.

Definition concat {A : Type} {FibA: Fibrant A} {x y z : A} (p : x = y) (q : y = z) : x = z.
Proof.
  ref (@paths_rec A _ y (fun z => x = z) _
                  (@paths_rec A _ x (fun y => x = y)_ idpath y p) z q).
  all: ref (pfibrant2_pfibrant _ _ (@paths A _) _ _).
Defined.

Arguments concat {A FibA x y z} !p !q.

Delimit Scope path_scope with path.
Open Scope path_scope.

Notation "p @ q" := (concat p%path q%path) (at level 20) : path_scope.
Notation "p ^" := (inverse p%path) (at level 3, format "p '^'") : path_scope.
Notation "1" := idpath : path_scope.

Definition transport {A : Type} {FibA: Fibrant A} (P : A -> Type)
           {FibP: PFibrant P}  {x y : A} (p : x = y) (u : P x) : P y
  := paths_rec x P u y p.

Arguments transport {A}%type_scope {FibA} P {FibP} {x y} p%path_scope u : simpl nomatch.

Notation "p # x"
  := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope.

Record Contr (A: Type) `{Fibrant A} :=
  { center : A;
    contr : ∀ x, center = x }.

Definition myid : forall A, A -> A := fun _ x => x.
Ltac mark H := let t := type of H in change (myid _ t) in H.
Ltac unmark H := let t := type of H in
                 match t with
                 | myid _ ?tt => change tt in H
                 end.

Ltac destruct_path p :=
  let t := type of p in
  match t with
    @paths _ _ ?x ?y =>
    mark p;
      repeat match goal with
             | [X: context[y] |- _] =>
               match type of X with
               | myid _ _ => fail 1
               | _ => revert X;
                   match goal with
                   | |- forall (X: ?T), ?G => change (forall (X: myid _ T), G)
                   end
               end
             end;
      unmark p;
      generalize y p; clear p y;
      match goal with
      | |- forall y p, @?P y p => let y := fresh y in
                                  let p := fresh p in
                                  intros y p; refine (paths_ind x P _ y p)
      end;
      repeat match goal with
             | |- forall (H: myid _ _), _ => let H := fresh H in
                                             intro H; unfold myid in H
             end
  end.


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

(****************************************************************************)
(*                          Signes Project                                  *)
(*                            2002-2003                                     *)
(*                           Houda ANOUN                                    *)
(*                          Pierre Casteran                                 *)
(*                           LaBRI/INRIA                                    *)
(****************************************************************************)

Require Export Form.
Set Implicit Arguments.
Unset Strict Implicit.

Section Atoms_fixed.
Variable Atoms : Set.

Section semantic_defs.

(* Models for CTL *)

Variables (W : Set) (R : W -> W -> W -> Prop) (v_at : Atoms -> W -> Prop).

(* extension of some valuation on atoms to all formulae *)

Fixpoint val (F : Form Atoms) : W -> Prop :=
  match F with
  | At a => v_at a
  | Dot A B =>
      fun x => exists y : W, (exists z : W, R x y z /\ val A y /\ val B z)
  | Slash C B => fun y => forall x z : W, R x y z -> val B z -> val C x
  | Backslash A C => fun z => forall x y : W, R x y z -> val A y -> val C x
  end.

Definition satisfies (w : W) (A : Form Atoms) : Prop := val A w.

End semantic_defs.

Section model_types.

 (* Kinds of models are caracterized wrt the ternary relation R *)

 Definition model_type := forall W : Set, (W -> W -> W -> Prop) -> Prop.

 Definition model_inter (P1 P2 : model_type) (W : Set)
   (R : W -> W -> W -> Prop) := P1 W R /\ P2 W R.
 Variable P : model_type.

 Definition sem_implies : Form Atoms -> Form Atoms -> Prop :=
   fun A B : Form _ =>
   forall (W : Set) (R : W -> W -> W -> Prop) (v_at : Atoms -> W -> Prop),
   P R -> forall w : W, satisfies R v_at w A -> satisfies R v_at w B.

 (* semantic versions of derivation rules *)

 Lemma ONE : forall A : Form Atoms, sem_implies A A.
 Proof.
  unfold sem_implies, satisfies in |- *; auto.
 Qed.

 Lemma COMP :
  forall A B C : Form Atoms,
  sem_implies A B -> sem_implies B C -> sem_implies A C.
 Proof.
  unfold sem_implies, satisfies in |- *; auto.
 Qed.

 Lemma GAMMA' :
  forall A B C : Form Atoms,
  sem_implies B (Backslash A C) -> sem_implies (Dot A B) C.
 Proof.
  unfold sem_implies, satisfies in |- *; simpl in |- *; auto.
  intros A B C H W R v_at w H0 H1.
  case H1; intros y H2.
  case H2; intros z H3.
  case H3; intros H4 H5.
  case H5; eauto.
 Qed.

 Lemma GAMMA :
  forall A B C : Form _,
  sem_implies (Dot A B) C -> sem_implies B (Backslash A C).
 Proof.
  unfold sem_implies, satisfies in |- *; simpl in |- *; auto.
  intros A B C H W R v_at H0 w H1 x y H2 H3.
  apply H.
  assumption.
  exists y; exists w; auto.
 Qed.

 Lemma BETA' :
  forall A B C : Form Atoms,
  sem_implies A (Slash C B) -> sem_implies (Dot A B) C.
 Proof.
  unfold sem_implies, satisfies in |- *; simpl in |- *; auto.
  intros A B C H W R v_at w H0 H1.
  case H1; intros y H2.
  case H2; intros z H3.
  case H3; intros H4 H5.
  case H5; eauto.
 Qed.

 Lemma BETA :
  forall A B C : Form _, sem_implies (Dot A B) C -> sem_implies A (Slash C B).
 Proof.
  unfold sem_implies, satisfies in |- *; simpl in |- *; auto.
  intros A B C H W R v_at H0 w H1 x y H2 H3.
  apply H.
  assumption.
  exists w; exists y; auto.
 Qed.

 Lemma GAMMA'BETA :
  forall A B C : Form _,
  sem_implies B (Backslash A C) -> sem_implies A (Slash C B).
 Proof.
  unfold sem_implies, satisfies in |- *; simpl in |- *; eauto.
 Qed.

 End model_types.

(* associativity and commutativity *)

 Definition ASS : model_type :=
   fun (W : Set) (R : W -> W -> W -> Prop) =>
   (forall x y z t u : W,
    R t x y -> R u t z -> exists v : W, R v y z /\ R u x v) /\
   (forall x y z v u : W,
    R v y z -> R u x v -> exists t : W, R t x y /\ R u t z).

 Definition COM : model_type :=
   fun (W : Set) (R : W -> W -> W -> Prop) =>
   forall x y z : W, R x y z -> R x z y.

 Section soundness.

 Definition sound (E : arrow_extension) (P : model_type) :=
   forall A B : Form _, arrow E A B -> sem_implies P A B.

 Lemma sem_implies_inter :
  forall (P1 P2 : model_type) (A B : Form _),
  sem_implies P1 A B ->
  sem_implies P2 A B -> sem_implies (model_inter P1 P2) A B.
 Proof.
  unfold model_inter, sem_implies in |- *; intros P1 P2 A B H H0 W R v_at H1.
  case H1; auto.
 Qed.

 Lemma ASS_lemma :
  forall (W : Set) (R : W -> W -> W -> Prop) (v_at : Atoms -> W -> Prop),
  ASS R ->
  forall (A B C : Form _) (w : W),
  satisfies R v_at w (Dot A (Dot B C)) ->
  satisfies R v_at w (Dot (Dot A B) C).
 Proof.
  intros W R v_at H A B C w H0.
  elim H; intros H1 H2.
  clear H; simpl in |- *.
  simpl in H0.
  elim H0; intros y Hy; clear H0.
  elim Hy; intros z Hz; clear Hy.
  elim Hz; intros H3 H4; elim H4; intros H5 H6; clear Hz H4.
  elim H6; intros y0 Hy0; clear H6.
  elim Hy0; intros z0 Hz0; clear Hy0.
  elim Hz0; intros H6 H7; elim H7; intros H8 H9; clear Hz0 H7.
  elim (H2 _ _ _ _ _ H6 H3); intros x H; case H; intros; clear H.
  exists x.
  exists z0; split.
  auto.
  split; auto.
  exists y; exists y0; auto.
 Qed.

 Lemma ASS_lemma_R :
  forall (W : Set) (R : W -> W -> W -> Prop) (v_at : Atoms -> W -> Prop),
  ASS R ->
  forall (A B C : Form _) (w : W),
  satisfies R v_at w (Dot (Dot A B) C) ->
  satisfies R v_at w (Dot A (Dot B C)).
 Proof.
  intros W R v_at H A B C w H0.
  elim H; intros H1 H2.
  clear H; simpl in |- *.
  simpl in H0.
  elim H0; intros y Hy; clear H0.
  elim Hy; intros z Hz; clear Hy.
  elim Hz; intros H3 H4; elim H4; intros H5 H6; clear Hz H4.
  elim H5; intros y0 Hy0; clear H5.
  elim Hy0; intros z0 Hz0; clear Hy0.
  elim Hz0; intros H5 H7; elim H7; intros H8 H9; clear Hz0 H7.
  elim (H1 _ _ _ _ _ H5 H3); intros x H; case H; intros; clear H.
  exists y0.
  exists x; split.
  auto.
  split; auto.
  exists z0; exists z; auto.
 Qed.

 Lemma COM_lemma :
  forall (W : Set) (R : W -> W -> W -> Prop) (v_at : Atoms -> W -> Prop),
  COM R ->
  forall (A B : Form _) (w : W),
  satisfies R v_at w (Dot A B) -> satisfies R v_at w (Dot B A).
 Proof.
  intros W R v_at H A B w H0.
  simpl in |- *.
  simpl in H0.
  case H0; intros y Hy; clear H0.
  case Hy; intros y0 Hy0; clear Hy.
  exists y0; exists y; auto.
  case Hy0.
  simple destruct 2; auto.
 Qed.

 Lemma soundX :
  forall (X : arrow_extension) (P : model_type),
  (forall A B : Form Atoms, X _ A B -> sem_implies P A B) -> sound X P.
 Proof.
  intros X P H.
  unfold sound in |- *; simple induction 1.
  apply ONE.
  intros; eapply COMP; eauto.
  intros; apply GAMMA'BETA; apply GAMMA; auto.
  intros; apply BETA'; assumption.
  intros; apply GAMMA; auto.

intros; apply GAMMA'; assumption.
  exact H.
 Qed.

Lemma soundness_NL : sound NL (fun W R => True).
 Proof.
  apply soundX.
  simple induction 1.
Qed.

 Lemma sound_add :
  forall (E1 E2 : arrow_extension) (M1 M2 : model_type),
  sound E1 M1 ->
  sound E2 M2 -> sound (add_extension E1 E2) (model_inter M1 M2).
 Proof.
  intros E1 E2 M1 M2 H H0; apply soundX.
  unfold add_extension in |- *; simpl in |- *.
  simple induction 1.
  intro H2.
  unfold sem_implies in |- *.
  intros.
  case H3; intros.
  unfold sound in H.
  unfold sem_implies in H.
  eapply H.
  constructor 7.
  eexact H2.
  assumption.
  assumption.
  intro H2.
  unfold model_inter in |- *.
  unfold sem_implies in |- *.
  intros.
  case H3; intros.
  unfold sound in H0.
  unfold sem_implies in H0.
  eapply H0.
  constructor 7.
  eexact H2.
  assumption.
  assumption.
 Qed.

 Lemma sound_NLP : sound NLP COM.
 Proof.
  apply soundX.
  unfold sem_implies in |- *.
  simple destruct 1; intros.
  apply COM_lemma; auto.
 Qed.

 Lemma sound_L : sound L ASS.
 Proof.
  apply soundX.
  unfold sem_implies in |- *.
  simple destruct 1; intros.
  apply ASS_lemma; auto.
  apply ASS_lemma_R; auto.
 Qed.

 Lemma sound_LP : sound LP (model_inter COM ASS).
 Proof.
  unfold LP in |- *; apply sound_add.
  apply sound_NLP.
  apply sound_L.
 Qed.

 End soundness.

 Section completeness.

 Section truth_lemma_spec.

 Variable X : arrow_extension.

 (* the syntactical models *)

 Definition WK : Set := Form Atoms.
 Definition RK (A B C : Form Atoms) := weak (arrow X A (Dot B C)).
 Definition valK (p : Atoms) (A : WK) : Prop := weak (arrow X A (At p)).

 (* The truth lemma (for X) provides us a tool to prove completeness *)

 Definition truth_lemma :=
   forall phi A : Form _, weak (arrow X A phi) <-> satisfies RK valK A phi.

 End truth_lemma_spec.

 Definition model_OK (P : model_type) (X : arrow_extension) := P _ (RK X).

 Definition complete (P : model_type) (X : arrow_extension) :=
   forall A B : Form Atoms, sem_implies P A B -> weak (arrow X A B).

 Lemma truth_lemma_X : forall X : arrow_extension, truth_lemma X.
 Proof.
  intro X.
  unfold truth_lemma, satisfies in |- *; simple induction phi.
  (* atomic formulae *)
  unfold WK, RK, valK in |- *; simpl in |- *; tauto.
  (* phi = C/B *)
  intros C HC B HB A.
  split; intro.
  simpl in |- *; intros x z H0 H1.
  elim (HB A); intros.
  cut (weak (arrow X z B)).
  intro.
  cut (weak (arrow X x C)).
  intro.
  elim (HC x); tauto.
  apply weak_comp with (Dot A B).
  apply weak_comp with (Dot A z).
  apply H0.
  apply weak_Dot_mono_right; auto.
  apply weak_beta'.
  auto.
  elim (HB z); tauto.
  simpl in H.
  apply weak_beta.
  elim (HC (Dot A B)); intros H0 H1.
  apply H1.
  apply (H (Dot A B) B).
  unfold RK in |- *; auto with ctl.
  elim (HB B); intros.
  apply H2.
  auto with ctl.

  (* phi =  (B o C) *)
  intros B HB C HC A.
  split; intro.
  simpl in |- *.
  exists B; exists C.
  split.
  unfold RK in |- *; auto.
  split.
  elim (HB B); auto with ctl.
  elim (HC C); auto with ctl.
  simpl in H; elim H.
  clear H.
  simple induction 1.
  intros x0 H0.
  case H0; intros H1 H2.
  case H2; intros H3 H4.
  apply weak_comp with (Dot x x0).
  apply H1.
  apply weak_comp with (Dot B x0).
  apply weak_Dot_mono_left.
  elim (HB x); auto.
  apply weak_Dot_mono_right.
  elim (HC x0); auto.

  (* phi = A\C *)
  intros A HA C HC B.
  split; intro.
  simpl in |- *.
  intros x y H0 H1.
  elim (HC (Dot A B)); intros H2 H3.
  elim (HC x); intros.
  apply H4.
  apply weak_comp with (Dot A B).
  apply weak_comp with (Dot y B).
  auto.
  apply weak_Dot_mono_left.
  elim (HA y); auto.
  apply weak_gamma'.
  auto.
  apply weak_gamma.
  simpl in H.
  elim (HC (Dot A B)); intros.
  apply H1.
  eapply H.
  unfold RK in |- *; apply weak_one.
  elim (HA A); auto with ctl.
 Qed.

 Lemma compl_X :
  forall (X : arrow_extension) (A B : Form Atoms),
  (forall w : WK,
   satisfies (RK X) (valK X) w A -> satisfies (RK X) (valK X) w B) ->
  weak (arrow X A B).
 Proof.
  intros X A B H.
  elim (truth_lemma_X X B A).
  intros.
  apply H1.
  apply H.
  elim (truth_lemma_X X A A).
  auto with ctl.
 Qed.

 Lemma X_complete :
  forall (P : model_type) (X : arrow_extension), model_OK P X -> complete P X.
 Proof.
  unfold complete in |- *; intros P X H0 A B H.
  apply compl_X; auto.
 Qed.

 Lemma NL_OK : model_OK (fun _ _ => True) NL.
 Proof.
  unfold model_OK in |- *; auto.
 Qed.

 Lemma NL_complete : complete (fun _ _ => True) NL.
 Proof.
  apply X_complete; apply NL_OK; auto.
 Qed.

 Lemma LX_OK : forall X : arrow_extension, extends L X -> model_OK ASS X.
 Proof.
  intros X HX.
  unfold model_OK, ASS in |- *.
  unfold RK in |- *; split.
  intros x y z t u H0 H1.
  case H0; intro H2.
  case H1; intro H3.
  exists (Dot y z).
  split.
  split.
  apply one.
  apply weak_comp with (Dot (Dot x y) z).
  split.
  apply comp with (Dot t z).
  assumption.
  apply Dot_mono_left.
  assumption.
  split.
  apply alpha'.
  apply HX.
  intros x y z v u H0 H1.
  case H0; intro H2.
  case H1; intro H3.
  exists (Dot x y).
  split.
  split.
  apply one.
  apply weak_comp with (Dot x (Dot y z)).
  split.
  apply comp with (Dot x v).
  assumption.
  apply Dot_mono_right.
  assumption.
  split.
  apply alpha.
  apply HX.
 Qed.

 Lemma L_OK : model_OK ASS L.
 Proof.
  apply LX_OK.
  unfold extends in |- *; auto.
 Qed.

 Lemma L_complete : complete ASS L.
 Proof.
  apply X_complete; apply L_OK.
 Qed.

 Lemma NLP_X_OK : forall X : arrow_extension, extends NLP X -> model_OK COM X.
 Proof.
  intros X HX; unfold model_OK, COM, RK in |- *; intros x y z H.
  apply weak_comp with (Dot y z).
  assumption.
  case H.
  intro H1.
  split.
  apply pi.
  exact HX.
 Qed.

 Lemma NLP_OK : model_OK COM NLP.
 Proof.
  apply NLP_X_OK.
  unfold extends in |- *; auto.
 Qed.

 Lemma NLP_complete : complete COM NLP.
 Proof.
  apply X_complete.
  apply NLP_OK.
 Qed.

 Lemma LPX_OK :
  forall X : arrow_extension,
  extends LP X -> model_OK (model_inter ASS COM) X.
 Proof.
  intros X HX.
  unfold model_inter in |- *.
  unfold model_OK, RK in |- *; split.
  generalize LX_OK.
  unfold model_OK in |- *.
  intros H.
  unfold RK in H.
  apply H.
  apply extends_trans with LP.
  unfold LP, extends in |- *; right; auto.
  auto.
  generalize NLP_X_OK.
  unfold model_OK in |- *.
  intro H.
  unfold RK in H. apply H.
  apply extends_trans with LP.
  unfold LP, extends in |- *; left; auto.
  auto.
 Qed.

Lemma LP_OK : model_OK (model_inter ASS COM) LP.
 Proof.
  apply LPX_OK.
  unfold extends in |- *; auto.
 Qed.

 Lemma LP_complete : complete (model_inter ASS COM) LP.
 Proof.
  apply X_complete; apply LP_OK.
 Qed.

 End completeness.

End Atoms_fixed.