(* Librariile necesare pt a lucra cu stringuri*)
Require Import Strings.String.
Local Open Scope string_scope.
Local Open Scope list_scope.
Scheme Equality for string.

(* Acum voi inlocui tipul nat pe care l am mai folosit cu un nou tip: ErrorNar, care trateaza si cazurile mai speciale *)
Inductive ErrorNat :=
 | error_nat: ErrorNat
 | num : nat -> ErrorNat.
Check ErrorNat.
Check error_nat.
Check num.
Coercion num : nat >-> ErrorNat.

(* Same pentru bool *)

Inductive ErrorBool :=
 | error_bool : ErrorBool
 | bul : bool -> ErrorBool.
Check ErrorBool.
Check error_bool.
Check bul.
Coercion bul : bool >-> ErrorBool.

(* Fac un tip cu erori si pentru string, pentru moment*)

Inductive ErrorString :=
 | error_string : ErrorString
 | char : string -> ErrorString.
Check ErrorString.
Check error_string.
Check char.
Coercion char : string >-> ErrorString.

Inductive Tipuri :=
 | error_undecl : Tipuri (* Sa nu folosesc variabile nedeclarate *)
 | error_assign : Tipuri (* Sa nu atribui valori de alt tip decat tipul variabilei *)
 | default : Tipuri (* O valoare default care se pune in variabile la declarere *)
 | tip_nat : ErrorNat -> Tipuri
 | tip_bul : ErrorBool -> Tipuri
 | tip_string : ErrorString -> Tipuri.

Scheme Equality for Tipuri.

Check tip_nat.
Check tip_string.
Check tip_bul.
Check Tipuri.

(* Deoarece am construit tipul "Tipuri", nu mai trebuie sa fac cate un enviroment pentru toate tipurile, ci doar pentru el*)
Definition Env := string -> Tipuri.

Definition Egalitate_tipuri (t1 : Tipuri)(t2 : Tipuri) : bool :=
 match t1 with
 | error_assign => match t2 with
                   | error_assign => true
                   | _ => false
                   end
 | error_undecl => match t2 with
                   | error_undecl => true
                   | _ => false
                   end
 | default => match t2 with
                   | default => true
                   | _ => false
                   end
 | tip_nat _x => match t2 with
                   | tip_nat _y => true
                   | _ => false
                   end
 | tip_bul _x => match t2 with
                   | tip_bul _y => true
                   | _ => false
                   end
 | tip_string _x => match t2 with
                   | tip_string _y => true
                   | _ => false
                  end
end.

Check Egalitate_tipuri.
Check tip_nat.

(* Definesc un environment in care practic spun ca initial nici o variabila nu este declarata*)
Definition env : Env := fun x => error_undecl.
Check (env "x").
Compute (env "x").

(* Acum fac functia de atribuire a unei valori unei variabile*)

Definition update (env : Env) (x : string) (v : Tipuri ) : Env :=
  fun y =>
    if (eqb y x)
    then
      if(andb ( Egalitate_tipuri (error_undecl) (env y)) (negb (Egalitate_tipuri (default) (v))))
      then error_undecl
      else
        if(andb (Egalitate_tipuri (error_undecl) (env y))(Egalitate_tipuri (default) (v)))
        then default
        else
          if(orb (Egalitate_tipuri (default) (env y))(Egalitate_tipuri (v) (env y)))
          then v
          else error_assign
    else (env y).

Check (update env "y" default).
Compute (update (update env "y" (default)) "y" (tip_bul true) "y").

(* Pentru expr aritmetice *)
Inductive AExp :=
 | anum : ErrorNat -> AExp
 | avar : string -> AExp
 | aplus : AExp -> AExp -> AExp
 | aminus : AExp -> AExp -> AExp
 | amul : AExp -> AExp -> AExp
 | adiv : AExp -> AExp -> AExp
 | amod : AExp -> AExp -> AExp.

Coercion avar : string >-> AExp.
Coercion anum : ErrorNat >-> AExp.

Notation "A +' B" := (aplus A B)(at level 60, right associativity).
Notation "A -' B" := (aminus A B)(at level 60, right associativity).
Notation "A *' B" := (amul A B)(at level 59, right associativity).
Notation "A /' B" := (adiv A B)(at level 59, right associativity).
Notation "A %' B" := (amod A B)(at level 58, right associativity).
Check ("a" +' "b").
Check ("a" -' "b").
Check ("a" +' 3).
Check ("a" /' 0).
Check (7 %' 2).

(* Este nevoie de anumite functii pentru a trata si cazurile cu erori, cate o functie pentru fiecare operatie*)

Definition plus_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | num v1, num v2 => num (v1 + v2)
  end.
Compute plus_ErrorNat 1 2.

Definition minus_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | num v1, num v2 => if (Nat.leb v1 v2)
                        then error_nat
                        else num (v1 - v2)
  end.
Definition mul_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | num v1, num v2 => num (v1 * v2)
  end.

Definition div_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | _, 0 => error_nat
    | num v1, num v2 => (Nat.div v1 v2)
  end.
Definition mod_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | _, 0 => error_nat
    | num v1, num v2 => (Nat.modulo v1 v2)
  end.

Check mod_ErrorNat.

(* Functiile pentru castare *)

Definition bool_to_nat (b : bool) : ErrorNat :=
  match b with
  | false => 0
  | true => 1
  end.

Notation "'(b_nat)' { A }" := (bool_to_nat A)( at level 35).

Compute bool_to_nat true.
Compute bool_to_nat false.
Compute ((b_nat) { false }).

Definition str_to_nat (s : string) : ErrorNat :=
  match s with
  | unu => 1
  end.

Notation "'(s_nat)' { A }" := (str_to_nat A)( at level 35).

Compute str_to_nat "unu".
Compute ((s_nat) { "unu" }).
(* Aici am dat peste o problema de redundanta *)

(* Am pus si semantica Big Step pentru expresii aritmetice*)
Reserved Notation "A =[ S ]=> N" (at level 70).
Inductive aeval : AExp -> Env -> ErrorNat -> Prop :=
 | const : forall n sigma, anum n =[ sigma ]=> n
 | var : forall v sigma, avar v =[ sigma ]=> match (sigma v) with
                                               | tip_nat x => x
                                               | _ => error_nat
                                             end
 | add : forall a1 a2 i1 i2 sigma n,
  a1 =[ sigma ]=> i1 ->
  a2 =[ sigma ]=> i2 ->
  n = (plus_ErrorNat i1 i2) -> (a1 +' a2) =[ sigma ]=> n
 | dif : forall a1 a2 i1 i2 sigma n,
  a1 =[ sigma ]=> i1 ->
  a2 =[ sigma ]=> i2 ->
  n = (minus_ErrorNat i1 i2) -> a1 -' a2 =[ sigma ]=> n
 | times : forall a1 a2 i1 i2 sigma n,
  a1 =[ sigma ]=> i1 ->
  a2 =[ sigma ]=> i2 ->
  n = (mul_ErrorNat i1 i2) -> a1 *' a2 =[ sigma ]=> n
 | div : forall a1 a2 i1 i2 sigma n,
  a1 =[ sigma ]=> i1 ->
  a2 =[ sigma ]=> i2 ->
  n = (div_ErrorNat i1 i2) -> a1 /' a2 =[ sigma ]=> n
 | modd : forall a1 a2 i1 i2 sigma n,
  a1 =[ sigma ]=> i1 ->
  a2 =[ sigma ]=> i2 ->
  n = mod_ErrorNat i1 i2 -> a1 %' a2 =[ sigma ]=> n
where "a =[ sigma ]=> n" := ( aeval a sigma n).

Hint Constructors aeval.

Example eroare_la_dif : 2 -' 3 =[ env ]=> error_nat.
Proof.
  eapply dif.
    - apply const.
    - apply const.
    - simpl. reflexivity.
Qed.
Example eroare_la_div : 9 /' 0 =[ env ]=> error_nat.
Proof.
  eapply div.
    - apply const.
    - apply const.
    - simpl. reflexivity.
Qed.
Example eroare_la_mod : 5 %' 0 =[ env ]=> error_nat.
Proof.
  eapply modd.
    - apply const.
    - apply const.
    - simpl. reflexivity.
Qed.

(* Acum pentru expresii booleene *)
Inductive BExp :=
 | berror
 | btrue
 | bfalse
 | bvar : string -> BExp
 | blessthan : AExp -> AExp -> BExp
 | beqlessthan : AExp -> AExp -> BExp
 | bgreaterthan : AExp -> AExp -> BExp
 | beqgreaterthan : AExp -> AExp -> BExp
 | bnot : BExp -> BExp
 | band : BExp -> BExp -> BExp
 | bor : BExp -> BExp -> BExp
 | bequal : AExp -> AExp -> BExp.

Coercion bvar : string >-> BExp.

Notation "A <' B" := (blessthan A B) (at level 53).
Notation "A <=' B" := (beqlessthan A B) (at level 53).
Notation "A >' B" := (bgreaterthan A B) (at level 53).
Notation "A >=' B" := (beqgreaterthan A B) (at level 53).
Notation "!' A" := (bnot A) (at level 50, left associativity).
Notation "A &&' B" := (band A B) (at level 51, left associativity).
Notation "A ||' B" := (bor A B) (at level 52, left associativity).
Notation "A ==' B" := (bequal A B) (at level 54, left associativity).
Check berror.
Check btrue.
Check bfalse.
Check (!' "a").
Check (!' btrue).
Check ("a" <' "b").
Check ("a" <=' "b").
Check ("a" >' "b").
Check ("a" >=' "b").
Check ("a" &&' bfalse).
Check ("a" ||' "b").

(* Asemanator ca la numerele naturale, fac functii pentru fiecare operatie, deoarece au aparut cazurile in care pot avea erori*)

Definition lessthan_ErrorBool (n1 n2 : ErrorNat) : ErrorBool :=
  match n1, n2 with
    | error_nat, _ => error_bool
    | _, error_nat => error_bool
    | num v1, num v2 => bul (Nat.ltb v1 v2)
  end.
Definition greaterthan_ErrorBool (n1 n2 : ErrorNat) : ErrorBool :=
  match n1, n2 with
    | error_nat, _ => error_bool
    | _, error_nat => error_bool
    | num v1, num v2 => bul (negb (Nat.leb v1 v2))
  end.
Definition not_ErrorBool (n : ErrorBool) : ErrorBool :=
  match n with
    | error_bool => error_bool
    | bul v => bul (negb v)
  end.
Definition and_ErrorBool (n1 n2 : ErrorBool) : ErrorBool :=
  match n1, n2 with
    | error_bool, _ => error_bool
    | _, error_bool => error_bool
    | bul v1, bul v2 => bul (andb v1 v2)
  end.
Definition or_ErrorBool (n1 n2 : ErrorBool) : ErrorBool :=
  match n1, n2 with
    | error_bool, _ => error_bool
    | _, error_bool => error_bool
    | bul v1, bul v2 => bul (orb v1 v2)
  end.
Compute eqb "asd" "asd".
Compute length "asd".

Definition equal_ErrorBool (n1 n2 : ErrorNat) : ErrorBool :=
  match n1, n2 with
    | error_nat, _ => error_bool
    | _, error_nat => error_bool
    | num v1, num v2 => bul (Nat.eqb v1 v2)
  end.

(* Functia de castare *)

Definition nat_to_bool (n : nat) : ErrorBool :=
  match n with
  | 0 => false
  | _ => true
  end.

Notation "'(n_bool)' { A }" := (nat_to_bool A)( at level 35).

Compute nat_to_bool 12.
Compute nat_to_bool 0.
Compute ((n_bool) { 123 }).

(* Am pus si semantica Big Step pentru expresii booleene*)

Reserved Notation "B ={ S }=> B'" (at level 70).
Inductive beval : BExp -> Env -> ErrorBool -> Prop :=
 | e_error : forall sigma,
  berror ={ sigma }=> error_bool
 | e_true : forall sigma,
  btrue ={ sigma }=> true
 | e_false : forall sigma,
  bfalse ={ sigma }=> false
 | e_var : forall v sigma,
  bvar v ={ sigma }=> match (sigma v) with
                        | tip_bul x => x
                        | _ => error_bool
                      end
 | e_lessthan : forall a1 a2 i1 i2 sigma b,
  a1 =[ sigma ]=> i1 ->
  a2 =[ sigma ]=> i2 ->
  b = (lessthan_ErrorBool i1 i2) -> a1 <=' a2 ={ sigma }=> b
 | e_greaterthan : forall a1 a2 i1 i2 sigma b,
  a1 =[ sigma ]=> i1 ->
  a2 =[ sigma ]=> i2 ->
  b = (greaterthan_ErrorBool i1 i2) -> a1 >=' a2 ={ sigma }=> b
 | e_not : forall a1 i1 sigma b,
  a1 ={ sigma }=> i1 ->
  b = (not_ErrorBool i1) -> !' a1 ={ sigma }=> b
 | e_and : forall a1 a2 i1 i2 sigma b,
  a1 ={ sigma }=> i1 ->
  a2 ={ sigma }=> i2 ->
  b = (and_ErrorBool i1 i2) -> (a1 &&' a2) ={ sigma }=> b
 | e_or : forall a1 a2 i1 i2 sigma b,
  a1 ={ sigma }=> i1 ->
  a2 ={ sigma }=> i2 ->
  b = (or_ErrorBool i1 i2) -> (a1 ||' a2) ={ sigma }=> b
 | e_equal : forall a1 a2 i1 i2 sigma b,
  a1 =[ sigma ]=> i1 ->
  a2 =[ sigma ]=> i2 ->
  b = (equal_ErrorBool i1 i2) -> a1 ==' a2 ={ sigma }=> b
where "B ={ S }=> B'" := ( beval B S B').

Hint Constructors beval.

Example eroare_bool : band (10 <=' 5) (100 >=' "n") ={ env }=> error_bool.
Proof.
  eapply e_and.
    - eapply e_lessthan.
      + apply const.
      + apply const.
      + auto.
    - eapply e_greaterthan.
      + apply const.
      + apply var.
      + simpl. auto.
    - simpl. reflexivity.
Qed.

(* Pentru expresii cu siruri de caractere *)

Inductive CExp :=
 | cconst : ErrorString -> CExp
 | cvar : string -> CExp
 | cequal : ErrorString -> ErrorString -> CExp
 | cstrlen : ErrorString -> CExp
 | cappend : ErrorString -> ErrorString -> CExp.

Coercion cvar : string >-> CExp.

Notation " A =s= B " := (cequal A B) (at level 30).
Notation " 'strlen' ( A ) " := (cstrlen A) (at level 31).
Notation " A +s+ B " := (cappend A B) (at level 32).

Check ("asd" =s= "asd").
Check (strlen ( "asd" )).
Check ("asd" +s+ "fgh").

(* Functii stringuri *)

Definition append_s (c1 c2 : ErrorString) : ErrorString :=
  match c1, c2 with
    | error_string, _ => error_string
    | _, error_string => error_string
    | char c1, "" => error_string
    | "", char c2 => error_string
    | char c1, char c2 => char (append c1 c2)
  end.

Compute append "asd" "asd".
Compute append_s "asd" "asd".
Compute eqb "asd" "asd".

Definition equal_s (c1 c2 : ErrorString) : ErrorBool :=
  match c1, c2 with
    | error_string, _ => error_bool
    | _, error_string => error_bool
    | char c1, char c2 => bul (eqb c1 c2)
  end.

Compute length "asd".

Definition strlen_s (c1 : ErrorString) : ErrorNat :=
  match c1 with
    | error_string => error_nat
    | char c1 => num (length c1)
  end.

Compute strlen_s "asd".

(* Functii castare *)

Definition b_to_str (b : bool) : ErrorString :=
  match b with
  | true => "true"
  | false => "false"
  end.

Notation "'(b_char)' { A }" := (b_to_str A)( at level 35).

Compute ((b_char) { true }).
Compute ((b_char) { false }).

Definition n_to_str (n : nat) : ErrorString :=
  match n with
  | 0 => "zero"
  | 1 => "unu"
  | 2 => "doi"
  | 3 => "trei"
  | 4 => "patru"
  | 5 => "cinci"
  | 6 => "sase"
  | 7 => "sapte"
  | 8 => "opt"
  | 9 => "noua"
  | _ => "numar din doua cifre"
  end.

Notation "'(n_char)' { A }" := (n_to_str A)( at level 35).

Compute ((n_char) { 5 }).
Compute ((n_char) { 11 }).

(* Am pus si semantica Big Step pentru operatii pe stringuri*)

Reserved Notation "C -[ S ]-> C'" (at level 70).
Inductive ceval : CExp -> Env -> ErrorString -> Prop :=
 | c_const : forall c sigma, cconst c -[ sigma ]-> c
 | c_var : forall c sigma, cvar c -[ sigma ]-> match (sigma c) with
                                               | tip_string x => x
                                               | _ => error_string
                                             end
 (*| append : forall c1 c2 i1 i2 sigma s,
  c1 -[ sigma ]-> i1 ->
  c2 -[ sigma ]-> i2 ->
  s = (append_ErrorString i1 i2) -> (c1 +s+ c2) -[ sigma ]-> s
 | length : forall c1 i1 sigma s,
  c1 -[ sigma ]-> i1 -> s = (length_ErrorString i1) -> ( strlen ( c1 )) -[ sigma ]-> s
 | equal : forall c1 c2 i1 i2 sigma s,
  c1 -[ sigma ]-> i1 ->
  c2 -[ sigma ]-> i2 ->
  s = (equal_ErrorString i1 i2) -> (c1 =s= c2) -[ sigma ]-> s *)
where "c -[ sigma ]-> c'" := ( ceval c sigma c').

(* Definirea tipului pentru vectori cu ajutorul listelor*)

Inductive Vector :=
 | Error_vector : Vector
 | Nat_vector : nat -> list ErrorNat -> Vector
 | Bool_vector : nat -> list ErrorBool -> Vector
 | String_vector : nat -> list ErrorString -> Vector.

Check Nat_vector.

(* Statementuri *)

Inductive Stmt :=
 | nat_decl : string -> Stmt
 | nat_assign : string -> AExp -> Stmt
 | bool_decl : string -> Stmt
 | bool_assign : string -> BExp -> Stmt
 | string_decl : string -> Stmt
 | string_assign : string -> CExp -> Stmt
 | sequence : Stmt -> Stmt -> Stmt
 | nat_decl_vector : string -> Vector -> Stmt
 | nat_assign_vector : string -> Vector -> Stmt
 | bool_decl_vector : string -> Vector -> Stmt
 | bool_assign_vector : string -> Vector -> Stmt
 | string_decl_vector : string -> Vector -> Stmt
 | string_assign_vector : string -> Vector -> Stmt
 | while : BExp -> Stmt -> Stmt
 | ifthenelse : BExp -> Stmt -> Stmt -> Stmt
 | ifthen : BExp -> Stmt -> Stmt
 | break : Stmt
 | continue : Stmt
 | fct_declare : string -> Stmt -> Stmt -> Stmt
 | fct_call_n : string -> list nat -> Stmt
 | fct_call_s : string -> list string -> Stmt
 | switch : AExp -> list Case -> Stmt
 with Case :=
 | case : AExp -> Stmt -> Case
 | default' : Stmt -> Case.

Notation "'unsigned' X" := (nat_decl X)(at level 80).
Notation "'bool' X" := (bool_decl X)(at level 80).
Notation "'char' X" := (string_decl X)(at level 80).

Notation "V [ N ]n" := ( nat_decl_vector V num N)(at level 40).
Notation "V [ N ]b" := ( bool_decl_vector V num N)(at level 40).
Notation "V [ N ]s" := ( string_decl_vector V num N)(at level 40).

Notation "V [ N ]n={ E1 ; E2 ; .. ; En }" := ( nat_assign_vector V ( Nat_vector N (cons num(E1) (cons num(E2) .. (cons num(En) nil) ..) ) ) )(at level 40).
Notation "V [ N ]b={ E1 ; E2 ; .. ; En }" := ( bool_assign_vector V ( Bool_vector N (cons bul(E1) (cons bul(E2) .. (cons bul(En) nil) ..) ) ) )(at level 40).
Notation "V [ N ]s={ E1 ; E2 ; .. ; En }" := ( string_assign_vector V ( String_vector N (cons string(E1) (cons string(E2) .. (cons string(En) nil) ..) ) ) )(at level 40).

Notation "X :n= A" := (nat_assign X A)(at level 80).
Notation "X :b= A" := (bool_assign X A)(at level 80).
Notation "X :s= A" := (string_assign X A)(at level 80).

Notation "S1 ;; S2" := (sequence S1 S2)(at level 93).

Notation "'if'' B 'then'' S1 'end''" := (ifthen B S1)(at level 83).
Notation "'if'' B 'then'' S1 'else'' S2 'end''" := (ifthenelse B S1 S2)(at level 83).
Notation "'for' ( A ~ B ~ C ) { S }" := (A ;; while B  (S ;; C )) (at level 97).
Notation "'while'' ( B ) { S }" := (while B S) (at level 83).

Notation " 'switch' A 'en' L 'ends' " := (switch A L)(at level 83).
Notation " 'case' A 'en' S 'en' " := (case A S)(at level 84).
Notation " 'default'' S 'en'" := (default' S)(at level 84).

Notation " 'declare' X S1 'begin' { S2 } 'endf' " := (fct_declare X S1 S2)(at level 78).
Notation " 'call_n' X 'begin' L 'endf'" := (fct_call_n X L)(at level 68).
Notation " 'call_s' X 'begin' L 'endf'" := (fct_call_s X L)(at level 68).

(* Librariile necesare pentru a lucra cu liste *)
Require Import Coq.Lists.List.
Import ListNotations.
Scheme Equality for list.

Check (unsigned "a").
Check ("a" :n= 3).

Check (bool "a").
Check ("a" :b= bfalse).

Check (char "c").
Check ("c" :s= "abc").

Check (

unsigned "a";;
unsigned "b";;
unsigned "sum";;
"sum" :n= 0;;
"a" :n= 1;;
"b" :n= 5;;
char "rasp";;

if' ("a" <=' "b") then'
  "rasp" :s= "a este mai mic sau egal cu b"
else'
  "rasp" :s= "a este mai mare decat b"
end'
).

Check (

switch 6 en [
  case 6 en "c" :n= 6 en ;
  case 9 en "c" :n= 9 en ;
  default' "c" :n= 0 en
]
ends
).

Check (call_n "fun" begin [10;20] endf).

Check (call_s "fun" begin ["a";"b"] endf).

Check (

unsigned "x";;
unsigned "y";;
"x" :n= 1;;
"y" :n= 4;;
while' ( "x" <' "y" ) {
  "x" :n= "x" +' 1;;
  if' ("x" ==' 2 ) then'
      break
  end'
}
).

Check (
declare "fun" unsigned "a"
  begin
    {
      unsigned "b" ;;
      "b" :n= ("a" *' 10)
}endf
).

(* Semantica pentru statementuri *)


Welcome to Coq 8.4pl4 (August 2014)

Coq < Section Math020.

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

Coq < Load CpdtTactics.

Coq < Goal forall x, (4 * x) = x + x + x + x + 0.
1 subgoal

  ============================
   forall x : nat, 4 * x = x + x + x + x + 0

Unnamed_thm < crush.
No more subgoals.

Unnamed_thm < Qed.
crush.

Unnamed_thm is defined

Coq <


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrbool ssrfun eqtype ssrnat.
From mathcomp
Require Import div seq fintype tuple finset.
From mathcomp
Require Import fingroup action gseries.

(******************************************************************************)
(* n-transitive and primitive actions:                                        *)
(*  [primitive A, on S | to] <=>                                              *)
(*       A acts on S in a primitive manner, i.e., A is transitive on S and    *)
(*       A does not act on any nontrivial partition of S.                     *)
(*  imprimitivity_system A to S Q <=>                                         *)
(*       Q is a non-trivial primitivity system for the action of A on S via   *)
(*       to, i.e., Q is a non-trivial partiiton of S on which A acts.         *)
(*       to * n == in the %act scope, the total action induced by the total   *)
(*                 action to on n.-tuples. via n_act to n.                    *)
(*  n.-dtuple S == the set of n-tuples with distinct values in S.             *)
(*  [transitive^n A, on S | to] <=>                                           *)
(*       A is n-transitive on S, i.e., A is transitive on n.-dtuple S         *)
(*              == the set of n-tuples with distinct values in S.             *)
(******************************************************************************)

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

Import GroupScope.

Section PrimitiveDef.

Variables (aT : finGroupType) (sT : finType).
Variables (A : {set aT}) (S : {set sT}) (to : {action aT &-> sT}).

Definition imprimitivity_system Q :=
  [&& partition Q S, [acts A, on Q | to^*] & 1 < #|Q| < #|S|].

Definition primitive :=
  [transitive A, on S | to] && ~~ [exists Q, imprimitivity_system Q].

End PrimitiveDef.

Arguments imprimitivity_system {aT sT} A%g S%g to%act Q%g.
Arguments primitive {aT sT} A%g S%g to%act.

Notation "[ 'primitive' A , 'on' S | to ]" := (primitive A S to)
  (at level 0, format "[ 'primitive'  A ,  'on'  S  |  to ]") : form_scope.

Section Primitive.

Variables (aT : finGroupType) (sT : finType).
Variables (G : {group aT}) (to : {action aT &-> sT}) (S : {set sT}).

Lemma trans_prim_astab x :
    x \in S -> [transitive G, on S | to] ->
  [primitive G, on S | to] = maximal_eq 'C_G[x | to] G.
Proof.
move=> Sx trG; rewrite /primitive trG negb_exists.
apply/forallP/maximal_eqP=> /= [primG | [_ maxCx] Q].
  split=> [|H sCH sHG]; first exact: subsetIl.
  pose X := orbit to H x; pose Q := orbit (to^*)%act G X.
  have Xx: x \in X by apply: orbit_refl.
  have defH: 'N_(G)(X | to) = H.
    have trH: [transitive H, on X | to] by apply/imsetP; exists x.
    have sHN: H \subset 'N_G(X | to) by rewrite subsetI sHG atrans_acts.
    move/(subgroup_transitiveP Xx sHN): (trH) => /= <-.
      by rewrite mulSGid //= setIAC subIset ?sCH.
    apply/imsetP; exists x => //; apply/eqP.
    by rewrite eqEsubset imsetS // acts_sub_orbit ?subsetIr.
  have [|/proper_card oCH] := eqVproper sCH; [by left | right].
  apply/eqP; rewrite eqEcard sHG leqNgt.
  apply: contra {primG}(primG Q) => oHG; apply/and3P; split; last first.
  - rewrite card_orbit astab1_set defH -(@ltn_pmul2l #|H|) ?Lagrange // muln1.
    rewrite oHG -(@ltn_pmul2l #|H|) ?Lagrange // -(card_orbit_stab to G x).
    by rewrite -(atransP trG x Sx) mulnC card_orbit ltn_pmul2r.
  - by apply/actsP=> a Ga Y; apply/orbit_transl/mem_orbit.
  apply/and3P; split; last 1 first.
  - rewrite orbit_sym; apply/imsetP=> [[a _]] /= defX.
    by rewrite defX /setact imset0 inE in Xx.
  - apply/eqP/setP=> y; apply/bigcupP/idP=> [[_ /imsetP[a Ga ->]] | Sy].
      case/imsetP=> _ /imsetP[b Hb ->] ->.
      by rewrite !(actsP (atrans_acts trG)) //; apply: subsetP Hb.
    case: (atransP2 trG Sx Sy) => a Ga ->.
    by exists ((to^*)%act X a); apply: mem_imset; rewrite // orbit_refl.
  apply/trivIsetP=> _ _ /imsetP[a Ga ->] /imsetP[b Gb ->].
  apply: contraR => /exists_inP[_ /imsetP[_ /imsetP[a1 Ha1 ->] ->]].
  case/imsetP=> _ /imsetP[b1 Hb1 ->] /(canLR (actK _ _)) /(canLR (actK _ _)).
  rewrite -(canF_eq (actKV _ _)) -!actM (sameP eqP astab1P) => /astab1P Cab.
  rewrite astab1_set (subsetP (subsetIr G _)) //= defH.
  rewrite -(groupMr _ (groupVr Hb1)) -mulgA -(groupMl _ Ha1).
  by rewrite (subsetP sCH) // inE Cab !groupM ?groupV // (subsetP sHG).
apply/and3P=> [[/and3P[/eqP defS tIQ ntQ]]]; set sto := (to^*)%act => actQ.
rewrite !ltnNge -negb_or => /orP[].
pose X := pblock Q x; have Xx: x \in X by rewrite mem_pblock defS.
have QX: X \in Q by rewrite pblock_mem ?defS.
have toX Y a: Y \in Q -> a \in G -> to x a \in Y -> sto X a = Y.
  move=> QY Ga Yxa; rewrite -(contraNeq (trivIsetP tIQ Y (sto X a) _ _)) //.
    by rewrite (actsP actQ).
  by apply/existsP; exists (to x a); rewrite /= Yxa; apply: mem_imset.
have defQ: Q = orbit (to^*)%act G X.
  apply/eqP; rewrite eqEsubset andbC acts_sub_orbit // QX.
  apply/subsetP=> Y QY.
  have /set0Pn[y Yy]: Y != set0 by apply: contraNneq ntQ => <-.
  have Sy: y \in S by rewrite -defS; apply/bigcupP; exists Y.
  have [a Ga def_y] := atransP2 trG Sx Sy.
  by apply/imsetP; exists a; rewrite // (toX Y) // -def_y.
rewrite defQ card_orbit; case: (maxCx 'C_G[X | sto]%G) => /= [||->|->].
- apply/subsetP=> a /setIP[Ga cxa]; rewrite inE Ga /=.
  by apply/astab1P; rewrite (toX X) // (astab1P cxa).
- exact: subsetIl.
- by right; rewrite -card_orbit (atransP trG).
by left; rewrite indexgg.
Qed.

Lemma prim_trans_norm (H : {group aT}) :
    [primitive G, on S | to] -> H <| G ->
  H \subset 'C_G(S | to) \/ [transitive H, on S | to].
Proof.
move=> primG /andP[sHG nHG]; rewrite subsetI sHG.
have [trG _] := andP primG; have [x Sx defS] := imsetP trG.
move: primG; rewrite (trans_prim_astab Sx) // => /maximal_eqP[_].
case/(_ ('C_G[x | to] <*> H)%G) => /= [||cxH|]; first exact: joing_subl.
- by rewrite join_subG subsetIl.
- have{cxH} cxH: H \subset 'C_G[x | to] by rewrite -cxH joing_subr.
  rewrite subsetI sHG /= in cxH; left; apply/subsetP=> a Ha.
  apply/astabP=> y Sy; have [b Gb ->] := atransP2 trG Sx Sy.
  rewrite actCJV [to x (a ^ _)](astab1P _) ?(subsetP cxH) //.
  by rewrite -mem_conjg (normsP nHG).
rewrite norm_joinEl 1?subIset ?nHG //.
by move/(subgroup_transitiveP Sx sHG trG); right.
Qed.

End Primitive.

Section NactionDef.

Variables (gT : finGroupType) (sT : finType).
Variables (to : {action gT &-> sT}) (n :  nat).

Definition n_act (t : n.-tuple sT) a := [tuple of map (to^~ a) t].

Fact n_act_is_action : is_action setT n_act.
Proof.
by apply: is_total_action => [t|t a b]; apply: eq_from_tnth => i;
    rewrite !tnth_map ?act1 ?actM.
Qed.

Canonical n_act_action := Action n_act_is_action.

End NactionDef.

Notation "to * n" := (n_act_action to n) : action_scope.

Section NTransitive.

Variables (gT : finGroupType) (sT : finType).
Variables (n :  nat) (A : {set gT}) (S : {set sT}) (to : {action gT &-> sT}).

Definition dtuple_on := [set t : n.-tuple sT | uniq t & t \subset S].
Definition ntransitive := [transitive A, on dtuple_on | to * n].

Lemma dtuple_onP t :
  reflect (injective (tnth t) /\ forall i, tnth t i \in S) (t \in dtuple_on).
Proof.
rewrite inE subset_all -map_tnth_enum.
case: (uniq _) / (injectiveP (tnth t)) => f_inj; last by right; case.
rewrite -[all _ _]negbK -has_predC has_map has_predC negbK /=.
by apply: (iffP allP) => [Sf|[]//]; split=> // i; rewrite Sf ?mem_enum.
Qed.

Lemma n_act_dtuple t a :
  a \in 'N(S | to) -> t \in dtuple_on -> n_act to t a \in dtuple_on.
Proof.
move/astabsP=> toSa /dtuple_onP[t_inj St]; apply/dtuple_onP.
split=> [i j | i]; rewrite !tnth_map ?[_ \in S]toSa //.
by move/act_inj; apply: t_inj.
Qed.

End NTransitive.

Arguments dtuple_on {sT} n%N S%g.
Arguments ntransitive {gT sT} n%N A%g S%g to%act.
Arguments n_act {gT sT} to {n} t a.

Notation "n .-dtuple ( S )" := (dtuple_on n S)
  (at level 8, format "n .-dtuple ( S )") : set_scope.

Notation "[ 'transitive' ^ n A , 'on' S | to ]" := (ntransitive n A S to)
  (at level 0, n at level 8,
   format "[ 'transitive' ^ n  A ,  'on'  S  |  to ]") : form_scope.

Section NTransitveProp.

Variables (gT : finGroupType) (sT : finType).
Variables (to : {action gT &-> sT}) (G : {group gT}) (S : {set sT}).

Lemma card_uniq_tuple n (t : n.-tuple sT) : uniq t -> #|t| = n.
Proof. by move/card_uniqP->; apply: size_tuple. Qed.

Lemma n_act0 (t : 0.-tuple sT) a : n_act to t a = [tuple].
Proof. exact: tuple0. Qed.

Lemma dtuple_on_add n x (t : n.-tuple sT) :
  ([tuple of x :: t] \in n.+1.-dtuple(S)) =
     [&& x \in S, x \notin t & t \in n.-dtuple(S)].
Proof. by rewrite !inE memtE !subset_all -!andbA; do !bool_congr. Qed.

Lemma dtuple_on_add_D1 n x (t : n.-tuple sT) :
  ([tuple of x :: t] \in n.+1.-dtuple(S))
     = (x \in S) && (t \in n.-dtuple(S :\ x)).
Proof.
rewrite dtuple_on_add !inE (andbCA (~~ _)); do 2!congr (_ && _).
rewrite -!(eq_subset (in_set (mem t))) setDE setIC subsetI; congr (_ && _).
by rewrite -setCS setCK sub1set !inE.
Qed.

Lemma dtuple_on_subset n (S1 S2 : {set sT}) t :
  S1 \subset S2 -> t \in n.-dtuple(S1) -> t \in n.-dtuple(S2).
Proof. by move=> sS12; rewrite !inE => /andP[-> /subset_trans]; apply. Qed.

Lemma n_act_add n x (t : n.-tuple sT) a :
  n_act to [tuple of x :: t] a = [tuple of to x a :: n_act to t a].
Proof. exact: val_inj. Qed.

Lemma ntransitive0 : [transitive^0 G, on S | to].
Proof.
have dt0: [tuple] \in 0.-dtuple(S) by rewrite inE memtE subset_all.
apply/imsetP; exists [tuple of Nil sT] => //.
by apply/setP=> x; rewrite [x]tuple0 orbit_refl.
Qed.

Lemma ntransitive_weak k m :
  k <= m -> [transitive^m G, on S | to] -> [transitive^k G, on S | to].
Proof.
move/subnKC <-; rewrite addnC; elim: {m}(m - k) => // m IHm.
rewrite addSn => tr_m1; apply: IHm; move: {m k}(m + k) tr_m1 => m tr_m1.
have ext_t t: t \in dtuple_on m S ->
  exists x, [tuple of x :: t] \in m.+1.-dtuple(S).
- move=> dt.
  have [sSt | /subsetPn[x Sx ntx]] := boolP (S \subset t); last first.
    by exists x; rewrite dtuple_on_add andbA /= Sx ntx.
  case/imsetP: tr_m1 dt => t1; rewrite !inE => /andP[Ut1 St1] _ /andP[Ut _].
  have /subset_leq_card := subset_trans St1 sSt.
  by rewrite !card_uniq_tuple // ltnn.
case/imsetP: (tr_m1); case/tupleP=> [x t]; rewrite dtuple_on_add.
case/and3P=> Sx ntx dt; set xt := [tuple of _] => tr_xt.
apply/imsetP; exists t => //.
apply/setP=> u; apply/idP/imsetP=> [du | [a Ga ->{u}]].
  case: (ext_t u du) => y; rewrite tr_xt.
  by case/imsetP=> a Ga [_ def_u]; exists a => //; apply: val_inj.
have: n_act to xt a \in dtuple_on _ S by rewrite tr_xt mem_imset.
by rewrite n_act_add dtuple_on_add; case/and3P.
Qed.

Lemma ntransitive1 m :
  0 < m -> [transitive^m G, on S | to] -> [transitive G, on S | to].
Proof.
have trdom1 x: ([tuple x] \in 1.-dtuple(S)) = (x \in S).
  by rewrite dtuple_on_add !inE memtE subset_all andbT.
move=> m_gt0 /(ntransitive_weak m_gt0) {m m_gt0}.
case/imsetP; case/tupleP=> x t0; rewrite {t0}(tuple0 t0) trdom1 => Sx trx.
apply/imsetP; exists x => //; apply/setP=> y; rewrite -trdom1 trx.
by apply/imsetP/imsetP=> [[a ? [->]]|[a ? ->]]; exists a => //; apply: val_inj.
Qed.

Lemma ntransitive_primitive m :
  1 < m -> [transitive^m G, on S | to] -> [primitive G, on S | to].
Proof.
move=> lt1m /(ntransitive_weak lt1m) {m lt1m}tr2G.
have trG: [transitive G, on S | to] by apply: ntransitive1 tr2G.
have [x Sx _]:= imsetP trG; rewrite (trans_prim_astab Sx trG).
apply/maximal_eqP; split=> [|H]; first exact: subsetIl; rewrite subEproper.
case/predU1P; first by [left]; case/andP=> sCH /subsetPn[a Ha nCa] sHG.
right; rewrite -(subgroup_transitiveP Sx sHG trG _) ?mulSGid //.
have actH := subset_trans sHG (atrans_acts trG).
pose y := to x a; have Sy: y \in S by rewrite (actsP actH).
have{nCa} yx: y != x by rewrite inE (sameP astab1P eqP) (subsetP sHG) in nCa.
apply/imsetP; exists y => //; apply/eqP.
rewrite eqEsubset acts_sub_orbit // Sy andbT; apply/subsetP=> z Sz.
have [-> | zx] := eqVneq z x; first by rewrite orbit_sym mem_orbit.
pose ty := [tuple y; x]; pose tz := [tuple z; x].
have [Sty Stz]: ty \in 2.-dtuple(S) /\ tz \in 2.-dtuple(S).
  by rewrite !inE !memtE !subset_all /= !mem_seq1 !andbT; split; apply/and3P.
case: (atransP2 tr2G Sty Stz) => b Gb [->] /esym/astab1P cxb.
by rewrite mem_orbit // (subsetP sCH) // inE Gb.
Qed.

End NTransitveProp.

Section NTransitveProp1.

Variables (gT : finGroupType) (sT : finType).
Variables (to : {action gT &-> sT}) (G : {group gT}) (S : {set sT}).

(* This is the forward implication of Aschbacher (15.12).1  *)
Theorem stab_ntransitive m x :
    0 < m -> x \in S -> [transitive^m.+1 G, on S | to] ->
  [transitive^m 'C_G[x | to], on S :\ x | to].
Proof.
move=> m_gt0 Sx Gtr; have sSxS: S :\ x \subset S by rewrite subsetDl.
case: (imsetP Gtr); case/tupleP=> x1 t1; rewrite dtuple_on_add.
case/and3P=> Sx1 nt1x1 dt1 trt1; have Gtr1 := ntransitive1 (ltn0Sn _) Gtr.
case: (atransP2 Gtr1 Sx1 Sx) => // a Ga x1ax.
pose t := n_act to t1 a.
have dxt: [tuple of x :: t] \in m.+1.-dtuple(S).
  by rewrite trt1 x1ax; apply/imsetP; exists a => //; apply: val_inj.
apply/imsetP; exists t; first by rewrite dtuple_on_add_D1 Sx in dxt.
apply/setP=> t2; apply/idP/imsetP => [dt2|[b]].
  have: [tuple of x :: t2] \in dtuple_on _ S by rewrite dtuple_on_add_D1 Sx.
  case/(atransP2 Gtr dxt)=> b Gb [xbx tbt2].
  by exists b; [rewrite inE Gb; apply/astab1P | apply: val_inj].
case/setIP=> Gb /astab1P xbx ->{t2}.
rewrite n_act_dtuple //; last by rewrite dtuple_on_add_D1 Sx in dxt.
apply/astabsP=> y; rewrite !inE -{1}xbx (inj_eq (act_inj _ _)).
by rewrite (actsP (atrans_acts Gtr1)).
Qed.

(* This is the converse implication of Aschbacher (15.12).1  *)
Theorem stab_ntransitiveI m x :
     x \in S -> [transitive G, on S | to] ->
     [transitive^m 'C_G[x | to], on S :\ x | to] ->
  [transitive^m.+1 G, on S | to].
Proof.
move=> Sx Gtr Gntr.
have t_to_x t: t \in m.+1.-dtuple(S) ->
  exists2 a, a \in G & exists2 t', t' \in m.-dtuple(S :\ x)
                                 & t = n_act to [tuple of x :: t'] a.
- case/tupleP: t => y t St.
  have Sy: y \in S by rewrite dtuple_on_add_D1 in St; case/andP: St.
  rewrite -(atransP Gtr _ Sy) in Sx; case/imsetP: Sx => a Ga toya.
  exists a^-1; first exact: groupVr.
  exists (n_act to t a); last by rewrite n_act_add toya !actK.
  move/(n_act_dtuple (subsetP (atrans_acts Gtr) a Ga)): St.
  by rewrite n_act_add -toya dtuple_on_add_D1 => /andP[].
case: (imsetP Gntr) => t dt S_tG; pose xt := [tuple of x :: t].
have dxt: xt \in m.+1.-dtuple(S) by rewrite dtuple_on_add_D1 Sx.
apply/imsetP; exists xt => //; apply/setP=> t2.
apply/esym; apply/imsetP/idP=> [[a Ga ->] | ].
  by apply: n_act_dtuple; rewrite // (subsetP (atrans_acts Gtr)).
case/t_to_x=> a2 Ga2 [t2']; rewrite S_tG.
case/imsetP=> a /setIP[Ga /astab1P toxa] -> -> {t2 t2'}.
by exists (a * a2); rewrite (groupM, actM) //= !n_act_add toxa.
Qed.

End NTransitveProp1.


Require Import SetoidClass Morphisms.

Module Type ShallowPermissionTheory.
  (* Type of a model of a permission theory *)

  Parameter perm : Type.
  Declare Instance perm_Setoid : Setoid perm.

  (* composition of permissions *)
  Parameter C : perm -> perm -> perm -> Prop.
  Declare Instance C_morphism : Proper (equiv ==> equiv ==> equiv ==> iff) C.

  Parameter full : perm.
  Parameter empty : perm.

  Axiom C_commutative : forall p p' p'', C p p' p'' -> C p' p p''.

  Axiom C_full_empty : forall p p', C full p p' -> p == empty.
  Axiom C_full_full : forall p p', C full p p' -> p' == full.

  Axiom C_non_idempotent : forall p p', C p p p' -> p == empty.

  Axiom C_identity : forall p, C empty p p.

  Axiom C_functional : forall p p' p'' p''', C p p' p'' -> C p p' p'' -> p'' == p'''.

  Axiom C_inverse : forall p, exists p', C p p' full.

  Axiom C_associative : forall p1 p2 p3 p,
     (exists p12, C p1 p2 p12 /\ C p12 p3 p) <->
     (exists p23, C p2 p3 p23 /\ C p1 p23 p).

  Axiom C_divisibility : forall p, p == empty \/
    exists p1, exists p2, ~(p1 == empty) /\ ~(p2 == empty) /\ C p1 p2 p.

  Axiom non_trivial : ~ (full == empty).
  Axiom equiv_dec : forall p p' : perm, p == p' \/ ~ p == p'.
  Axiom C_dec : forall p p' p'' : perm, C p p' p'' \/ ~ C p p' p''.

End ShallowPermissionTheory.

Module ShallowPermissionProperties (Import SPT : ShallowPermissionTheory).
  Definition O : perm -> perm -> Prop := fun p1 p2 => forall p, ~ C p1 p2 p.

  Hint Unfold O.

  Lemma overlap_or_empty : forall p, O p p \/ p == empty.
   unfold O; intro.
   destruct (equiv_dec p empty); firstorder.
   left.
   intro; contradict H.
   eapply C_non_idempotent; eauto.
  Qed.

End ShallowPermissionProperties.

Set Implicit Arguments.

Section DeepPermissions.

  Inductive dpf : nat -> Set :=
    | dpf_false : forall n, dpf n
    | dpf_and : forall n, dpf n -> dpf n -> dpf n
    | dpf_or : forall n, dpf n -> dpf n -> dpf n
    | dpf_not : forall n, dpf n -> dpf n
    | dpf_eq : forall n, forall n0, n > n0 -> forall n1, n > n1 -> dpf n
    | dpf_C : forall n, forall n0, n > n0 -> forall n1, n > n1 -> forall n2, n > n2 -> dpf n
    | dpf_all : forall n, dpf (S n) -> dpf n
    | dpf_ex : forall n, dpf (S n) -> dpf n.

End DeepPermissions.

Require Import LList.
Require Import List.

Module InhabitationFunctionDefs.
  Open Scope bool.
  Definition inhf n := llist bool n -> bool.
  Definition restrict n (f : inhf (S n)) : inhf n :=
    fun v => f (llcons true v) || f (llcons false v).
  Program Instance inhf_setoid n : Setoid (inhf n) :=
    {| equiv := fun f g => forall v, f v = g v |}.
  Obligation 1.
   split; try firstorder.
   repeat intro.
   rewrite H; firstorder.
  Qed.

  Definition is_extension_of n (f : inhf (S n)) (g : inhf n) := restrict f == g.

  Definition empty_inhf : inhf 0 := fun _ => true.

End InhabitationFunctionDefs.

Section DeepPermissionsSatisfaction.
  Import InhabitationFunctionDefs.
(*
  Program Fixpoint dpf_empty_inter2 n (v1 : nat) (c1 : bool)
          (v2 : nat) (c2 : bool) (i : inhf n) : bool :=
   |
*)
  Inductive dpf_empty_inter2 : forall n, (nat * bool) -> (nat * bool) -> inhf n -> Prop :=
   | .

  Inductive dpf_sat : forall n, dpf n -> inhf n -> Prop :=
  | dpfs_and : forall n (l : dpf n)  r i, dpf_sat l i -> dpf_sat r i -> dpf_sat (dpf_and l r) i
  | dpfs_orl : forall n (l : dpf n) r i, dpf_sat l i -> dpf_sat (dpf_or l r) i
  | dpfs_orr : forall n (l : dpf n) r i, dpf_sat r i -> dpf_sat (dpf_or l r) i
  | dpfs_not : forall n (f : dpf n) i, dpf_unsat f i -> dpf_sat (dpf_not f) i
  with dpf_unsat : forall n, dpf n -> inhf n -> Prop :=
  | dpfu_false : forall n i, dpf_unsat (dpf_false n) i
  | dpfu_andl : forall n (l : dpf n) r i, dpf_unsat l i -> dpf_unsat (dpf_and l r) i
  | dpfu_andr : forall n (l : dpf n) r i, dpf_unsat l i -> dpf_unsat (dpf_and l r) i
  | dpfu_or : forall n (l : dpf n) r i, dpf_unsat l i -> dpf_unsat r i -> dpf_unsat (dpf_or l r) i
  | dpfu_not : forall n (f : dpf n) i, dpf_sat f i -> dpf_unsat (dpf_not f) i
  .

(*
  Variable dpf_prop : dpf 0 -> Prop.
  Variable dpf_prov : forall (f : dpf 0), dpf_sat f (fun _ => true) -> dpf_prop f.
  Variable dpf_nprov : forall (f : dpf 0), dpf_unsat f (fun _ => true) -> ~dpf_prop f.
  Variable dpf_dec : forall (f : dpf 0), dpf_sat f (fun _ => true) \/ dpf_unsat f (fun _ => true).
  Lemma dpf_prop_prov : forall f, dpf_prop f -> dpf_sat f (fun _ => true).
  firstorder.
  Qed.
*)

Module Type InhabitationGrid.
  Import InhabitationFunctionDefs.
  Parameter grid : nat -> Type.
  Parameter eval : forall n, grid n -> llist bool n -> bool.
  Parameter empty_grid : grid 0.
  Parameter extensions : forall n, grid n -> list (grid (S n)).
  Axiom empty_grid_is_empty : forall v, eval empty_grid v = true.
  Axiom extensions_are_extensions : forall n (f : grid (S n)) (g : grid n),
    In f (extensions g) -> is_extension_of (eval f) (eval g).
  Axiom all_extensions : forall n (g : grid n) (f' : inhf (S n)),
    is_extension_of f' (eval g) -> exists f,
      In f (extensions g) /\ f' == eval f.
End InhabitationGrid.

Fixpoint mix_with {A B C} (f : A -> B -> C) (la : list A) (lb : list B) : list C :=
  match la with
  | nil => nil
  | cons x xs => (map (f x) lb) ++ mix_with f xs lb
  end.

Lemma In_mix_with {A B C} (f : A -> B -> C) la lb :
  forall z, In z (mix_with f la lb) <-> exists x, exists y, In x la /\ In y lb /\ z = f x y.
 induction la.
  simpl; firstorder.
  simpl; intuition.
   apply in_app_or in H; destruct H.
    clear IHla.
    induction lb.
     contradiction H.
     destruct H.
      subst; exists a; exists a0; intuition.
      apply IHlb in H; destruct H; destruct H.
      intuition; subst.
       exists x; exists x0; intuition.
       exists x; exists x0; intuition.
   firstorder.

   firstorder; subst.
   remember lb as lb'.
   rewrite Heqlb' at 2; clear Heqlb'.
   clear IHla; induction lb'.
    contradiction H0.
    firstorder; subst.
     left; reflexivity.
Qed.

Module TreeInhabitationGrid.
  Import InhabitationFunctionDefs.
  Inductive et : nat -> Type :=
    | et_some : et 0
    | et_none : forall n, et n
    | et_branch : forall n, et n -> et n -> et (S n).
(*
  Inductive inhabited : forall n, et n -> Prop :=
    | eti_some : inhabited et_some
    | eti_branch_l : forall n (x x': et n), inhabited x -> inhabited (et_branch x x')
    | eti_branch_r : forall n (x x': et n), inhabited x' -> inhabited (et_branch x x').

  Definition grid n := {x : et n | inhabited x}.
*)

  Definition grid := et.

  Program Fixpoint eval' n (g : grid n) (l : llist bool n) : bool :=
    match g with
    | et_some => true
    | et_none m => false
    | et_branch m L R => match l with
      | nil => _
      | cons b bs => if b then eval' R bs else eval' L bs end
    end.
  Obligation 1.
   destruct l.
   simpl in Heq_l; subst.
   inversion e.
  Qed.
  Obligation 2.
   destruct l.
   simpl in *; subst.
   inversion e; auto.
  Qed.
  Obligation 3.
   destruct l.
   simpl in *; subst.
   inversion e; auto.
  Qed.

(*
  Definition eval' : forall n, grid n -> llist bool n -> bool.
   fix 1.
   intro.
   destruct n; intros g v.
    inversion g.
     exact true.
     exact false.
    inversion g.
     exact false.
     exact (match llhead v with
         | false => eval' n H0 (lltail v)
         | true => eval' n H1 (lltail v) end).
  Defined. *)
  Definition eval n (g : grid n) (v : llist bool n) :=
    eval' g (llrev v).

(*
  Compute (eval (et_branch et_some (et_none 0)) (llcons true (llnil bool))).
  Compute (eval (et_branch (et_branch et_some (et_some)) (et_none 1)) (llcons true (llcons false (llnil bool)))).
*)

  Definition empty_grid := et_some.
  Proposition empty_grid_is_empty : forall v, eval empty_grid v = true.
   firstorder.
  Qed.

  Fixpoint extensions n (g : grid n) : list (grid (S n)) :=
  match g with
  | et_some => et_branch et_some et_some :: et_branch et_some (et_none 0) :: et_branch (et_none 0) et_some :: nil
  | et_none m => et_none (S m) :: nil
  | et_branch m l r => mix_with (@et_branch (S m) ) (extensions l) (extensions r)
  end.

(*  Compute (extensions (et_branch (et_branch et_some et_some) (et_branch (et_none _) (et_some)))). *)

  Lemma eval'_branch n (g1 g2 : grid n) b v : eval' (et_branch g1 g2) (llcons b v) = if b then eval' g2 v else eval' g1 v.
   simpl.
   destruct b;
   f_equal;
   apply ll_proj_eq;
   auto.
  Qed.

  Lemma extension_foo : forall n (f : grid (S n)) (g : grid n),
    In f (extensions g) -> forall v, eval' g v = eval' f (llsnoc v true) || eval' f (llsnoc v false).
   induction g; intros.
    simpl in *.
    llniltac; intuition; subst; auto.

    simpl in *; intuition.
    subst; auto.

    simpl in H.
    apply In_mix_with in H.
    destruct H; destruct H; intuition; subst.
    generalize (IHg1 _ H0 (lltail v)); intro.
    generalize (IHg2 _ H (lltail v)); intro.
    clear IHg1 IHg2 H H0.
    replace v with (llcons (llhead v) (lltail v)) in * by auto.
    rewrite llist_tail_cons in *.
    rewrite eval'_branch.
    rewrite H1, H2.
    rewrite llist_snoc_cons.
    rewrite llist_snoc_cons.
    do 2 rewrite eval'_branch.
    destruct (llhead v); auto.
  Qed.
  Hint Resolve extension_foo.

  Proposition extensions_are_extensions : forall n (f : grid (S n)) (g : grid n),
    In f (extensions g) -> is_extension_of (eval f) (eval g).
   intros.
   intro.
   unfold restrict.
   unfold eval.
   do 2 rewrite ll_cons_rev_snoc.
   symmetry; auto.
  Qed.

  Proposition all_extensions : forall n (g : grid n) (f' : inhf (S n)),
    is_extension_of f' (eval g) -> exists f,
      In f (extensions g) /\ f' == eval f.
   induction g; intuition.
    unfold is_extension_of in H.
    generalize (H (llnil bool)); intro e.
    unfold restrict in e.
    remember (f' (llcons false (llnil _))) as b1.
    remember (f' (llcons true (llnil _))) as b2.
    cbv -[orb] in e.
    exists (et_branch (if b1 then et_some else et_none 0)
               (if b2 then et_some else et_none 0)).
     destruct b1; destruct b2;
     simpl; intuition;
    revert v; apply llist_ind1; intro;
    destruct a; (rewrite <- Heqb1 || rewrite <- Heqb2); auto.

    exists (et_none (S n)).
    simpl; intuition.
    generalize (H (lltail v)); intro.
    unfold restrict in H0.
    cbv -[orb llcons lltail] in H0.
    cbv.
    replace v with (llcons (llhead v) (lltail v)) by auto.
    destruct (llhead v);
     match goal with |- ?F = false => destruct F; auto; inversion H0 end.
    match goal with |- _ = ?F || _ => destruct F; auto end.

    unfold is_extension_of in *.
    set (f1 := (fun l => f' (llsnoc l false)) : inhf (S n) ).
    set (f2 := (fun l => f' (llsnoc l true)) : inhf (S n) ).
    simpl in H.
     assert (restrict f1 == eval g1).
      intro.
      unfold f1.
      unfold restrict in *.
      do 2 rewrite llist_snoc_cons.
      rewrite H.
      unfold eval.
      rewrite <- ll_snoc_rev_cons.
      simpl; f_equal.
      apply ll_proj_eq; auto.
     assert (restrict f2 == eval g2).
      intro.
      unfold f2.
      unfold restrict in *.
      do 2 rewrite llist_snoc_cons.
      rewrite H.
      unfold eval.
      rewrite <- ll_snoc_rev_cons.
      simpl; f_equal.
      apply ll_proj_eq; auto.
     apply IHg1 in H0.
     apply IHg2 in H1.
     destruct H0; destruct H1; intuition.
     exists (et_branch x x0).
     split.
      simpl.
      apply In_mix_with.
      firstorder.

      intro.
      unfold eval.
      replace (llrev v) with (llcons (llhead (llrev v)) (lltail (llrev v))) by auto.

      rewrite llhead_cohead.
      rewrite <- (llist_cohead_cotail) at 1.
      rewrite eval'_branch.
      destruct (llcohead v).
       replace (f' (llsnoc (llcotail v) true)) with (f2 (llcotail v)) by auto.
       rewrite H4.
       unfold eval; f_equal; auto.

       replace (f' (llsnoc (llcotail v) false)) with (f1 (llcotail v)) by auto.
       rewrite H3.
       unfold eval; f_equal; auto.
  Qed.

End TreeInhabitationGrid.


Require Import Coqlib.
Require Import ImpPrelude.
Require Import STS.
Require Import Behavior.
Require Import ModSem.
Require Import Skeleton.
Require Import PCM.
Require Import HoareDef OpenDef.
Require Import ProofMode.
Require Import Mem1.
Require Import AList.

Set Implicit Arguments.

Module Ag.
Section Ag.

Context {X: Type}.

Variant car: Type := | bag (P: X -> Prop).
(*** We follow Iris style ***)
(*** - just/unit/boom --> need Dec or excluded_middle_informative ***)
(*** - list A (just like Iris) --> need equiv class but we don't have ***)

Let _add := fun '(bag xs0) '(bag xs1) => bag (xs0 \1/ xs1).
Let _wf := fun '(bag xs0) => forall x0 x1 (IN0: xs0 x0) (IN1: xs0 x1), x0 = x1.

Program Instance t: URA.t := {
  URA.car := car;
  URA._add := _add;
  URA._wf := _wf;
  URA.unit := (bag bot1);
  URA.core := (fun _ => bag bot1);
}
.
Next Obligation.
  unfold _wf, _add in *. i. des_ifs. f_equal. extensionality x. eapply Axioms.prop_ext. tauto.
Qed.
Next Obligation.
  unfold _wf, _add in *. i. des_ifs. f_equal. extensionality x. eapply Axioms.prop_ext. tauto.
Qed.
Next Obligation.
  unfold _wf, _add in *. i. unseal "ra". des_ifs. f_equal. extensionality x. eapply Axioms.prop_ext.
  split; i; des; ss; et.
Qed.
Next Obligation. unfold _wf, _add in *. i. unseal "ra". des_ifs. Qed.
Next Obligation. unfold _wf, _add in *. i. unseal "ra". des_ifs. i. eapply H; et. Qed.
Next Obligation.
  unfold _wf, _add in *. i. unseal "ra". des_ifs. f_equal. extensionality x. eapply Axioms.prop_ext. split; i; des; ss; auto.
Qed.
Next Obligation.
  unfold _wf, _add in *. i. unseal "ra". des_ifs.
Qed.
Next Obligation.
 unfold _wf, _add in *. i. unseal "ra". exists (bag bot1). f_equal. extensionality x. eapply Axioms.prop_ext. split; i; des; ss; auto.
Qed.

Definition ag (x: X): t := bag (fun x0 => x0 = x).

(*** duplicable **)
(* Theorem dup_aux *)
(*         ag0 *)
(*   : *)
(*     <<UPD: URA.updatable ag0 (ag0 ⋅ ag0)>> *)
(* . *)
(* Proof. *)
(*   rr. unfold URA.wf, URA.add in *. unseal "ra". ss. ii. r in H. r. des_ifs. *)
(*   unfold _add in *. des_ifs. *)
(*   i. eapply H; tauto. *)
(* Qed. *)

Theorem dup_aux
        ag0
        (WF: URA.wf ag0)
  :
    <<UPD: ag0 = (ag0 ⋅ ag0)>>
.
Proof.
  rr. unfold URA.wf, URA.add in *. unseal "ra". ss. destruct ag0. ss. f_equal. extensionality x.
  eapply Axioms.prop_ext. tauto.
Qed.

(* Theorem dup *)
(*         x *)
(*   : *)
(*     <<UPD: URA.updatable (ag x) ((ag x) ⋅ (ag x))>> *)
(* . *)
(* Proof. eapply dup_aux. Qed. *)

Theorem wf
        x
  :
    <<UPD: URA.wf (ag x)>>
.
Proof. ur. ii. subst. refl. Qed.

Theorem dup
        x
  :
    <<UPD: (ag x) = ((ag x) ⋅ (ag x))>>
.
Proof. eapply dup_aux. eapply wf. Qed.

Theorem agree
        x y
        (WF: URA.wf ((ag x) ⋅ (ag y)))
  :
    x = y
.
Proof. ur in WF. eapply WF; et. Qed.

Theorem extends
        x y
        (WF: URA.wf y)
        (EXT: URA.extends (ag x) y)
  :
    y = ag x
.
Proof.
  ur in WF. r in EXT. des; clarify. ur. ur in WF. des_ifs; ss. unfold ag. f_equal.
  extensionality x0. apply Axioms.prop_ext. split; i; et.
Qed.

Lemma ag_inj
      (x0 x1: X)
      (EQ: ag x0 = ag x1)
  :
    x0 = x1
.
Proof.
  clarify. eapply func_ext_rev with (a:=x0) in H0. eapply prop_ext_rev in H0. des; et.
Qed.

End Ag.
End Ag.

Arguments Ag.t: clear implicits.

Module Opt.
Section Opt.

Context {M: URA.t}.

Let _add := fun (x y: option M) => match x, y with
                                   | Some x, Some y => Some (x ⋅ y)
                                   | Some x, _ => Some x
                                   | _, Some y => Some y
                                   | _, _ => None
                                   end.
Let _wf := fun (x: option M) => match x with | Some x => URA.wf x | _ => True end.

Program Instance t: URA.t := {
  URA.car := option M;
  URA._add := _add;
  URA._wf := _wf;
  URA.unit := None;
  URA.core := fun _ => None;
}
.
Next Obligation.
  unfold _wf, _add in *. i. des_ifs. f_equal. rewrite URA.add_comm. ss.
Qed.
Next Obligation.
  unfold _wf, _add in *. i. des_ifs. f_equal. rewrite URA.add_assoc. ss.
Qed.
Next Obligation. unfold _wf, _add in *. i. unseal "ra". des_ifs. Qed.
Next Obligation. unfold _wf, _add in *. i. unseal "ra". des_ifs. Qed.
Next Obligation. unfold _wf, _add in *. i. unseal "ra". des_ifs. eapply URA.wf_mon; et. Qed.
Next Obligation. unfold _wf, _add in *. i. unseal "ra". des_ifs. Qed.
Next Obligation. unfold _wf, _add in *. i. unseal "ra". des_ifs. Qed.
Next Obligation. unfold _wf, _add in *. i. unseal "ra". exists None. auto. Qed.

Theorem wf
        m
  :
    (<<WF: URA.wf (Some m)>>) <-> <<WF: URA.wf m>>
.
Proof.
  split; i.
  - ur in H; ss.
  - ur; ss.
Qed.

Theorem extends
        x0 m
        (WF: URA.wf m)
        (EXT: URA.extends (Some x0) m)
  :
    exists x1, m = Some x1 ∧ <<EXT: URA.extends x0 x1>>
.
Proof.
  r in EXT. des; clarify. ur. ss. ur in WF. des_ifs; ss.
  - esplits; et. r. esplits; et.
  - esplits; et. refl.
Qed.

End Opt.
End Opt.

Arguments Opt.t: clear implicits.

Module Ag2.
Section Ag2.

Context {X: Type}.

Variant car: Type := ag (x: X) | unit | boom.

Let _add := fun x y => match x, y with
                       | ag x, ag y => if excluded_middle_informative (x = y) then ag x else boom
                       | _, unit => x | unit, _ => y | _, _ => boom
                       end.
Let _wf := fun a => a <> boom.

Program Instance t: URA.t := {
  URA.car := car;
  URA._add := _add;
  URA._wf := _wf;
  URA.unit := unit;
  URA.core := fun _ => unit;
}
.
Next Obligation.
  unfold _wf, _add in *. i. des_ifs.
Qed.
Next Obligation.
  unfold _wf, _add in *. i. des_ifs.
Qed.
Next Obligation.
  unfold _wf, _add in *. i. unseal "ra". des_ifs.
Qed.
Next Obligation. unfold _wf, _add in *. i. unseal "ra". des_ifs. Qed.
Next Obligation. unfold _wf, _add in *. i. unseal "ra". des_ifs. Qed.
Next Obligation. unfold _wf, _add in *. i. unseal "ra". des_ifs. Qed.
Next Obligation. unfold _wf, _add in *. i. unseal "ra". des_ifs. Qed.
Next Obligation.
  i. exists unit. unfold _add. unseal "ra". auto.
Qed.

(* Definition ag (x: X): t := just x. *)

(*** duplicable **)
(* Theorem dup_aux *)
(*         ag0 *)
(*   : *)
(*     <<UPD: URA.updatable ag0 (ag0 ⋅ ag0)>> *)
(* . *)
(* Proof. *)
(*   rr. unfold URA.wf, URA.add in *. unseal "ra". ss. ii. r in H. r. des_ifs. *)
(*   unfold _add in *. des_ifs. *)
(*   i. eapply H; tauto. *)
(* Qed. *)

Theorem dup_aux
        ag0
        (WF: URA.wf ag0)
  :
    <<UPD: ag0 = (ag0 ⋅ ag0)>>
.
Proof. rr. unfold URA.wf, URA.add in *. unseal "ra". ss. destruct ag0; ss. des_ifs. Qed.

(* Theorem dup *)
(*         x *)
(*   : *)
(*     <<UPD: URA.updatable (ag x) ((ag x) ⋅ (ag x))>> *)
(* . *)
(* Proof. eapply dup_aux. Qed. *)

Theorem wf
        x
  :
    <<UPD: URA.wf (ag x)>>
.
Proof. ur. ss. Qed.

Theorem dup
        x
  :
    <<UPD: (ag x) = ((ag x) ⋅ (ag x))>>
.
Proof. eapply dup_aux. eapply wf. Qed.

Theorem agree
        x y
        (WF: URA.wf ((ag x) ⋅ (ag y)))
  :
    x = y
.
Proof. ur in WF. des_ifs. Qed.

Theorem extends
        x y
        (WF: URA.wf y)
        (EXT: URA.extends (ag x) y)
  :
    y = ag x
.
Proof. ur in WF. r in EXT. des; clarify. ur. ur in WF. des_ifs; ss. Qed.

End Ag2.
End Ag2.

Arguments Ag2.t: clear implicits.

Definition _stkRA: URA.t := (mblock ==> (Opt.t (Ag.t (val -> Prop))))%ra.
Instance stkRA: URA.t := Auth.t _stkRA.

Section PROOF.

  Context `{Σ: GRA.t}.
  Context `{@GRA.inG stkRA Σ}.

  Compute (URA.car (t:=_stkRA)).
  Definition _is_stack (h: mblock) (P: val -> Prop): _stkRA :=
    (fun _h => if (dec _h h) then Some (Ag.ag P) else ε)
  .

  Definition is_stack (h: mblock) (P: val -> Prop): stkRA := Auth.white (_is_stack h P).

  Theorem is_stack_dup
          h P
    :
      <<UPD: URA.updatable (is_stack h P) ((is_stack h P) ⋅ (is_stack h P))>>
  .
  Proof.
    unfold is_stack. eapply Auth.auth_dup_white. unfold _is_stack.
    extensionality _h. ss. ur. des_ifs.
    - ur. erewrite <- Ag.dup; ss.
    - ur. ss.
  Qed.

  Definition new_spec: fspec :=
    (mk_simple (fun P => (
                    (ord_pure 0),
                    (fun varg => (⌜varg = ([]: list val)↑⌝: iProp)%I),
                    (fun vret => (∃ h, ⌜vret = (Vptr h 0)↑⌝ ** OwnM (is_stack h P): iProp)%I)
    ))).

  Definition pop_spec: fspec :=
    mk_simple (fun '(h, P) => (
                   (ord_pure 0),
                 (fun varg => (⌜varg = ([Vptr h 0%Z]: list val)↑⌝
                                  ** OwnM (is_stack h P): iProp)%I),
                 (fun vret =>
                    (((OwnM (is_stack h P) ** ∃ x, ⌜(x = Vint (- 1)%Z ∨ P x) ∧ vret = x↑⌝): iProp)%I))
              ))
  .

  Definition push_spec: fspec :=
    mk_simple (fun '(h, P) => (
                   (ord_pure 0),
                   (fun varg => (OwnM (is_stack h P)
                        ** ∃ x, ⌜varg = ([Vptr h 0%Z; x]: list val)↑ ∧ P x⌝: iProp)%I),
                   (fun vret => (((OwnM (is_stack h P)): iProp)%I))
              ))
  .

  Definition StackSbtb: list (gname * fspecbody) :=
    [("new", mk_specbody new_spec (fun _ => trigger (Choose _)));
    ("pop",  mk_specbody pop_spec (fun _ => trigger (Choose _)));
    ("push", mk_specbody push_spec (fun _ => trigger (Choose _)))
    ].

  Definition StackStb: list (gname * fspec).
    eapply (Seal.sealing "stb").
    let x := constr:(List.map (map_snd fsb_fspec) StackSbtb) in
    let y := eval cbn in x in
    eapply y.
  Defined.

  Definition SStackSem: SModSem.t := {|
    SModSem.fnsems := StackSbtb;
    SModSem.mn := "Stack";
    SModSem.initial_mr := (GRA.embed (Auth.black (M:=_stkRA) (fun _ => ε)));
    SModSem.initial_st := tt↑;
  |}
  .

  Definition StackSem (stb: gname -> option fspec): ModSem.t := (SModSem.to_tgt stb) SStackSem.

  Definition SStack: SMod.t := {|
    SMod.get_modsem := fun _ => SStackSem;
    SMod.sk := [("new", Sk.Gfun); ("pop", Sk.Gfun); ("push", Sk.Gfun)];
  |}
  .

  Definition Stack (stb: Sk.t -> gname -> option fspec): Mod.t := (SMod.to_tgt stb) SStack.

End PROOF.
Global Hint Unfold StackStb: stb.


Require Import Omega.
Require Import RelationClasses.

Require Import sflib.

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

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

Set Implicit Arguments.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O A B C Bprime Cprime : Universe, ((wd_ A Cprime /\ (wd_ O A /\ (wd_ O Bprime /\ (wd_ O Cprime /\ (wd_ A B /\ (wd_ B C /\ (wd_ O C /\ (wd_ O B /\ (col_ O A C /\ (col_ A Bprime Cprime /\ (col_ A B C /\ col_ O A Cprime))))))))))) -> col_ O A Bprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library 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 library 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 Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

(** Properties of real sequences. *)
Require Import Max.
Require Export Rseries_facts.
Require Export Rsequence_facts.
Require Import Fourier.
Require Import Complex.
Require Import Csequence_facts.
Require Import Cseries.
Open Scope C_scope.
Open Scope Cseq_scope.

Lemma Cser_cv_re_compat Un l : Cser_cv Un l ->
  Rser_cv (fun n : nat => Cre (Un n)) (Cre l).
Proof.
intros Un l HC.
apply Rseq_cv_eq_compat with (fun n => Cre (sum_f_C0 Un n)).
 intro; rewrite sum_f_C0_Cre_compat; trivial.
 apply Cseq_cv_re_compat.
 apply HC.
Qed.

Lemma Cser_cv_im_compat Un l : Cser_cv Un l ->
  Rser_cv (fun n : nat => Cim (Un n)) (Cim l).
Proof.
intros Un l HC.
apply Rseq_cv_eq_compat with (fun n => Cim (sum_f_C0 Un n)).
 intro; rewrite sum_f_C0_Cim_compat; trivial.
 apply Cseq_cv_im_compat.
 apply HC.
Qed.

Lemma Cser_cv_re_im_compat : forall Un l,
  Rser_cv (fun n => Cre (Un n)) (Cre l) ->
  Rser_cv (fun n => Cim (Un n)) (Cim l) ->
  Cser_cv Un l.
Proof.
intros Un l HCre HCim.
apply Cseq_cv_re_im_compat.
 apply Rseq_cv_eq_compat with (sum_f_R0 (fun n => Cre (Un n))).
  intro; rewrite <- sum_f_C0_Cre_compat; trivial.
  apply HCre.
 apply Rseq_cv_eq_compat with (sum_f_R0 (fun n => Cim (Un n))).
  intro; rewrite <- sum_f_C0_Cim_compat; trivial.
  apply HCim.
Qed.

Lemma Ccauchy_product : forall An Bn la lb lna,
 Cser_cv An la ->
 Cser_cv Bn lb ->
 Cser_abs_cv An lna ->
 Cser_cv ((fun k:nat => sum_f_C0 (fun p:nat => An p * Bn (k - p)%nat) k)%C)
   (la * lb)%C.
Proof.
intros An Bn la lb lna HA HB HNA.
assert (HNAre : {lnare | Rser_abs_cv (fun n => Cre (An n)) lnare}).
 apply Rser_pos_maj_cv with (fun n => Cnorm (An n)).
  intro; apply Rabs_pos.
  intro; apply Cnorm_pos.
  intro; unfold Rseq_abs; apply Cre_le_Cnorm.
  exists lna; apply HNA.
destruct HNAre as [lnare HNAre].

assert (HNAim : {lnaim | Rser_abs_cv (fun n => Cim (An n)) lnaim}).
 apply Rser_pos_maj_cv with (fun n => Cnorm (An n)).
  intro; apply Rabs_pos.
  intro; apply Cnorm_pos.
  intro; unfold Rseq_abs; apply Cim_le_Cnorm.
  exists lna; apply HNA.
destruct HNAim as [lnaim HNAim].

apply Cser_cv_re_im_compat.
 rewrite Cre_mul.
 apply Rser_cv_eq_compat with (fun k =>
   sum_f_R0 (fun p => ((Cre (An p) * Cre (Bn (k - p)%nat)))%R) k -
   sum_f_R0 (fun p => ((Cim (An p) * Cim (Bn (k - p)%nat)))%R) k )%R.
  repeat (intro; rewrite <- sum_f_C0_Cre_compat; rewrite <- minus_sum; apply Rsum_eq_compat).
  intro; rewrite <- Cre_mul; trivial.

  apply Rser_cv_minus_compat.
   eapply (cauchy_product (fun n => Cre (An n)) (fun n => Cre (Bn n)));
     try (apply Cser_cv_re_compat; auto).
   apply HNAre.

   eapply (cauchy_product (fun n => Cim (An n)) (fun n => Cim (Bn n)));
     try (apply Cser_cv_im_compat; auto).
   apply HNAim.

 rewrite Cim_mul.
 apply Rser_cv_eq_compat with (fun k =>
   sum_f_R0 (fun p => ((Cre (An p) * Cim (Bn (k - p)%nat)))%R) k +
   sum_f_R0 (fun p => ((Cim (An p) * Cre (Bn (k - p)%nat)))%R) k )%R.
  repeat (intro; rewrite <- sum_f_C0_Cim_compat; rewrite <- plus_sum; apply Rsum_eq_compat).
  intro; rewrite Cim_mul; ring.

  apply Rser_cv_plus_compat.
   eapply (cauchy_product (fun n => Cre (An n)) (fun n => Cim (Bn n))).
    apply Cser_cv_re_compat; auto.
    apply Cser_cv_im_compat; auto.
    apply HNAre.

   rewrite Rmult_comm.
   eapply (cauchy_product (fun n => Cim (An n)) (fun n => Cre (Bn n))).
    apply Cser_cv_im_compat; auto.
    apply Cser_cv_re_compat; auto.
    apply HNAim.
Qed.

Lemma Cser_cv_unique Un l1 l2 : Cser_cv Un l1 -> Cser_cv Un l2 -> l1 = l2.
Proof.
intros Un l1 l2 H H'.
apply Cseq_cv_unique with (sum_f_C0 Un); auto.
Qed.

Lemma Csum_eq_compat_weak Un Vn n :
  (forall j, Un j = Vn j) -> sum_f_C0 Un n = sum_f_C0 Vn n.
Proof.
intros Un Vn n H.
induction n.
 apply H.
 simpl; rewrite H; rewrite IHn; trivial.
Qed.

Lemma Csum_eq_compat Un Vn n :
  (forall j, (j <= n)%nat -> Un j = Vn j) -> sum_f_C0 Un n = sum_f_C0 Vn n.
Proof.
intros Un Vn n H.
induction n.
 apply H; omega.
 simpl; rewrite H; try omega.
 rewrite IHn; trivial.
 intros j Hj.
 apply H; omega.
Qed.

Lemma Cser_cv_eq_compat Un Vn l :
  (forall j, Un j = Vn j) -> Cser_cv Un l -> Cser_cv Vn l.
Proof.
intros Un Vn l H HC.
apply Cseq_cv_eq_compat with (sum_f_C0 Un).
 intro; apply Csum_eq_compat_weak; apply H.
 apply HC.
Qed.


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

(** * Finite sets library *)

(** This file proposes an implementation of the non-dependent
    interface [MSetInterface.S] using strictly ordered list. *)

Require Export MSetInterface OrdersFacts OrdersLists.
Set Implicit Arguments.
Unset Strict Implicit.

(** * Functions over lists

   First, we provide sets as lists which are not necessarily sorted.
   The specs are proved under the additional condition of being sorted.
   And the functions returning sets are proved to preserve this invariant. *)

Module Ops (X:OrderedType) <: WOps X.

  Definition elt := X.t.
  Definition t := list elt.

  Definition empty : t := nil.

  Definition is_empty (l : t) := if l then true else false.

  (** ** The set operations. *)

  Fixpoint mem x s :=
    match s with
    | nil => false
    | y :: l =>
        match X.compare x y with
        | Lt => false
        | Eq => true
        | Gt => mem x l
        end
    end.

  Fixpoint add x s :=
    match s with
    | nil => x :: nil
    | y :: l =>
        match X.compare x y with
        | Lt => x :: s
        | Eq => s
        | Gt => y :: add x l
        end
    end.

  Definition singleton (x : elt) := x :: nil.

  Fixpoint remove x s : t :=
    match s with
    | nil => nil
    | y :: l =>
        match X.compare x y with
        | Lt => s
        | Eq => l
        | Gt => y :: remove x l
        end
    end.

  Fixpoint union (s : t) : t -> t :=
    match s with
    | nil => fun s' => s'
    | x :: l =>
        (fix union_aux (s' : t) : t :=
           match s' with
           | nil => s
           | x' :: l' =>
               match X.compare x x' with
               | Lt => x :: union l s'
               | Eq => x :: union l l'
               | Gt => x' :: union_aux l'
               end
           end)
    end.

  Fixpoint inter (s : t) : t -> t :=
    match s with
    | nil => fun _ => nil
    | x :: l =>
        (fix inter_aux (s' : t) : t :=
           match s' with
           | nil => nil
           | x' :: l' =>
               match X.compare x x' with
               | Lt => inter l s'
               | Eq => x :: inter l l'
               | Gt => inter_aux l'
               end
           end)
    end.

  Fixpoint diff (s : t) : t -> t :=
    match s with
    | nil => fun _ => nil
    | x :: l =>
        (fix diff_aux (s' : t) : t :=
           match s' with
           | nil => s
           | x' :: l' =>
               match X.compare x x' with
               | Lt => x :: diff l s'
               | Eq => diff l l'
               | Gt => diff_aux l'
               end
           end)
    end.

  Fixpoint equal (s : t) : t -> bool :=
    fun s' : t =>
    match s, s' with
    | nil, nil => true
    | x :: l, x' :: l' =>
        match X.compare x x' with
        | Eq => equal l l'
        | _ => false
        end
    | _, _ => false
    end.

  Fixpoint subset s s' :=
    match s, s' with
    | nil, _ => true
    | x :: l, x' :: l' =>
        match X.compare x x' with
        | Lt => false
        | Eq => subset l l'
        | Gt => subset s l'
        end
    | _, _ => false
    end.

  Definition fold (B : Type) (f : elt -> B -> B) (s : t) (i : B) : B :=
    fold_left (flip f) s i.

  Fixpoint filter (f : elt -> bool) (s : t) : t :=
    match s with
    | nil => nil
    | x :: l => if f x then x :: filter f l else filter f l
    end.

  Fixpoint for_all (f : elt -> bool) (s : t) : bool :=
    match s with
    | nil => true
    | x :: l => if f x then for_all f l else false
    end.

  Fixpoint exists_ (f : elt -> bool) (s : t) : bool :=
    match s with
    | nil => false
    | x :: l => if f x then true else exists_ f l
    end.

  Fixpoint partition (f : elt -> bool) (s : t) : t * t :=
    match s with
    | nil => (nil, nil)
    | x :: l =>
        let (s1, s2) := partition f l in
        if f x then (x :: s1, s2) else (s1, x :: s2)
    end.

  Definition cardinal (s : t) : nat := length s.

  Definition elements (x : t) : list elt := x.

  Definition min_elt (s : t) : option elt :=
    match s with
    | nil => None
    | x :: _ => Some x
    end.

  Fixpoint max_elt (s : t) : option elt :=
    match s with
    | nil => None
    | x :: nil => Some x
    | _ :: l => max_elt l
    end.

  Definition choose := min_elt.

  Fixpoint compare s s' :=
   match s, s' with
    | nil, nil => Eq
    | nil, _ => Lt
    | _, nil => Gt
    | x::s, x'::s' =>
      match X.compare x x' with
       | Eq => compare s s'
       | Lt => Lt
       | Gt => Gt
      end
   end.

End Ops.

Module MakeRaw (X: OrderedType) <: RawSets X.
  Module Import MX := OrderedTypeFacts X.
  Module Import ML := OrderedTypeLists X.

  Include Ops X.

  (** ** Proofs of set operation specifications. *)

  Section ForNotations.

  Definition inf x l :=
   match l with
   | nil => true
   | y::_ => match X.compare x y with Lt => true | _ => false end
   end.

  Fixpoint isok l :=
   match l with
   | nil => true
   | x::l => inf x l && isok l
   end.

  Notation Sort l := (isok l = true).
  Notation Inf := (lelistA X.lt).
  Notation In := (InA X.eq).

  Existing Instance X.eq_equiv.
  Hint Extern 20 => solve [order].

  Definition IsOk s := Sort s.

  Class Ok (s:t) : Prop := ok : Sort s.

  Hint Resolve ok.
  Hint Unfold Ok.

  Instance Sort_Ok s `(Hs : Sort s) : Ok s := { ok := Hs }.

  Lemma inf_iff : forall x l, Inf x l <-> inf x l = true.
  Proof.
    intros x l; split; intro H.
    (* -> *)
    destruct H; simpl in *.
      reflexivity.
    rewrite <- compare_lt_iff in H; rewrite H; reflexivity.
    (* <- *)
    destruct l as [|y ys]; simpl in *.
      constructor; fail.
    revert H; case_eq (X.compare x y); try discriminate; [].
    intros Ha _.
    rewrite compare_lt_iff in Ha.
    constructor; assumption.
  Qed.

  Lemma isok_iff : forall l, sort X.lt l <-> Ok l.
  Proof.
    intro l; split; intro H.
    (* -> *)
    elim H.
      constructor; fail.
    intros y ys Ha Hb Hc.
    change (inf y ys && isok ys = true).
    rewrite inf_iff in Hc.
    rewrite andb_true_iff; tauto.
    (* <- *)
    induction l as [|x xs].
      constructor.
    change (inf x xs && isok xs = true) in H.
    rewrite andb_true_iff, <- inf_iff in H.
    destruct H; constructor; tauto.
  Qed.

  Hint Extern 1 (Ok _) => rewrite <- isok_iff.

  Ltac inv_ok := match goal with
   | H:sort X.lt (_ :: _) |- _ => inversion_clear H; inv_ok
   | H:sort X.lt nil |- _ => clear H; inv_ok
   | H:sort X.lt ?l |- _ => change (Ok l) in H; inv_ok
   | H:Ok _ |- _ => rewrite <- isok_iff in H; inv_ok
   | |- Ok _ => rewrite <- isok_iff
   | _ => idtac
  end.

  Ltac inv := invlist InA; inv_ok; invlist lelistA.
  Ltac constructors := repeat constructor.

  Ltac sort_inf_in := match goal with
   | H:Inf ?x ?l, H':In ?y ?l |- _ =>
     cut (X.lt x y); [ intro | apply Sort_Inf_In with l; auto]
   | _ => fail
  end.

  Global Instance isok_Ok s `(isok s = true) : Ok s | 10.
  Proof.
  intros. assumption.
  Qed.

  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
  Definition Subset s s' := forall a : elt, In a s -> In a s'.
  Definition Empty s := forall a : elt, ~ In a s.
  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
  Definition Exists (P : elt -> Prop) (s : t) := exists x, In x s /\ P x.

  Lemma mem_spec :
   forall (s : t) (x : elt) (Hs : Ok s), mem x s = true <-> In x s.
  Proof.
  induction s; intros x Hs; inv; simpl.
  intuition. discriminate. inv.
  elim_compare x a; rewrite InA_cons; intuition; try order.
  discriminate.
  sort_inf_in. order.
  rewrite <- IHs; auto.
  rewrite IHs; auto.
  Qed.

  Lemma add_inf :
   forall (s : t) (x a : elt), Inf a s -> X.lt a x -> Inf a (add x s).
  Proof.
  simple induction s; simpl.
  intuition.
  intros; elim_compare x a; inv; intuition.
  Qed.
  Hint Resolve add_inf.

  Global Instance add_ok s x : forall `(Ok s), Ok (add x s).
  Proof.
  repeat rewrite <- isok_iff; revert s x.
  simple induction s; simpl.
  intuition.
  intros; elim_compare x a; inv; auto.
  Qed.

  Lemma add_spec :
   forall (s : t) (x y : elt) (Hs : Ok s),
    In y (add x s) <-> X.eq y x \/ In y s.
  Proof.
  induction s; simpl; intros.
  intuition. inv; auto.
  elim_compare x a; inv; rewrite !InA_cons, ?IHs; intuition.
  Qed.

  Lemma remove_inf :
   forall (s : t) (x a : elt) (Hs : Ok s), Inf a s -> Inf a (remove x s).
  Proof.
  induction s; simpl.
  intuition.
  intros; elim_compare x a; inv; auto.
  apply Inf_lt with a; auto.
  Qed.
  Hint Resolve remove_inf.

  Global Instance remove_ok s x : forall `(Ok s), Ok (remove x s).
  Proof.
  repeat rewrite <- isok_iff; revert s x.
  induction s; simpl.
  intuition.
  intros; elim_compare x a; inv; auto.
  Qed.

  Lemma remove_spec :
   forall (s : t) (x y : elt) (Hs : Ok s),
    In y (remove x s) <-> In y s /\ ~X.eq y x.
  Proof.
  induction s; simpl; intros.
  intuition; inv; auto.
  elim_compare x a; inv; rewrite !InA_cons, ?IHs; intuition;
   try sort_inf_in; try order.
  Qed.

  Global Instance singleton_ok x : Ok (singleton x).
  Proof.
  unfold singleton; simpl; auto.
  Qed.

  Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x.
  Proof.
  unfold singleton; simpl; split; intros; inv; auto.
  Qed.

  Ltac induction2 :=
    simple induction s;
     [ simpl; auto; try solve [ intros; inv ]
     | intros x l Hrec; simple induction s';
        [ simpl; auto; try solve [ intros; inv ]
        | intros x' l' Hrec'; simpl; elim_compare x x'; intros; inv; auto ]].

  Lemma union_inf :
   forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'),
   Inf a s -> Inf a s' -> Inf a (union s s').
  Proof.
  induction2.
  Qed.
  Hint Resolve union_inf.

  Global Instance union_ok s s' : forall `(Ok s, Ok s'), Ok (union s s').
  Proof.
  repeat rewrite <- isok_iff; revert s s'.
  induction2; constructors; try apply @ok; auto.
  apply Inf_eq with x'; auto; apply union_inf; auto; apply Inf_eq with x; auto; order.
  change (Inf x' (union (x :: l) l')); auto.
  Qed.

  Lemma union_spec :
   forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'),
   In x (union s s') <-> In x s \/ In x s'.
  Proof.
  induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto.
  Qed.

  Lemma inter_inf :
   forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'),
   Inf a s -> Inf a s' -> Inf a (inter s s').
  Proof.
  induction2.
  apply Inf_lt with x; auto.
  apply Hrec'; auto.
  apply Inf_lt with x'; auto.
  Qed.
  Hint Resolve inter_inf.

  Global Instance inter_ok s s' : forall `(Ok s, Ok s'), Ok (inter s s').
  Proof.
  repeat rewrite <- isok_iff; revert s s'.
  induction2.
  constructors; auto.
  apply Inf_eq with x'; auto; apply inter_inf; auto; apply Inf_eq with x; auto.
  Qed.

  Lemma inter_spec :
   forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'),
   In x (inter s s') <-> In x s /\ In x s'.
  Proof.
  induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto;
   try sort_inf_in; try order.
  Qed.

  Lemma diff_inf :
   forall (s s' : t) (Hs : Ok s) (Hs' : Ok s') (a : elt),
   Inf a s -> Inf a s' -> Inf a (diff s s').
  Proof.
  intros s s'; repeat rewrite <- isok_iff; revert s s'.
  induction2.
  apply Hrec; trivial.
  apply Inf_lt with x; auto.
  apply Inf_lt with x'; auto.
  apply Hrec'; auto.
  apply Inf_lt with x'; auto.
  Qed.
  Hint Resolve diff_inf.

  Global Instance diff_ok s s' : forall `(Ok s, Ok s'), Ok (diff s s').
  Proof.
  repeat rewrite <- isok_iff; revert s s'.
  induction2.
  Qed.

  Lemma diff_spec :
   forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'),
   In x (diff s s') <-> In x s /\ ~In x s'.
  Proof.
  induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto;
   try sort_inf_in; try order.
  right; intuition; inv; auto.
  Qed.

  Lemma equal_spec :
   forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'),
   equal s s' = true <-> Equal s s'.
  Proof.
  induction s as [ | x s IH]; intros [ | x' s'] Hs Hs'; simpl.
  intuition reflexivity.
  split; intros H. discriminate. assert (In x' nil) by (rewrite H; auto). inv.
  split; intros H. discriminate. assert (In x nil) by (rewrite <-H; auto). inv.
  inv.
  elim_compare x x' as C; try discriminate.
  (* x=x' *)
  rewrite IH; auto.
  split; intros E y; specialize (E y).
  rewrite !InA_cons, E, C; intuition.
  rewrite !InA_cons, C in E. intuition; try sort_inf_in; order.
  (* x<x' *)
  split; intros E. discriminate.
  assert (In x (x'::s')) by (rewrite <- E; auto).
  inv; try sort_inf_in; order.
  (* x>x' *)
  split; intros E. discriminate.
  assert (In x' (x::s)) by (rewrite E; auto).
  inv; try sort_inf_in; order.
  Qed.

  Lemma subset_spec :
   forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'),
   subset s s' = true <-> Subset s s'.
  Proof.
  intros s s'; revert s.
  induction s' as [ | x' s' IH]; intros [ | x s] Hs Hs'; simpl; auto.
  split; try red; intros; auto.
  split; intros H. discriminate. assert (In x nil) by (apply H; auto). inv.
  split; try red; intros; auto. inv.
  inv. elim_compare x x' as C.
  (* x=x' *)
  rewrite IH; auto.
  split; intros S y; specialize (S y).
  rewrite !InA_cons, C. intuition.
  rewrite !InA_cons, C in S. intuition; try sort_inf_in; order.
  (* x<x' *)
  split; intros S. discriminate.
  assert (In x (x'::s')) by (apply S; auto).
  inv; try sort_inf_in; order.
  (* x>x' *)
  rewrite IH; auto.
  split; intros S y; specialize (S y).
  rewrite !InA_cons. intuition.
  rewrite !InA_cons in S. rewrite !InA_cons. intuition; try sort_inf_in; order.
  Qed.

  Global Instance empty_ok : Ok empty.
  Proof.
  constructors.
  Qed.

  Lemma empty_spec : Empty empty.
  Proof.
  unfold Empty, empty; intuition; inv.
  Qed.

  Lemma is_empty_spec : forall s : t, is_empty s = true <-> Empty s.
  Proof.
  intros [ | x s]; simpl.
  split; auto. intros _ x H. inv.
  split. discriminate. intros H. elim (H x); auto.
  Qed.

  Lemma elements_spec1 : forall (s : t) (x : elt), In x (elements s) <-> In x s.
  Proof.
  intuition.
  Qed.

  Lemma elements_spec2 : forall (s : t) (Hs : Ok s), sort X.lt (elements s).
  Proof.
  intro s; repeat rewrite <- isok_iff; auto.
  Qed.

  Lemma elements_spec2w : forall (s : t) (Hs : Ok s), NoDupA X.eq (elements s).
  Proof.
  intro s; repeat rewrite <- isok_iff; auto.
  Qed.

  Lemma min_elt_spec1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s.
  Proof.
  destruct s; simpl; inversion 1; auto.
  Qed.

  Lemma min_elt_spec2 :
   forall (s : t) (x y : elt) (Hs : Ok s),
   min_elt s = Some x -> In y s -> ~ X.lt y x.
  Proof.
  induction s as [ | x s IH]; simpl; inversion 2; subst.
  intros; inv; try sort_inf_in; order.
  Qed.

  Lemma min_elt_spec3 : forall s : t, min_elt s = None -> Empty s.
  Proof.
  destruct s; simpl; red; intuition. inv. discriminate.
  Qed.

  Lemma max_elt_spec1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s.
  Proof.
  induction s as [ | x s IH]. inversion 1.
  destruct s as [ | y s]. simpl. inversion 1; subst; auto.
  right; apply IH; auto.
  Qed.

  Lemma max_elt_spec2 :
   forall (s : t) (x y : elt) (Hs : Ok s),
   max_elt s = Some x -> In y s -> ~ X.lt x y.
  Proof.
  induction s as [ | a s IH]. inversion 2.
  destruct s as [ | b s]. inversion 2; subst. intros; inv; order.
  intros. inv; auto.
  assert (~X.lt x b) by (apply IH; auto).
  assert (X.lt a b) by auto.
  order.
  Qed.

  Lemma max_elt_spec3 : forall s : t, max_elt s = None -> Empty s.
  Proof.
  induction s as [ | a s IH]. red; intuition; inv.
  destruct s as [ | b s]. inversion 1.
  intros; elim IH with b; auto.
  Qed.

  Definition choose_spec1 :
    forall (s : t) (x : elt), choose s = Some x -> In x s := min_elt_spec1.

  Definition choose_spec2 :
    forall s : t, choose s = None -> Empty s := min_elt_spec3.

  Lemma choose_spec3: forall s s' x x', Ok s -> Ok s' ->
   choose s = Some x -> choose s' = Some x' -> Equal s s' -> X.eq x x'.
  Proof.
   unfold choose; intros s s' x x' Hs Hs' Hx Hx' H.
   assert (~X.lt x x').
    apply min_elt_spec2 with s'; auto.
    rewrite <-H; auto using min_elt_spec1.
   assert (~X.lt x' x).
    apply min_elt_spec2 with s; auto.
    rewrite H; auto using min_elt_spec1.
   order.
  Qed.

  Lemma fold_spec :
   forall (s : t) (A : Type) (i : A) (f : elt -> A -> A),
   fold f s i = fold_left (flip f) (elements s) i.
  Proof.
  reflexivity.
  Qed.

  Lemma cardinal_spec :
   forall (s : t) (Hs : Ok s),
   cardinal s = length (elements s).
  Proof.
  auto.
  Qed.

  Lemma filter_inf :
   forall (s : t) (x : elt) (f : elt -> bool) (Hs : Ok s),
   Inf x s -> Inf x (filter f s).
  Proof.
  simple induction s; simpl.
  intuition.
  intros x l Hrec a f Hs Ha; inv.
  case (f x); auto.
  apply Hrec; auto.
  apply Inf_lt with x; auto.
  Qed.

  Global Instance filter_ok s f : forall `(Ok s), Ok (filter f s).
  Proof.
  repeat rewrite <- isok_iff; revert s f.
  simple induction s; simpl.
  auto.
  intros x l Hrec f Hs; inv.
  case (f x); auto.
  constructors; auto.
  apply filter_inf; auto.
  Qed.

  Lemma filter_spec :
   forall (s : t) (x : elt) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   (In x (filter f s) <-> In x s /\ f x = true).
  Proof.
  induction s; simpl; intros.
  split; intuition; inv.
  destruct (f a) eqn:F; rewrite !InA_cons, ?IHs; intuition.
  setoid_replace x with a; auto.
  setoid_replace a with x in F; auto; congruence.
  Qed.

  Lemma for_all_spec :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   (for_all f s = true <-> For_all (fun x => f x = true) s).
  Proof.
  unfold For_all; induction s; simpl; intros.
  split; intros; auto. inv.
  destruct (f a) eqn:F.
  rewrite IHs; auto. firstorder. inv; auto.
  setoid_replace x with a; auto.
  split; intros H'. discriminate.
  rewrite H' in F; auto.
  Qed.

  Lemma exists_spec :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   (exists_ f s = true <-> Exists (fun x => f x = true) s).
  Proof.
  unfold Exists; induction s; simpl; intros.
  firstorder. discriminate. inv.
  destruct (f a) eqn:F.
  firstorder.
  rewrite IHs; auto.
  firstorder.
  inv.
  setoid_replace a with x in F; auto; congruence.
  exists x; auto.
  Qed.

  Lemma partition_inf1 :
   forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s),
   Inf x s -> Inf x (fst (partition f s)).
  Proof.
  intros s f x; repeat rewrite <- isok_iff; revert s f x.
  simple induction s; simpl.
  intuition.
  intros x l Hrec f a Hs Ha; inv.
  generalize (Hrec f a H).
  case (f x); case (partition f l); simpl.
  auto.
  intros; apply H2; apply Inf_lt with x; auto.
  Qed.

  Lemma partition_inf2 :
   forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s),
   Inf x s -> Inf x (snd (partition f s)).
  Proof.
  intros s f x; repeat rewrite <- isok_iff; revert s f x.
  simple induction s; simpl.
  intuition.
  intros x l Hrec f a Hs Ha; inv.
  generalize (Hrec f a H).
  case (f x); case (partition f l); simpl.
  intros; apply H2; apply Inf_lt with x; auto.
  auto.
  Qed.

  Global Instance partition_ok1 s f : forall `(Ok s), Ok (fst (partition f s)).
  Proof.
  repeat rewrite <- isok_iff; revert s f.
  simple induction s; simpl.
  auto.
  intros x l Hrec f Hs; inv.
  generalize (Hrec f H); generalize (@partition_inf1 l f x).
  case (f x); case (partition f l); simpl; auto.
  Qed.

  Global Instance partition_ok2 s f : forall `(Ok s), Ok (snd (partition f s)).
  Proof.
  repeat rewrite <- isok_iff; revert s f.
  simple induction s; simpl.
  auto.
  intros x l Hrec f Hs; inv.
  generalize (Hrec f H); generalize (@partition_inf2 l f x).
  case (f x); case (partition f l); simpl; auto.
  Qed.

  Lemma partition_spec1 :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f -> Equal (fst (partition f s)) (filter f s).
  Proof.
  simple induction s; simpl; auto; unfold Equal.
  split; auto.
  intros x l Hrec f Hf.
  generalize (Hrec f Hf); clear Hrec.
  destruct (partition f l) as [s1 s2]; simpl; intros.
  case (f x); simpl; auto.
  split; inversion_clear 1; auto.
  constructor 2; rewrite <- H; auto.
  constructor 2; rewrite H; auto.
  Qed.

  Lemma partition_spec2 :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
  Proof.
  simple induction s; simpl; auto; unfold Equal.
  split; auto.
  intros x l Hrec f Hf.
  generalize (Hrec f Hf); clear Hrec.
  destruct (partition f l) as [s1 s2]; simpl; intros.
  case (f x); simpl; auto.
  split; inversion_clear 1; auto.
  constructor 2; rewrite <- H; auto.
  constructor 2; rewrite H; auto.
  Qed.

  End ForNotations.

  Definition In := InA X.eq.
  Instance In_compat : Proper (X.eq==>eq==> iff) In.
  Proof. repeat red; intros; rewrite H, H0; auto. Qed.

  Module L := MakeListOrdering X.
  Definition eq := L.eq.
  Definition eq_equiv := L.eq_equiv.
  Definition lt l1 l2 :=
    exists l1' l2', Ok l1' /\ Ok l2' /\ eq l1 l1' /\ eq l2 l2' /\ L.lt l1' l2'.

  Instance lt_strorder : StrictOrder lt.
  Proof.
  split.
  intros s (s1 & s2 & B1 & B2 & E1 & E2 & L).
  repeat rewrite <- isok_iff in *.
  assert (eqlistA X.eq s1 s2).
   apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *.
   transitivity s; auto. symmetry; auto.
  rewrite H in L.
  apply (StrictOrder_Irreflexive s2); auto.
  intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12)
                  (s2'' & s3' & B2' & B3 & E2' & E3 & L23).
  exists s1', s3'.
  repeat rewrite <- isok_iff in *.
  do 4 (split; trivial).
  assert (eqlistA X.eq s2' s2'').
   apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *.
   transitivity s2; auto. symmetry; auto.
  transitivity s2'; auto.
  rewrite H; auto.
  Qed.

  Instance lt_compat : Proper (eq==>eq==>iff) lt.
  Proof.
  intros s1 s2 E12 s3 s4 E34. split.
  intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
  exists s1', s3'; do 2 (split; trivial).
   split. transitivity s1; auto. symmetry; auto.
   split; auto. transitivity s3; auto. symmetry; auto.
  intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
  exists s1', s3'; do 2 (split; trivial).
   split. transitivity s2; auto.
   split; auto. transitivity s4; auto.
  Qed.

  Lemma compare_spec_aux : forall s s', CompSpec eq L.lt s s' (compare s s').
  Proof.
  induction s as [|x s IH]; intros [|x' s']; simpl; intuition.
  elim_compare x x'; auto.
  Qed.

  Lemma compare_spec : forall s s', Ok s -> Ok s' ->
   CompSpec eq lt s s' (compare s s').
  Proof.
  intros s s' Hs Hs'.
  destruct (compare_spec_aux s s'); constructor; auto.
  exists s, s'; repeat split; auto using @ok.
  exists s', s; repeat split; auto using @ok.
  Qed.

End MakeRaw.

(** * Encapsulation

   Now, in order to really provide a functor implementing [S], we
   need to encapsulate everything into a type of strictly ordered lists. *)

Module Make (X: OrderedType) <: S with Module E := X.
 Module Raw := MakeRaw X.
 Include Raw2Sets X Raw.
End Make.

(** For this specific implementation, eq coincides with Leibniz equality *)

Require Eqdep_dec.

Module Type OrderedTypeWithLeibniz.
  Include OrderedType.
  Parameter eq_leibniz : forall x y, eq x y -> x = y.
End OrderedTypeWithLeibniz.

Module Type SWithLeibniz.
  Declare Module E : OrderedTypeWithLeibniz.
  Include SetsOn E.
  Parameter eq_leibniz : forall x y, eq x y -> x = y.
End SWithLeibniz.

Module MakeWithLeibniz (X: OrderedTypeWithLeibniz) <: SWithLeibniz with Module E := X.
  Module E := X.
  Module Raw := MakeRaw X.
  Include Raw2SetsOn X Raw.

  Lemma eq_leibniz_list : forall xs ys, eqlistA X.eq xs ys -> xs = ys.
  Proof.
    induction xs as [|x xs]; intros [|y ys] H; inversion H; [ | ].
    reflexivity.
    f_equal.
    apply X.eq_leibniz; congruence.
    apply IHxs; subst; assumption.
  Qed.

  Lemma eq_leibniz : forall s s', eq s s' -> s = s'.
  Proof.
    intros [xs Hxs] [ys Hys] Heq.
    change (equivlistA X.eq xs ys) in Heq.
    assert (H : eqlistA X.eq xs ys).
      rewrite <- Raw.isok_iff in Hxs, Hys.
      apply SortA_equivlistA_eqlistA with X.lt; auto with *.
    apply eq_leibniz_list in H.
    subst ys.
    f_equal.
    apply Eqdep_dec.eq_proofs_unicity.
    intros x y; destruct (bool_dec x y); tauto.
  Qed.

End MakeWithLeibniz.