Require Import List.
Import ListNotations.
Require Import Coq.Init.Nat.
Require Import String.
Open Scope string_scope.

Inductive Var : Set :=
| variable : string -> Var.

Scheme Equality for Var.
Coercion variable : string >-> Var.

Definition Var_equality (var1 var2 : Var) : bool :=
  match var1,var2 with
  | variable x, variable y => if (eqb x y)
                            then true
                            else false
  end.

Compute Var_equality "aur" "aur".

(*Vectorul este implementat cu ajutorul List*)

Definition Vector := list nat.

Definition add_first (vect : Vector) (valoare : nat): Vector := valoare :: vect.
Notation "Add( V , Val )" := (add_first V Val) (at level 50).

Definition length (vect : Vector) : nat := List.length vect.
Notation "Size( V )" := (length V) (at level 50).

Definition last_el (vect : Vector) := List.last vect.
Notation "Last( V )" := (last_el V ) (at level 50).

Definition remove_ls (vect : Vector) : Vector := List.removelast vect.
Notation "RemoveLast( V )" := (remove_ls V) (at level 50).

Definition index (vect : Vector) (valoare : nat) : nat := List.nth valoare vect 0.
Notation " V [* I *]" := (index V I) (at level 40).

Check [1;2;3].
Compute Size( [1;32;11;9] ).
Compute Last( [1;22;13;91] ).

Definition Vector1 := [1;32;11;9].
Definition Vector2 := Add( Vector1 , 100 ).
Compute Vector2.
Compute Vector2 [* 3 *].
Compute RemoveLast( [1;32;11;9] ).

(* Environment *)

Inductive Value :=
| undef : Value
| structure : Value
| nat_val : nat -> Value
| bool_val : bool -> Value
| string_val: string -> Value.

Coercion nat_val : nat >-> Value.
Coercion bool_val : bool >-> Value.
Coercion string_val : string >-> Value.

Scheme Equality for Value.

Definition Env := Var -> Value.

Definition env1 : Env :=
  fun x =>
    if (Var_eq_dec x "variable")
    then nat_val 10
    else if(Var_eq_dec x "sir")
          then string_val "mesaj"
          else if(Var_eq_dec x "boolean")
                then bool_val true
                else undef.

Definition empty_env : Env := fun var => undef.

Inductive Struct :=
|structura : Var -> Struct.

Coercion structura : Var >-> Struct.

Definition is_declared (x : Var) (env : Env) :=
  if (Value_beq (env x) undef)
  then false
  else true.

Compute env1 "variable".
Compute env1 "not_a_variable".
Compute is_declared "variable" env1.
Compute is_declared "ms" env1.

Compute env1 "variable".

Definition conv_nat (x : Value) : nat :=
  match x with
  | structure => 999
  | undef => 999
  | bool_val n => 999
  | string_val n => 999
  | nat_val n' => n'
  end.

Compute conv_nat (env1 "variable").

Definition conv_str (x : Value) : string :=
  match x with
  | undef => "!"
  | structure => "!"
  | bool_val n => "!"
  | string_val n => n
  | nat_val n' => "!"
  end.

Compute conv_str (env1 "sir").

Definition conv_bool (x : Value) : bool :=
  match x with
  | undef => false
  | structure => false
  | bool_val n => n
  | string_val n => false
  | nat_val n' => false
  end.

Compute conv_bool (env1 "boolean").

Definition update (env : Env)
           (x : Var) (v : Value) : Env :=
  fun y =>
    if (Var_eq_dec y x)
    then v
    else (env y).

Notation "S [ V /' X ]" := (update S X V) (at level 0).

(*ArithExp*)

Inductive ArithExp :=
| avar : Var -> ArithExp
| anum : Value -> ArithExp
| aplus : ArithExp -> ArithExp -> ArithExp
| aminus : ArithExp -> ArithExp -> ArithExp
| amul : ArithExp -> ArithExp -> ArithExp
| adiv : ArithExp -> ArithExp -> ArithExp
| aperc : ArithExp -> ArithExp -> ArithExp.

Coercion avar : Var >-> ArithExp.
Coercion anum : Value >-> ArithExp.

Notation "A -' B" := (aminus A B) (at level 50).
Notation "A +' B" := (aplus A B) (at level 50).
Notation "A *' B" := (amul A B) (at level 40).
Notation "A /' B" := (adiv A B) (at level 40, left associativity).
Notation "A %' B" := (aperc A B) (at level 40).

Fixpoint AEval (a : ArithExp) (env : Env) : Value :=
  match a with
  | avar var => env var
  | anum n' => n'
  | aplus a1 a2 => conv_nat(AEval a1 env) + conv_nat(AEval a2 env)
  | amul a1 a2 => conv_nat(AEval a1 env) * conv_nat(AEval a2 env)
  | aminus a1 a2 =>if( leb (conv_nat(AEval a1 env)) (conv_nat(AEval a2 env)))
                       then 0
                       else conv_nat(AEval a1 env) - conv_nat(AEval a2 env)
  | adiv a1 a2 => conv_nat(AEval a1 env) / conv_nat(AEval a2 env)
  | aperc a1 a2 => (Nat.modulo (conv_nat(AEval a1 env)) (conv_nat(AEval a2 env)))

  end.

Compute AEval (16/'4) (env1).
Compute AEval "variable" env1.
Compute AEval ("variable" /' 2)(env1).

(*BoolExp*)
Inductive BoolExp :=
| btrue : BoolExp
| bfalse : BoolExp
| bgt    : ArithExp -> ArithExp -> BoolExp
| bge    : ArithExp -> ArithExp -> BoolExp
| beq    : ArithExp -> ArithExp -> BoolExp
| blt    : ArithExp -> ArithExp -> BoolExp
| ble    : ArithExp -> ArithExp -> BoolExp
| bnot   : BoolExp -> BoolExp
| band   : BoolExp -> BoolExp -> BoolExp
| bxor   : BoolExp -> BoolExp -> BoolExp
| bor    : BoolExp -> BoolExp -> BoolExp.

Notation "A >' B" := (bgt A B)(at level 60).
Notation "A >=' B" := (bge A B)(at level 60).
Notation "A ==' B" := (beq A B)(at level 60).
Notation "A <' B" := (blt A B)(at level 60).
Notation "A <=' B" := (ble A B)(at level 60).
Notation "! A" := (bnot A)(at level 60).
Notation "A &' B" := (band A B)(at level 60).
Notation "A |' B" := (bor A B)(at level 60).
Notation "A ^' B" := (bxor A B)(at level 60).

Fixpoint BEval (b : BoolExp) (env : Env) : Value :=
  match b with
  | btrue => true
  | bfalse => false
  | bnot b' => negb (conv_bool(BEval b' env))
  | bor b1 b2 => orb (conv_bool(BEval b1 env)) (conv_bool(BEval b2 env))
  | bxor b1 b2 => xorb (conv_bool(BEval b1 env)) (conv_bool(BEval b2 env))
  | band b1 b2 => andb (conv_bool(BEval b1 env)) (conv_bool(BEval b2 env))
  | beq a1 a2 => Nat.eqb (conv_nat(AEval a1 env)) (conv_nat(AEval a2 env))
  | blt a1 a2 => ltb (conv_nat(AEval a1 env)) (conv_nat(AEval a2 env))
  | ble a1 a2 => leb (conv_nat(AEval a1 env)) (conv_nat(AEval a2 env))
  | bgt a1 a2 => negb(leb (conv_nat(AEval a1 env)) (conv_nat(AEval a2 env)))
  | bge a1 a2 => negb(ltb (conv_nat(AEval a1 env)) (conv_nat(AEval a2 env)))
  end.

Compute BEval (!("x" <' 100)) env1.

Compute AEval "variable" env1.
Compute BEval ("variable" <=' 9) env1.

(*StringExp*)

Inductive StringExp :=
| str_val : string ->StringExp
| str_comp : StringExp -> StringExp -> StringExp
| str_concat : StringExp -> StringExp -> StringExp
| str_len : StringExp -> StringExp.

Coercion str_val : string >-> StringExp.

Notation "strcompare( Str1 , Str2 )" := (str_comp Str1 Str2) (at level 70).
Notation "strconcat( Str1 , Str2 )" := (str_concat Str1 Str2) (at level 50).
Notation "strlength( Str1 )" := (str_len Str1) (at level 50).

Check strcompare("abcd" , "abcd").

Fixpoint SEval (s : StringExp) (env : Env) : Value :=
  match s with
  | str_val str => str
  | str_comp s1 s2 => String.eqb (conv_str(SEval s1 env)) (conv_str(SEval s2 env))
  | str_concat s1 s2 => String.append (conv_str(SEval s1 env)) (conv_str(SEval s2 env))
  | str_len s => String.length (conv_str(SEval s env))
  end.

Compute SEval (strlength(strconcat("aer", "aer"))).

(*Stmt*)

Inductive Stmt :=
(*Declarari si assignments*)
| Nat_decl : Var -> Stmt
| Bool_decl : Var -> Stmt
| String_decl : Var -> Stmt
| Vector_decl : Vector -> Stmt
| nat_assignment : Var -> ArithExp -> Stmt
| string_assignment : Var -> StringExp -> Stmt
| bool_assignment : Var -> BoolExp -> Stmt
| sequence : Stmt -> Stmt -> Stmt

(*Structura implementata la nivel de Stmt - notatie*)
| structSTMT : Var -> Stmt -> Stmt
| Struct_init : Var -> Stmt
| Struct_decl : Var -> Var -> Stmt

(*Switch*)
| caseSTMT : ArithExp -> Stmt -> Stmt
| switchSTMT : ArithExp -> Stmt -> Stmt

(*I/O*)
| printSTMT : string -> Stmt
| scanSTMT : Var -> string -> Stmt

(*Instructiuni repetitive si conditionale*)
| ifthen : BoolExp -> Stmt ->Stmt
| ifthenelse : BoolExp -> Stmt -> Stmt -> Stmt
| while_ : BoolExp -> Stmt -> Stmt.

Inductive Function :=
| call : Stmt -> ArithExp -> Function
| f_return : Value -> Function.

Notation " C ([ A ]) " := (call C A)(at level 80).
Notation "'Return' # R " := (f_return R)(at level 80).

Check Return # 2.

Inductive Format :=
| func_form : Function -> Format
| stmt_form : Stmt -> Format
| func : Function -> Stmt -> Function -> Format
| form_divider : Format -> Format -> Format.
Notation "F1 '$' F2" := (form_divider F1 F2) (at level 99).
Coercion stmt_form : Stmt >-> Format.
Coercion func_form : Function >-> Format.

Notation "X ::= A" := (nat_assignment X A) (at level 80).
Notation "S1 ;; S2" := (sequence S1 S2) (at level 90).
Notation "-nat- V" := (Nat_decl V) (at level 70).
Notation "-bool- V" := (Bool_decl V) (at level 70).
Notation "-string- V" := (String_decl V) (at level 70).
Notation " S --> V " := (Struct_decl S V) (at level 70).
Notation "-vector- V" := (Vector_decl V) (at level 70).
Notation "[ X ] ::= A" := (bool_assignment X A) (at level 80).
Notation "'struct' ( NUME ){ S }" := (structSTMT NUME S) (at level 40).
Notation "copy_string( X , A )" := (string_assignment X A) (at level 80).
Notation " 'print' \\ S " := (printSTMT S) (at level 70).
Notation " 'scan' \\ V \\ S  " := (scanSTMT V S) (at level 70).
Notation "'If' ( B ) 'Then' S1 'Else' S2 " := (ifthenelse B S1 S2) (at level 92).
Notation "'If' ( B ) 'IfThen' S1 " := (ifthen B S1) (at level 92).
Notation "'while' ( Cond ) { S }" := (while_ Cond S)(at level 97).
Notation "'for_' ( I ; Cond ; Pas ) { S }" := (I ;; while_ Cond (S ;; Pas))(at level 97).
Notation "'switch' ( A ) { S } " := (switchSTMT A S)  (at level 90).
Notation " 'case' ( A ) [ S ]  " := (caseSTMT A S)  (at level 90).

Notation " % Call 'begin_' S R 'end_' % " := (func Call S R)(at level 97).

Fixpoint STMTeval (s : Stmt) (env : Env) (gas : nat) : Env :=
  match gas with
  | 0 => env
  | S gas' =>   match s with
                | Nat_decl var => update env var  0
                | Bool_decl var => update env var false
                | Vector_decl vector => env
                | Struct_init var => update env var structure
                | Struct_decl st v => STMTeval (-nat- "x.diametru" ;; -bool- "x.plin" ;; -string- "x.denumire" ;; Struct_init v ;; Struct_init st ) env gas'
                | String_decl var => update env var ""
                | nat_assignment var exp => update env var (AEval exp env)
                | string_assignment var str => update env var (SEval str env)
                | bool_assignment var b => update env var (BEval b env)

                | sequence S1 S2 => STMTeval S2 (STMTeval S1 env gas') gas'
                | ifthen cond S1 => if(conv_bool(BEval cond env))
                                    then STMTeval S1 env gas'
                                    else env
                | ifthenelse cond S1 S2 => if(conv_bool(BEval cond env))
                                            then STMTeval S1 env gas'
                                            else STMTeval S2 env gas'
                | while_ cond S1  => if(conv_bool(BEval cond env))
                                            then STMTeval (S1 ;; (while_ cond S1)) env gas'
                                            else env
                | caseSTMT A X => if(Nat.eqb (conv_nat(env "switch")) (conv_nat(AEval A env)) )
                                 then STMTeval X env gas'
                                 else env
                | switchSTMT A S1 => STMTeval S1 (STMTeval (-nat- "switch" ;; "switch" ::= conv_nat(AEval A env)) env gas') gas'
                | printSTMT str => STMTeval (-string- "print" ;; copy_string("print", str)) env gas'
                | scanSTMT var str =>  STMTeval (copy_string(var, str)) env gas'
                | structSTMT nume S2 => STMTeval S2 (STMTeval (Struct_init nume ) env gas') gas'

                end
  end.

Definition dec_ex := (STMTeval ( -bool- "bool" ;;
                              -string- "sir" ;;
                              -nat- "numar"
                      ) empty_env 100).

Compute dec_ex "numar".
Compute dec_ex "bool".
Compute dec_ex "sir".
Compute dec_ex "not_declared".

Definition decl_ex := (STMTeval ( -bool- "bool" ;;
                              -string- "sir" ;;
                              -nat- "numar" ;;
                              -vector-[11;23] ;;

                               "numar" ::= 12 ;;
                              copy_string("sirul2" , "avion") ;;
                              ["bul"] ::= bfalse ;;

                              If(btrue |' bfalse)
                                Then ["boool"] ::= btrue
                                Else ["boool"] ::= bfalse

                               ) empty_env 100).
Compute decl_ex "numar".
Compute decl_ex "bool".
Compute decl_ex "sir".
Compute decl_ex "sirul2".
Compute decl_ex "bul".
Compute decl_ex "boool".

Definition while_ex := (STMTeval ( -nat- "nr" ;;
                              "nr" ::= 3 ;;
                              while("nr" <=' 5)
                                {
                                 "nr" ::= 104
                                }

                               ) empty_env 100).

Compute while_ex "nr".

Definition for_ex := (STMTeval ( -nat- "i" ;;
                                 -nat- "sum" ;;
                              for_ ( "i" ::= 2 ; "i" <=' 4 ; "i" ::= "i" +' 1 ) {
                                  "sum" ::= "sum" +' "i"
                                }
                            ) empty_env 100).

Compute for_ex "sum".

Definition switch_ex := (STMTeval ( -nat- "x" ;;
                              switch (6)
                              {
                              case(2)
                              ["x" ::= 1] ;;
                              case(4)
                              ["x" ::= 7] ;;
                              case(2)
                              ["x" ::= 9]
                              }
                            ) empty_env 100).

Compute switch_ex "x".

Definition print_scan_ex := (STMTeval (   -string- "var" ;;
                                  print \\ "mesaj afisat" ;;
                                  scan \\ "var" \\ "mesaj citit"
                              ) empty_env 100).

Compute print_scan_ex "var".
Compute print_scan_ex "print".

Definition struct_ex := (STMTeval (
  struct ("cerc"){
  -nat- "diametru" ;;
  -string- "denumire" ;;
  -bool- "plin"
  } ;;
   "cerc"-->"x" ;;
  ["x.plin"] ::= btrue
) empty_env 100).

Compute struct_ex "cerc".
Compute struct_ex "x".
Compute struct_ex "x.plin".
Compute struct_ex "x.denumire".

Definition ex5 :=
  -bool-"global_var"
$
  -vector-[]
$
  % -nat- "func" ([ 2 ])
      begin_

        for_ ("i" ::=2 ; "i" <=' 6 ; "i" ::= "i" +' 1) {
          "x" ::= "x" +' "i"

          }
        Return # 1
      end_
  %
$
  % -bool- "bool_func" ([ true ])
    begin_
      If("n"<='9)
        Then "i" ::= 2
        Else "i" ::= 1
      Return # 1
    end_
  %
.


(* To be imported qualified. *)
Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.universal_algebra MathClasses.theory.ua_homomorphisms MathClasses.misc.workaround_tactics
  MathClasses.categories.categories.
Require
  MathClasses.categories.varieties MathClasses.categories.product MathClasses.theory.forget_algebra MathClasses.theory.forget_variety.

Inductive op := mult | one.

Definition sig: Signature := single_sorted_signature
  (λ o, match o with one => O | mult => 2%nat end).

Section laws.
  Global Instance: SgOp (Term0 sig nat tt) :=
    fun x => App sig _ _ _ (App sig _ _ _ (Op sig nat mult) x).
  Global Instance: MonUnit (Term0 sig nat tt) := Op sig nat one.

  Local Notation x := (Var sig nat 0%nat tt).
  Local Notation y := (Var sig nat 1%nat tt).
  Local Notation z := (Var sig nat 2%nat tt).

  Import notations.

  Inductive Laws: EqEntailment sig → Prop :=
    | e_mult_assoc: Laws (x & (y & z) === (x & y) & z)
    | e_mult_1_l: Laws (mon_unit & x === x)
    | e_mult_1_r: Laws (x & mon_unit === x).
End laws.

Definition theory: EquationalTheory := Build_EquationalTheory sig Laws.
Definition Object := varieties.Object theory.

Local Hint Extern 3 => progress simpl : typeclass_instances.

Definition forget: Object → setoids.Object :=
  @product.project unit
    (λ _, setoids.Object)
    (λ _, _) _
    (λ _, _) (λ _, _) (λ _, _) tt
     ∘ forget_algebra.object theory ∘ forget_variety.forget theory.
  (* todo: too ugly *)

(* Now follow a series of encoding/decoding functions to convert between the
 specialized Monoid/Monoid_Morphism type classes and the universal
 Algebra/InVariety/HomoMorphism type classes instantiated with the above
 signature and theory. *)

#[global]
Instance encode_operations A `{!SgOp A} `{!MonUnit A}: AlgebraOps sig (λ _, A) :=
  λ o, match o with mult => (&) | one => mon_unit: A end.

Section decode_operations.
  Context `{AlgebraOps theory A}.
  Global Instance: MonUnit (A tt) := algebra_op one.
  Global Instance: SgOp (A tt) := algebra_op mult.
End decode_operations.

Section encode_variety_and_ops.
  Context A `{Monoid A}.

  Global Instance encode_algebra_and_ops: Algebra sig _.
  Proof. constructor. intro. apply _. intro o. destruct o; simpl; try apply _; unfold Proper; reflexivity. Qed.

  Global Instance encode_variety_and_ops: InVariety theory (λ _, A) | 10.
  Proof.
   constructor. apply _.
   intros ? [] ?; simpl; unfold algebra_op; simpl.
     apply associativity.
    apply left_identity.
   apply right_identity.
  Qed.

  Definition object: Object := varieties.object theory (λ _, A).
End encode_variety_and_ops.

Lemma encode_algebra_only `{!AlgebraOps theory A} `{∀ u, Equiv (A u)} `{!Monoid (A tt)}: Algebra theory A .
Proof. constructor; intros []; apply _. Qed.

Global Instance decode_variety_and_ops `{InVariety theory A}: Monoid (A tt) | 10.
Proof with simpl; auto.
 pose proof (λ law lawgood x y z, variety_laws law lawgood (λ s n,
  match s with tt => match n with 0 => x | 1 => y | _ => z end end)) as laws.
 constructor.
   constructor.
     apply _.
    intro. apply_simplified (laws _ e_mult_assoc).
   apply_simplified (algebra_propers mult)...
  intro. apply_simplified (laws _ e_mult_1_l)...
 intro. apply_simplified (laws _ e_mult_1_r)...
Qed.

Lemma encode_morphism_only
  `{AlgebraOps theory A} `{∀ u, Equiv (A u)}
  `{AlgebraOps theory B} `{∀ u, Equiv (B u)}
  (f: ∀ u, A u → B u) `{!Monoid_Morphism (f tt)}: HomoMorphism sig A B f.
Proof.
 pose proof (monmor_a (f:=f tt)).
 pose proof (monmor_b (f:=f tt)).
 constructor.
    intros []. apply _.
   intros []; simpl.
    apply preserves_sg_op.
   apply (@preserves_mon_unit (A tt) (B tt) _ _ _ _ _ _ (f tt)).
   apply _.
  apply encode_algebra_only.
 apply encode_algebra_only.
Qed.

Lemma encode_morphism_and_ops `{Monoid_Morphism A B f}:
  @HomoMorphism sig (λ _, A) (λ _, B) _ _ ( _) ( _) (λ _, f).
Proof. intros. apply encode_morphism_only. assumption. Qed.

Lemma decode_morphism_and_ops
  `{InVariety theory x} `{InVariety theory y} `{!HomoMorphism theory x y f}:
    Monoid_Morphism (f tt).
Proof.
 constructor; try apply _.
  constructor; try apply _.
  apply (preserves theory x y f mult).
 apply (preserves theory x y f one).
Qed.

#[global]
Instance id_monoid_morphism `{Monoid A}: Monoid_Morphism (@id A).
Proof. repeat (split; try apply _); easy. Qed.

(* Finally, we use these encoding/decoding functions to specialize some universal results: *)
Section specialized.
  Context `{Equiv A}`{MonUnit A} `{SgOp A}
     `{Equiv B} `{MonUnit B} `{SgOp B}
     `{Equiv C} `{MonUnit C} `{SgOp C}
    (f : A → B) (g : B → C).

  Instance compose_monoid_morphism:
    Monoid_Morphism f → Monoid_Morphism g → Monoid_Morphism (g ∘ f).
  Proof.
    intros. pose proof (encode_morphism_and_ops (f:=f)) as P.
    pose proof (encode_morphism_and_ops (f:=g)) as Q.
    pose proof (@compose_homomorphisms theory _ _ _ _ _ _ _ _ _ _ _ P Q) as PP.
    pose proof (monmor_a (f:=f)). pose proof (monmor_b (f:=f)). pose proof (monmor_b (f:=g)).
    apply (@decode_morphism_and_ops _ _ _ _ _ _ _ _ _ PP).
  Qed.

  Lemma invert_monoid_morphism:
    ∀ `{!Inverse f}, Bijective f → Monoid_Morphism f → Monoid_Morphism (f⁻¹).
  Proof.
    intros. pose proof (encode_morphism_and_ops (f:=f)) as P.
    pose proof (@invert_homomorphism theory _ _ _ _ _ _ _ _ _ _ P) as Q.
    pose proof (monmor_a (f:=f)). pose proof (monmor_b (f:=f)).
    apply (@decode_morphism_and_ops _ _ _ _ _ _ _ _ _ Q).
  Qed.
End specialized.

#[global]
Hint Extern 4 (Monoid_Morphism (_ ∘ _)) => class_apply @compose_monoid_morphism : typeclass_instances.
#[global]
Hint Extern 4 (Monoid_Morphism (_⁻¹)) => class_apply @invert_monoid_morphism : typeclass_instances.


(*
        #####################################################
        ###  PLEASE DO NOT DISTRIBUTE SOLUTIONS PUBLICLY  ###
        #####################################################
*)

Require Import Coq.Strings.Ascii.
Require Import Coq.Lists.List.
Import ListNotations.
Open Scope char_scope.

Definition rule := (ascii * list ascii) % type.

Structure grammar := {
    grammar_vars : list ascii;
    grammar_terminals : list ascii;
    grammar_rules : list rule;
    grammar_start : ascii;
}.

Definition g1 := {|
    grammar_vars := ["C"];
    grammar_terminals := ["{"; "}"];
    grammar_start := "C";
    grammar_rules := [
        ("C", ["{"; "C"; "}"]);
        ("C", ["C"; "C"]);
        ("C", [])
    ];
|}.

Inductive Yield (G:grammar) : list ascii -> list ascii -> Prop :=
| yield_def:
    forall u v w A w1 w2,
    In (A, w) (grammar_rules G) ->
    w1 = u ++ [A] ++ v ->
    w2 = u ++ w ++ v ->
    Yield G w1 w2.

Inductive Derivation (G:grammar): list (list ascii) -> Prop :=
| derivation_nil:
    Derivation G [[grammar_start G]]
| derivation_cons:
    forall u v ws,
    Derivation G (u :: ws) ->
    Yield G u v ->
    Derivation G (v :: u :: ws).

Inductive Accept (G:grammar) : list ascii -> Prop :=
| accept_def:
    forall w ws,
    Derivation G (w::ws) ->
    Forall (fun c => List.In c (grammar_terminals G)) w ->
    Accept G w.


(*Commnet Here*)

Require Import ssreflect ssrbool.
Require Export Lists.List.
Require Export GenReflect SetSpecs.
Require Import Lia.
Require Import Wf.
From Equations Require Import Equations.

Require Export DecSort.
Require Export mBidAsk.
Require Export DecList.
Require Export mMatching.
Require Export Quantity.
Require Export mFair_Bid.

Section Fair_Ask.
Hypothesis unique_timestampask:forall s1 s2, (stime s1 = stime s2) -> s1 = s2.

Definition by_sp (s1:Ask) (s2:Ask) :=(Nat.ltb s1 s2) ||
((Nat.eqb s1 s2) && (Nat.leb (stime s1) (stime s2) )).

Definition fair_on_asks (M: list fill_type) (A: list Ask):=
  (forall s s', In s A /\ In s' A -> (s<>s') -> by_sp s s' -> In s' (asks_of M) ->
  (ttqa M s')>0 ->
  (In s (asks_of M)/\(ttqa M s= sq s))).

(*##################Sorting Criteria for Bids and Matchings for fair #################*)

Lemma by_sp_P : transitive by_sp /\ DecSort.comparable by_sp.
Proof. { split.
          { unfold transitive. unfold by_sp.
            intros y x z H H1. move /orP in H1. move /orP in H.
            apply /orP. destruct H1;destruct H.
            { left. move /leP in H0. move /leP in H. apply /leP. lia. }
            { move /andP in H. destruct H. left.
              move /leP in H0. move /eqP in H. apply /leP. lia. }
            { move /andP in H0. destruct H0. left.
              move /leP in H. move /eqP in H0. apply /leP. lia. }
            { move /andP in H0. move /andP in H. destruct H0. destruct H.
              right.
              move /eqP in H. move /eqP in H0. apply /andP.
              split. apply /eqP. lia. apply /leP. move /leP in H1.
              move /leP in H2. lia. } }
          { unfold DecSort.comparable.
              unfold by_sp. intros.  intros. destruct x. destruct y.  simpl.
              assert((sp0 = sp)\/(sp0 < sp)\/(sp < sp0)). lia. destruct H.
              subst. assert(Nat.ltb sp sp = false). apply /ltP. lia. rewrite H. simpl.
              assert(Nat.eqb sp sp =true). auto. rewrite H0. simpl.
              assert((stime0 <= stime)\/(stime < stime0)). lia. destruct H1.
              right. apply /leP. auto. left. apply /leP. lia.
              destruct H. right. apply /orP. left. apply /ltP. auto. left.
              apply /orP. left. apply /ltP. auto. } } Qed.

Lemma by_sp_antisymmetric : antisymmetric by_sp.
    Proof. unfold antisymmetric. intros. move /andP in H.
    destruct H as [H2 H3].
    unfold by_dbp in H2. unfold by_dbp in H3.
    move /orP in H2. move /orP in H3.
    destruct H2;destruct H3.
    move /ltP in H. move /ltP in H0. lia.
    move /andP in H0. destruct H0.
    move /ltP in H. move /eqP in H0. lia.
    move /andP in H. destruct H.
    move /ltP in H0. move /eqP in H.
    lia.
    move /andP in H. destruct H.
    move /leP in H1.
    move /andP in H0. destruct H0.
    move /leP in H2. apply unique_timestampask. lia.
Qed.

Lemma by_sp_refl: reflexive by_sp.
Proof. unfold reflexive. intros. unfold by_sp. apply /orP.
right. apply /andP. split. auto. apply nat_reflexive.  Qed.

Definition m_sp (m1:fill_type) (m2:fill_type) := by_sp (ask_of m1) (ask_of m2).

Lemma m_sp_P : transitive m_sp /\ DecSort.comparable m_sp.
Proof. { split.
         { unfold transitive. unfold m_sp.
           intros. cut (transitive by_sp). intros. eauto using by_sp_P.
            apply by_sp_P. }
         { unfold DecSort.comparable.  unfold m_sp. intros x y. eapply by_sp_P.
             } } Qed.

Lemma m_sp_refl: reflexive m_sp.
Proof. unfold reflexive. intros. unfold m_sp. unfold by_sp.
apply /orP. right. apply /andP. split. auto. apply nat_reflexive.  Qed.

Lemma m_sp_and_by_sp (M:list fill_type):
Sorted m_sp M -> Sorted by_sp (asks_of M).
Proof. intros. induction M. simpl. constructor. simpl. inversion H.
assert(exists a0, a0=(ask_of a)). eauto.
destruct H4. rewrite <- H4.
constructor. apply IHM. eauto. intros.
assert (exists m0, (In m0 M)/\(x0=(ask_of m0))).
eapply asks_of_elim. auto.
destruct H6. destruct H6. apply H3 in H6. unfold m_sp in H6.
subst. auto. Qed.

Hint Resolve m_sp_P by_sp_P : core.
Hint Resolve by_sp_refl m_sp_refl : core.

(*####################################################################################*)

(*----------------  Function to make a matching fair on bids -----------------------*)

(*####################################################################################*)

Equations FOA_aux (M:list fill_type) (A: list Ask) (t: nat):
(list fill_type) by wf (|M| + |A|):=
FOA_aux nil _ _ := nil;
FOA_aux _ nil _:= nil;
FOA_aux (m::M') (a::A') t:=  if (Nat.eqb (tq m) (sq a - t)) then

(Mk_fill (bid_of m) a (sq a - t) (tp m))::(FOA_aux M' A' 0)

else (if (Nat.leb (tq m) (sq a - t)) then

(Mk_fill (bid_of m) a (tq m) (tp m)):: (FOA_aux M' (a::A') (t + tq m))

else

(Mk_fill (bid_of m) a (sq a - t) (tp m))::
(FOA_aux ((Mk_fill (bid_of m) (ask_of m) (tq m - (sq a - t)) (tp m))::M') A' 0)).

Next Obligation.
lia. Qed.
Next Obligation.
lia. Qed.

Definition FOA (M:list fill_type) (A: list Ask) := FOA_aux M A 0.

(*################################################################################*)
(*Lemma on subsets: The list of Bids of FOA is subset of B
  and the Asks are subset of input M*)
(*################################################################################*)

(*################################################################################*)
(*Lemma on subsets: The list of Bids of FOA is subset of B
  and the Asks are subset of input M*)
(*################################################################################*)

Lemma FOA_aux_asks_subset (M: list fill_type) (A:list Ask)(t:nat) :
asks_of (FOA_aux M A t) [<=] A.
Proof. apply FOA_aux_elim. all: auto.
{
 intros. destruct (Nat.eqb (tq f) (sq a - t0)) eqn: Hfb.
 { simpl. cut (asks_of (FOA_aux l l0 0) [<=] l0). auto. exact H. }
 { destruct (Nat.leb (tq f) (sq a - t0)) eqn: Hbf.
 { simpl. eapply subset_elim1. apply H0. }
 {  simpl. eapply subset_elim2. exact H1. }
 }
}
Qed.

Lemma FOA_aux_bids_subset (M: list fill_type) (A: list Ask) (t:nat):
bids_of (FOA_aux M A t) [<=] bids_of M.
Proof. apply FOA_aux_elim. all: auto.
{
 intros. destruct (Nat.eqb (tq f) (sq a - t0)) eqn: Hfb.
 { simpl. cut (bids_of (FOA_aux l l0 0) [<=] bids_of l).
   auto. move /eqP in Hfb.
   assert ((tq f - (sq a - t0)) =0). lia.  exact H.
 }
 { destruct (Nat.leb (tq f) (sq a - t0)) eqn: Hbf.
   { simpl. eapply subset_elim2. apply H0. }
   { simpl. simpl in H1. eapply subset_elim1. exact H1. }
 }
}
Qed.

Lemma FOA_aux_tp_subset (M: list fill_type) (A: list Ask) (t:nat):
trade_prices_of (FOA_aux M A t) [<=] trade_prices_of M.
Proof. apply FOA_aux_elim. all: auto.
{
 intros. destruct (Nat.eqb (tq f) (sq a - t0)) eqn: Hfb.
 { simpl. cut (trade_prices_of (FOA_aux l l0 0) [<=] trade_prices_of l).
   auto. move /eqP in Hfb.
   assert ((tq f - (sq a - t0)) =0). lia.  exact H.
 }
 { destruct (Nat.leb (tq f) (sq a - t0)) eqn: Hbf.
   { simpl. eapply subset_elim2. apply H0. }
   { simpl. simpl in H1. eapply subset_elim1. exact H1. }
 }
}
Qed.

Lemma FOA_subA (M: list fill_type)(A: list Ask): bids_of (FOA M A) [<=] bids_of M.
Proof. { unfold FOA. apply FOA_aux_bids_subset. } Qed.
Lemma FOA_subB (M:list fill_type) (A: list Ask): asks_of (FOA M A) [<=] A.
Proof. { unfold FOA. apply FOA_aux_asks_subset. } Qed.

(*################################################################################*)
(*Lemmas: Total traded quantity *)

(*################################################################################*)

(*This lemma (fob_asks_invariant) ensures that the total traded quantity for each ask in FOA is equal
to it's  traded quantity in the input atching M. With this it is starightforward that the total traded
quantity of an ask in FOA is less than or equal to it's  ask quantity, since M is a
matching. This lemma is also useful to ensures that the asks are not changed during
fair on bids. This is useful to prove that during composition of FOA to FOA functions the fairness property of FOA
remains invariant. This lemaa is also useful to show that the total traded quantity of FOA is same as
input M. *)

Lemma FOA_aux_bids_invariant_t (M:list fill_type)(A: list Ask)(b:Bid)(t:nat)
(NZT:(forall m, In m M -> (tq m) > 0) ):
QA(A)>=QM(M)+t -> ttqb M b = ttqb (FOA_aux M A t) b.
Proof.
funelim (FOA_aux M A t). all:auto.
+ intros. simpl in H. assert(tq f =0). lia. assert(tq f >0). apply NZT. auto.
rewrite H0 in H1. inversion H1.
+ intros. rewrite <- Heqcall. destruct (Nat.eqb (tq f) (sq a - t)) eqn:Heq0.
{ simpl. destruct (b_eqb b (bid_of f)) eqn:Ham.
 cut (ttqb l b = ttqb (FOA_aux l l0 0) b). auto.
 all: eapply H. all: try (simpl; lia);auto;eauto.
 all: simpl in H2. all:move /eqP in Heq0. lia. lia. }
{ intros. destruct (Nat.leb (tq f) (sq a - t)) eqn: Hle.
{ simpl. simpl in H2.
move /leP in Hle. move /eqP in Heq0. destruct (b_eqb b (bid_of f)) eqn:Ham.
cut( ttqb l b = ttqb (FOA_aux l (a :: l0) (t + tq f)) b). auto.
 eapply H0. all: try (simpl; lia);auto.
eapply H0. all: try (simpl; lia);auto. }
{ simpl. simpl in H2.
move /leP in Hle. move /eqP in Heq0.
assert (ttqb (FOA_aux
      ({|bid_of := bid_of f;
      ask_of := ask_of f;
       tq := tq f - (sq a - t);
      tp := tp f |} :: l)
      l0 0) b =
      ttqb ({|bid_of := bid_of f;
      ask_of := ask_of f;
       tq := tq f - (sq a - t);
      tp := tp f |} :: l) b). symmetry.
      (*Handle this situation in general, try to clean it using ltac*)
 eapply H1. all: try (simpl; lia);auto.
 { intros. simpl in H3. destruct H3. subst m. simpl. lia. auto. } rewrite H3.
 simpl. destruct (b_eqb b (bid_of f)) eqn:Ham. simpl. lia. lia. } } Qed.

Lemma FOA_bids_invariant (M:list fill_type)(A: list Ask)(b:Bid)
(NZT:(forall m, In m M -> (tq m) > 0) ):
QA(A)>=QM(M) -> ttqb M b = ttqb (FOA M A) b.
Proof. unfold FOA. intros. eapply FOA_aux_bids_invariant_t. auto. lia. Qed.

(*################################################################################*)

(*Lemmas: Fair property *)

(*################################################################################*)

(*In this lemma (fob_aux_top_bid_fair) we first show that the top bid in B is fully traded
(trade quantity is total quantity. Note that, for arbitrary value of t, the statement is total
quantity minus t. For t=0, the statement of following lemma is same as fully traded*)

Lemma FOA_aux_top_ask_fair (M: list fill_type)(A: list Ask)(a:Ask)(t:nat)
(NZT:(forall m, In m M -> (tq m) > 0) )(NDA:NoDup (a::A)):
QM(M)>=(sq a) - t -> ttqa (FOA_aux M (a::A) t) a = sq a - t.
Proof.
revert t A a NDA. induction M as [ | m M']. intros.
simp FOA_aux. simpl. simpl in H. lia.
{ intros. simp FOA_aux. destruct (Nat.eqb (tq m) (sq a -t )) eqn: Heq0.
{
simpl.  assert(a_eqb a a = true). eauto. rewrite H0.
cut (ttqa (FOA_aux M' A 0) a = 0). lia.
assert (~In a A). eauto.
 assert (forall t, asks_of (FOA_aux M' A t) [<=] A). intros.
  eapply FOA_aux_asks_subset with (M:=M')(t:=t0)(A:=A).
 assert (forall t, ~In a (asks_of (FOA_aux M' A t))).  intros. specialize (H2 t0).
 eauto. apply ttqa_elim. auto. }
{ intros. destruct (Nat.leb (tq m) (sq a - t)) eqn: Hle.
{ simpl. assert(a_eqb a a = true). eauto. rewrite H0.
assert (ttqa (FOA_aux M' (a :: A) (t+tq m)) a = sq a - (t+tq m)).
apply IHM'. auto. exact NDA. simpl in H. move /leP in Hle. lia.
move /leP in Hle. rewrite H1. lia. }
{ simpl.
assert(a_eqb a a = true). eauto. rewrite H0.
cut (ttqa (FOA_aux ({|bid_of := bid_of m;
      ask_of := ask_of m;
      tq := tq m - (sq a - t);
      tp := tp m |} :: M') A 0) a = 0). lia.
assert (~In a A). eauto.
 assert (asks_of (FOA_aux ({|bid_of := bid_of m;
      ask_of := ask_of m;
      tq := tq m - (sq a - t);
      tp := tp m |} :: M') A 0) [<=] A). eapply FOA_aux_asks_subset.
 assert (~In a (asks_of (FOA_aux ({|bid_of := bid_of m;
      ask_of := ask_of m;
      tq := tq m - (sq a - t);
      tp := tp m |} :: M') A 0))).
 eauto. apply ttqa_elim. auto. }} } Qed.

(*Special case of above lemma for t=0 *)
Lemma FOA_aux_top_ask_fair0 (M: list fill_type)(A: list Ask)(a:Ask)
(NZT:(forall m, In m M -> (tq m) > 0) )(NDA:NoDup (a::A)):
QM(M)>=(sq a)-> ttqa (FOA M (a::A)) a = sq a.
Proof.
unfold FOA.
cut(QM(M)>=(sq a) - 0-> ttqa (FOA_aux M (a::A) 0) a = sq a - 0). lia.
eapply FOA_aux_top_ask_fair with (t:=0)(a:=a)(M:=M). exact. exact. Qed.

(*This lemma ensures that if a less move competitive ask is part of FOA then less competitive
must be part of matching.*)
Lemma FOA_aux_more_competative_in (M: list fill_type)(A: list Ask)(a1 a2:Ask)(t:nat)
(NZT:(forall m, In m M -> (tq m) > 0) )(NDA:NoDup A)(Hnot: a1<>a2):
Sorted by_sp A ->
by_sp a1 a2 ->
In a1 A ->
In a2 A ->
In a2 (asks_of (FOA_aux M A t))->
In a1 (asks_of (FOA_aux M A t)).
Proof.
funelim (FOA_aux M A t).
+ intros. simp FOA_aux in H1.
+ intros. simp FOA_aux in H1.
+ intros. destruct (a_eqb a a1) eqn: Hbb1;destruct (a_eqb a a2) eqn: Hbb2.
{ move /eqP in Hbb1;move /eqP in Hbb2.
  subst a1;subst a2. auto. }
{ move /eqP in Hbb1;subst a1.
  rewrite <- Heqcall.
  destruct (Nat.eqb (tq f) (sq a - t)) eqn:Heq0.
  simpl. left;auto.
  destruct (Nat.leb (tq f) (sq a - t)) eqn:Hle.
  simpl. left;auto.
  simpl. left;auto.
}
{ move /eqP in Hbb2;subst a2.
  { eapply Sorted_elim4 with (a0:=a)(x:=a1) in H2.
    assert(a=a1). apply by_sp_antisymmetric. apply /andP.
    auto. subst. simpl. auto.
    (**)
    destruct H4. subst. move /eqP in Hbb1. destruct Hbb1. auto. exact.
  }
}
{
  destruct H4;destruct H5.
  { subst a. move /eqP in Hbb1. elim Hbb1;auto. }
  { subst a. move /eqP in Hbb1. elim Hbb1;auto. }
  { subst a. move /eqP in Hbb2. elim Hbb2;auto. }
  { rewrite <- Heqcall. rewrite <- Heqcall in H6.
    destruct (Nat.eqb (tq f) (sq a - t)) eqn: Heq.
    { simpl. simpl in H6. destruct H6.
      { subst a. move /eqP in Hbb2. elim Hbb2;auto. }
      { right. eapply H. auto. all:eauto. }
    }
    { destruct (Nat.leb (tq f) (sq a - t)) eqn: Hle.
      { simpl. simpl in H6. destruct H6.
        { subst a. move /eqP in Hbb2. elim Hbb2;auto. }
        { right. eapply H0. auto. all:eauto. }
      }
      { simpl. simpl in H6. destruct H6.
        { subst a. move /eqP in Hbb2. elim Hbb2;auto. }
        { right. eapply H1. auto.
          intros. simpl in H7. destruct H7. subst m.
          simpl. move /eqP in Heq. move /leP in Hle. lia.
           all:eauto.
        }
      }
    }
  }
} Qed.

(*Following lemma (TQ_FM) ensures that if a less competitive bid is part of FOA_aux then
the total quantity traded in the matching should be more that or equal to more competitive bid*)

Lemma FOA_QM_ge_bqb (M: list fill_type)(A: list Ask)(a1 a2:Ask)(t:nat)
(NZT:(forall m, In m M -> (tq m) > 0) )(NDA:NoDup A)(Hnot: a1<>a2):
Sorted by_sp A ->  by_sp a1 a2 ->
In a1 (asks_of (FOA_aux M A t)) -> In a2 (asks_of (FOA_aux M A t))
->  QM(M)>=sq a1 - t.
Proof.  funelim (FOA_aux M A t).
+ intros. simp FOA_aux in H1. simpl in H1;elim H1.
+ intros. simp FOA_aux in H1. simpl in H1;elim H1.
+ intros. rewrite <- Heqcall in H4. rewrite <- Heqcall in H5.
destruct (Nat.eqb (tq f) (sq a - t)) eqn:Heq0.
{  (*Case : EQ *)
   simpl in H4. simpl in H5. move /eqP in Heq0. destruct H4;destruct H5.
   { subst a1. simpl. lia. }
   { subst a1. simpl. lia. }
   { (*this case contradict sorted. Move this into
     a general result and automate. *)subst a2. assert (In a1 l0). eapply FOA_aux_asks_subset.
     eauto. assert(by_sp a a1).
     { eapply Sorted_elim4 with (a0:=a)(x:=a1) in H2. auto. auto. }
       simpl. assert(a=a1). apply by_sp_antisymmetric. apply /andP.
       auto. subst. lia. }
   { eapply H in H3. all: try (simpl;lia);auto;eauto. }
}   (*End Case : EQ*)
{
   destruct (Nat.leb (tq f) (sq a - t)) eqn: Hle.
   { (*Case : Top trade quantity is less than the the top bid  *)
     move /eqP in Heq0. move /leP in Hle. simpl in H4. simpl in H5.
     destruct H4;destruct H5.
      { subst. destruct Hnot. auto. }
      { subst a. eapply H0 in H3. all: try (simpl;lia);auto.
       { case l eqn:Hl.  simp FOA_aux in H5. simp FOA_aux.
         destruct (Nat.eqb (tq f0) (sq a1 - (t + tq f))) eqn:Hfb1.
         simpl. left. auto.
         destruct (Nat.leb (tq f0) (sq a1 - (t + tq f))) eqn: Hfble.
         simpl;left;auto.
         simpl;left;auto.   }
      }
      { subst a2. assert (In a1 (a::l0)).
        eapply FOA_aux_asks_subset with (A:=(a::l0)).
        eauto. eapply Sorted_elim4 with (a0:=a)(x:=a1) in H2.
          assert(a=a1). apply by_sp_antisymmetric. apply /andP.
          auto. subst. destruct Hnot. auto.
          destruct H5. subst. destruct Hnot. auto.
          exact.
      }
      { eapply H0 with (a1:=a1) in H5. all: try (simpl;lia);auto. }
   }
   { (*Case : Top trade quantity is more than the the top ask *)
     move /eqP in Heq0. move /leP in Hle. simpl in H4. simpl in H5.
     destruct H4;destruct H5.
     { subst. destruct Hnot. auto. }
     { subst a. simpl. lia. }
     { eapply Sorted_elim4 with (a0:=a)(x:=a1) in H2. subst.
       assert(a2=a1). apply by_sp_antisymmetric. apply /andP.
       auto. subst. destruct Hnot. auto.
       eapply FOA_aux_asks_subset with (A:=(l0)) in H4. exact.
     }
     { eapply H1 with (a1:=a1) in H5. simpl in H5. all: try (simpl;lia);auto.
      intros. simpl in H6. destruct H6. subst m. all: try (simpl;lia);auto;eauto.
     }
   }
}   Qed.

Lemma FOA_aux_triv (l:list fill_type):
FOA_aux l nil 0 =nil.
Proof. funelim (FOA_aux l nil 0). simp FOA_aux. auto. simp FOA_aux. auto. Qed.

(*Following lemma (foa_aux_asks_fair_t) is the main fair lemma for arbitrary value of t.
  Note that, for t=0 the lemma is fair_on_asks lemma.*)
Lemma FOA_aux_asks_fair_t (M: list fill_type)(A: list Ask)(a a1 a2:Ask)(t:nat)
(NZT:(forall m, In m M -> (tq m) > 0) )(NDA:NoDup (a::A))(Hnot: a1<>a2):
Sorted by_sp (a::A) ->
by_sp a1 a2 ->
In a1 (asks_of (FOA_aux M (a::A) t)) ->
In a2 (asks_of (FOA_aux M (a::A) t)) ->
(a1=a -> ttqa (FOA_aux M (a::A) t) a1 = sq a1 - t )/\
(a1<>a->ttqa (FOA_aux M (a::A) t) a1 = sq a1 ).
Proof.
funelim (FOA_aux M (a::A) t). auto.
{ intros. destruct (a_eqb a1 a ) eqn: Hbb1.
  { move /eqP in Hbb1. subst a. split.
    intros. eapply FOA_aux_top_ask_fair. auto. auto.
    eapply FOA_QM_ge_bqb with(a1:=a1) in H5.
    all: try (simpl;lia);auto.
  }
  { split;intros.
    { subst a1. move /eqP in Hbb1. auto. }
    { rewrite<- Heqcall.
      destruct (Nat.eqb (tq f) (sq a - t)) eqn:Hmb. (*EQ case when a1<>a *)
      { simpl. rewrite Hbb1.
        rewrite<- Heqcall in H4. simpl in H4.
        rewrite<- Heqcall in H5. simpl in H5.
        destruct H4;destruct H5.
        { subst a1;auto. }
        { subst a1;auto. }
        { subst a2. assert (In a1 l0).
          eapply FOA_aux_asks_subset. eauto.
          eapply Sorted_elim4 with (a0:=a)(x:=a1)(lr:=by_sp) in H2.
          assert(a=a1). apply by_sp_antisymmetric. apply /andP.
          auto. subst. destruct Hnot. auto.
          exact.  }
         { case l0 as [| b0 A'] eqn:Hl0.
             { rewrite FOA_aux_triv in H4. simpl in H4. auto. }
             { destruct (a_eqb a1 b0) eqn: Hbb0.
                  { move /eqP in Hbb0. subst b0. eapply FOA_aux_top_ask_fair0.
                    auto. eauto. eapply FOA_QM_ge_bqb with (a1:=a1)(A:=(a1::A'))(a2:=a2) in H5.
                    lia. auto. eauto. eauto. eauto. all:exact. }
                  { eapply H with (a:=b0)(a1:=a1)(a2:=a2). auto. eauto. eauto.
                    eauto. eauto. eauto.
                    exact. exact. exact. move /eqP in Hbb0. exact. }
             }
         }
      }
      { destruct (Nat.leb (tq f) (sq a - t)) eqn: Hle.
           (*Less than case *)
        { rewrite <- Heqcall in H4. simpl in H4.
          rewrite <- Heqcall in H5. simpl in H5.
          move /eqP in Hmb. move /leP in Hle.
          destruct H4;destruct H5.
          { subst a1;auto. }
          { subst a1;auto. }
          { subst a2. assert (In a1 (a::l0)).
            eapply FOA_aux_asks_subset. eauto.
            eapply Sorted_elim4 with (a0:=a)(x:=a1)(lr:=by_sp) in H2.
            assert(a=a1). apply by_sp_antisymmetric. apply /andP.
            auto. subst.  destruct Hnot. auto.
            destruct H5. subst.  destruct Hnot. auto.
            exact. }
           { simpl. rewrite Hbb1. eapply H0 with (a2:=a2).
             all: try auto.  }
        }
           (*greater than case *)
        { simpl. rewrite Hbb1.
          rewrite <- Heqcall in H4. simpl in H4.
          rewrite <- Heqcall in H5. simpl in H5.
          move /eqP in Hmb. move /leP in Hle.
          destruct H4;destruct H5.
          { subst a1;auto. }
          { subst a1;auto. }
          { subst a2. assert (In a1 l0).
            eapply FOA_aux_asks_subset. eauto.
            apply Sorted_elim4 with (a0:=a)(x:=a1) in H2.
            assert(a=a1). apply by_sp_antisymmetric. apply /andP.
            auto. subst.  destruct Hnot. auto.
            exact. }
          { case l0 as [| a0 A'].
            { rewrite FOA_aux_triv in H4. simpl in H4. auto. }
            { destruct (a_eqb a1 a0) eqn: Hbb0.
              { move /eqP in Hbb0. subst a0. eapply FOA_aux_top_ask_fair0.
                simpl. intros. destruct H7. subst m. simpl. lia. auto. eauto.
                simpl. eapply FOA_QM_ge_bqb with (a1:=a1)(A:=(a1::A'))(a2:=a2) in H4 .
                simpl in H4. lia. intros. destruct H7. subst m. simpl. lia. eauto.
                eauto. auto. eauto. all:exact.
              }
              { eapply H1 with (a1:=a0)(a2:=a1)(a3:=a2).
                intros. destruct H7. subst m. simpl. lia. auto.
                eauto. eauto. eauto. eauto. eauto. eauto. exact. exact.
                move /eqP in Hbb0. exact.
              }
            }
          }
        }
      }
    }
  }
}
Qed.

(*This (FOA_asks_fair) is the main lemma which prove that FOA is fair on asks*)
Lemma FOA_asks_fair (M: list fill_type)(A: list Ask)(a1 a2:Ask)
(NZT:(forall m, In m M -> (tq m) > 0) )(NDA:NoDup A)(Hnot: a1<>a2):
Sorted by_sp A ->
by_sp a1 a2 ->
In a1 (asks_of (FOA M A)) -> In a2 (asks_of (FOA M A))
-> ttqa (FOA M A) a1 = sq a1.
Proof. { unfold FOA. intros. case A as [ |a A' ] eqn: HA.
          { intros. rewrite FOA_aux_triv in H1;simpl in H1;elim H1. }
          { intros.
          eapply FOA_aux_asks_fair_t with (t:=0)(a:=a)(M:=M)(A:=A')(a2:=a2) in H1.
           destruct H1. assert((a1=a)\/(a1<>a)). eauto. destruct H4.
            { apply H1 in H4. lia. }
            { apply H3 in H4. lia. }
            all:auto. }} Qed.

(*################################################################################*)

(*Lemmas: All matchable in FOA *)

(*################################################################################*)

Lemma FOA_aux_matchable_t (M: list fill_type)(A: list Ask)(a:Ask)(t:nat)
(NZT:(forall m, In m M -> (tq m) > 0) )(NDA:NoDup A):
Sorted by_sp (a::A) ->
Sorted m_sp M ->
All_matchable M ->
(asks_of M) [<=] (a::A) ->
(forall a0, ttqa M a0 <= sq a0) ->
(ttqa M a <= sq a - t) ->
All_matchable (FOA_aux M (a::A) t).

Proof. { funelim ((FOA_aux M (a::A) t)).
+ intros. simp FOA_aux.
+ unfold All_matchable. intros.
destruct (Nat.eqb (tq f) (sq a - t)) eqn: Heq. (*EQ case*)
   { rewrite <- Heqcall in H8.
     simpl in H8. destruct H8.
      { subst m. simpl. assert (In (ask_of f) (a::l0)). (*EQ: Base case *)
        apply H5. simpl. left. auto. assert (In f (f::l)). auto.
        specialize (H4 f). apply H4 in H9. assert (ask_of f >= a).
        eapply Sorted_elim2 with (x:=ask_of f) in H2. unfold by_sp in H2.
        move /orP in H2. destruct H2.
        { move /ltP in H2. lia. }
        { move /andP in H2. destruct H2. move /eqP in H2. lia. }
        auto. exact. lia. }
      { case l0 as [|a0 A'] eqn: HB. (*EQ: IH case*)
        { rewrite FOA_aux_triv in H8. inversion H8. }
        { revert H8.
          eapply H.
          { auto. }
          { eauto. }
          { auto. }
          { auto. }
          { eauto. }
          { eauto. }
          { eauto. }
          { move /eqP in Heq. simpl in H7.
            destruct (a_eqb a (ask_of f)) eqn: Hbm.
            { assert (ttqa l a = 0). lia.
              assert(~In a (asks_of l)).
              eapply ttqa_intro in H8. auto. auto.
              revert H5. unfold "[<=]". intros. simpl in H5.
              specialize (H5 a1). destruct H5. right. auto.
              subst a. elim H9. auto. simpl. auto.
            }
            { move /eqP in Hbm. assert (In a (asks_of l)
             \/ ~In a (asks_of l)). eauto.
             destruct H8.
             { simpl in H5.
               eapply m_sp_and_by_sp in H3. simpl in H3.
               eapply Sorted_elim4 with (a1 := (ask_of f))(x:=a) in H3.
               assert (a=(ask_of f)). apply by_sp_antisymmetric. apply /andP.
               auto. subst.
               eapply Sorted_elim4 with (a1:=a)(x:=ask_of f) in H2. auto.
               eapply included_elim2. eauto.
               eauto.
               exact. }
             { simpl in H5.
               eapply Subset_elim with (a1:=(ask_of f))(a2:=a)(l2:=(a0::A'))
               in H5. eauto. eauto. }
            }
          }
         { simpl in H6. intros. specialize (H6 a1).
           destruct (a_eqb a1 (ask_of f)).
           lia. lia.
         }
         { simpl in H6. specialize (H6 a0). destruct (a_eqb a0 (ask_of f)).
           lia. lia.
         }
       }
     }
   }
   { rewrite <- Heqcall in H8.
     destruct (Nat.leb (tq f) (sq a - t)) eqn: Hle.
     { simpl in H8. destruct H8.    (*LT case*)
        { subst m. simpl. assert (In (ask_of f) (a::l0)). (*LT: Base case*)
          apply H5. simpl. left. auto. assert (In f (f::l)). auto.
          specialize (H4 f). apply H4 in H9. assert (ask_of f >= a).
          eapply Sorted_elim2 with (x:=ask_of f) in H2. unfold by_sp in H2.
          move /orP in H2. destruct H2.
          { move /ltP in H2. lia. }
          { move /andP in H2. destruct H2. move /eqP in H2. lia. }
          auto. exact. lia.
        }
        (*LT: IH case*)
        { eapply H0.
          all: try auto; eauto.
          intros.
          specialize (H6 a0). simpl in H6. destruct (a_eqb a0 (ask_of f)).
          lia. lia. simpl in H7.
          destruct (a_eqb a (ask_of f)) eqn: Hbm.
          { move /leP in Hle.  lia. }
          { move /eqP in Hbm.
            assert (In a (asks_of l) \/ ~In a (asks_of l)).
            eauto. destruct H9.
            { simpl in H5.
              eapply Sorted_elim4 with (a0:=a)(x:=ask_of f) in H2.
              eapply m_sp_and_by_sp in H3. simpl in H3.
               eapply Sorted_elim4 with (a0 := (ask_of f))(x:=a) in H3.
               assert(a=(ask_of f)).  apply by_sp_antisymmetric. apply /andP.
               auto. subst a. destruct Hbm. auto.
               exact. eapply included_elim2. eauto.
            }
            { eapply  ttqa_elim in H9. lia. }
          }
        }
      }
      { simpl in H8. destruct H8.
      (*GT case*)
        { subst m. simpl. assert (In (ask_of f) (a::l0)). (*GT: Base case*)
          apply H5. simpl. left. auto. assert (In f (f::l)). auto.
          specialize (H4 f). apply H4 in H9.
          destruct (a_eqb a (ask_of f)) eqn:Hfb. move /eqP in Hfb. subst. auto.
          eapply Sorted_elim4 with (a0:=a)(x:=ask_of f) in H2.
          unfold by_sp in H2.
          move /orP in H2. destruct H2.
          { move /ltP in H2. lia. }
          { move /andP in H2. destruct H2. move /eqP in H2. lia. } move /eqP in Hfb.
             eapply included_elim2. eauto.
        }
        { case l0 as [|a0 A'] eqn: HB.  (*GT: IH case*)
          { rewrite FOA_aux_triv in H8. inversion H8. }
          { eapply H1 in H8.
            all: try auto. simpl. intros. destruct H9. subst m0.
            simpl. move /leP in Hle. lia. auto. eauto. eauto.
            revert H3. constructor. eauto. intros.  simpl.
            eapply Sorted_elim2  with (x0:=x) in H3. unfold m_sp in H3.
            unfold m_sp. simpl. exact. eauto. eauto.
            unfold All_matchable. simpl. intros.
            destruct H9. subst m0. simpl. eauto. eauto. simpl.
            move /leP in Hle. simpl in H7.
            destruct (a_eqb a (ask_of f)) eqn: Hbm.
            move /eqP in Heq. lia. move /eqP in Hbm.
            assert (In a (asks_of l) \/ ~In a (asks_of l)). eauto.
            destruct H9.
            { simpl in H5.
              eapply Sorted_elim4 with (a1:=a)(x:=ask_of f) in H2.
              eapply m_sp_and_by_sp in H3. simpl in H3.
               eapply Sorted_elim4 with (a1 := (ask_of f))(x:=a) in H3.
               assert(a=(ask_of f)).  apply by_sp_antisymmetric. apply /andP.
               auto. subst a. destruct Hbm. auto.
               exact. eapply included_elim2. eauto.
            }
            { simpl in H5.
              eapply Subset_elim0 with (a1:=(ask_of f))(a2:=a)
              (l2:=(a0::A')) in H5. eauto. eauto. eauto.
            }
           intros.  simpl. specialize (H6 a1). simpl in H6.
           destruct (a_eqb a1 (ask_of f)).
           lia. exact H6. simpl.  specialize (H6 a0). simpl in H6.
           destruct (a_eqb a0 (ask_of f)). lia. lia.
         }
       }
     }
  }
}
Qed.

Lemma FOA_matchable (M: list fill_type)(A: list Ask)
(NZT:(forall m, In m M -> (tq m) > 0) )
(NDA:NoDup A) :
Sorted by_sp A ->
Sorted m_sp M ->
All_matchable M ->
(asks_of M) [<=] A ->
(forall a0, ttqa M a0 <= sq a0) ->
All_matchable (FOA M A).
Proof. unfold FOA. intros.
case A eqn:HA. rewrite FOA_aux_triv. auto. intros.
eapply FOA_aux_matchable_t with (t:=0)(a:=a)(A:=l).
all: auto. eauto. specialize (H3 a);lia. Qed.

(*##########################IR M -> IR FOA#########################*)

Lemma FOA_aux_IR_t (M: list fill_type)(A: list Ask)(a:Ask)(t:nat)
(NZT:(forall m, In m M -> (tq m) > 0) )(NDA:NoDup A):
Sorted by_sp (a::A) ->
Sorted m_sp M ->
Is_IR M ->
(asks_of M) [<=] (a::A) ->
(forall a0, ttqa M a0 <= sq a0) ->
(ttqa M a <= sq a - t) ->
Is_IR (FOA_aux M (a::A) t).

Proof. { funelim ((FOA_aux M (a::A) t)).
+ intros. simp FOA_aux.
+ unfold Is_IR. intros.
destruct (Nat.eqb (tq f) (sq a - t)) eqn: Heq. (*EQ case*)
   { rewrite <- Heqcall in H8.
     simpl in H8. destruct H8.
      { subst m. unfold rational.
       simpl.  assert (In (ask_of f) (a::l0)). (*EQ: Base case *)
        apply H5. simpl. left. auto. assert (In f (f::l)). auto.
        specialize (H4 f). apply H4 in H9. assert (ask_of f >= a).
        eapply Sorted_elim2 with (x:=ask_of f) in H2. unfold by_sp in H2.
        move /orP in H2. destruct H2.
        { move /ltP in H2. lia. }
        { move /andP in H2. destruct H2. move /eqP in H2. lia. }
        auto. exact. unfold rational in H9. lia. }
      { case l0 as [|a0 A'] eqn: HB. (*EQ: IH case*)
        { rewrite FOA_aux_triv in H8. inversion H8. }
        { revert H8.
          eapply H.
          { auto. }
          { eauto. }
          { auto. }
          { auto. }
          { eauto. }
          { eauto. }
          { eauto. }
          { move /eqP in Heq. simpl in H7.
            destruct (a_eqb a (ask_of f)) eqn: Hbm.
            { assert (ttqa l a = 0). lia.
              assert(~In a (asks_of l)).
              eapply ttqa_intro in H8. auto. auto.
              revert H5. unfold "[<=]". intros. simpl in H5.
              specialize (H5 a1). destruct H5. right. auto.
              subst a. elim H9. auto. simpl. auto.
            }
            { move /eqP in Hbm. assert (In a (asks_of l)
             \/ ~In a (asks_of l)). eauto.
             destruct H8.
             { simpl in H5.
               eapply Sorted_elim4 with (a1:=a)(x:=ask_of f) in H2.
               eapply m_sp_and_by_sp in H3. simpl in H3.
               eapply Sorted_elim4 with (a1 := (ask_of f))(x:=a) in H3.
               assert (a=(ask_of f)). apply by_sp_antisymmetric. apply /andP.
               auto. subst. destruct Hbm. auto.
               exact.  eapply included_elim2. eauto. }
             { simpl in H5.
               eapply Subset_elim with (a1:=(ask_of f))(a2:=a)(l2:=(a0::A'))
               in H5. eauto. eauto. }
            }
          }
         { simpl in H6. intros. specialize (H6 a1).
           destruct (a_eqb a1 (ask_of f)).
           lia. lia.
         }
         { simpl in H6. specialize (H6 a0). destruct (a_eqb a0 (ask_of f)).
           lia. lia.
         }
       }
     }
   }
   { rewrite <- Heqcall in H8.
     destruct (Nat.leb (tq f) (sq a - t)) eqn: Hle.
     { simpl in H8. destruct H8.    (*LT case*)
        { subst m. simpl. assert (In (ask_of f) (a::l0)). (*LT: Base case*)
          apply H5. simpl. left. auto. assert (In f (f::l)). auto.
          specialize (H4 f). apply H4 in H9. assert (ask_of f >= a).
          eapply Sorted_elim2 with (x:=ask_of f) in H2. unfold by_sp in H2.
          move /orP in H2. destruct H2.
          { move /ltP in H2. lia. }
          { move /andP in H2. destruct H2. move /eqP in H2. lia. }
          auto. exact.
          unfold rational in H9. unfold rational. simpl. lia.
        }
        (*LT: IH case*)
        { eapply H0.
          all: try auto; eauto.
          intros.
          specialize (H6 a0). simpl in H6. destruct (a_eqb a0 (ask_of f)).
          lia. lia. simpl in H7.
          destruct (a_eqb a (ask_of f)) eqn: Hbm.
          { move /leP in Hle.  lia. }
          { move /eqP in Hbm.
            assert (In a (asks_of l) \/ ~In a (asks_of l)).
            eauto. destruct H9.
            { simpl in H5.
              eapply Sorted_elim4 with (a0:=a)(x:=ask_of f) in H2.
               eapply m_sp_and_by_sp in H3. simpl in H3.
               eapply Sorted_elim4 with (a0 := (ask_of f))(x:=a) in H3.
               assert (a=(ask_of f)). apply by_sp_antisymmetric. apply /andP.
               auto. subst. destruct Hbm. auto.
               exact.  eapply included_elim2. eauto.
            }
            { eapply  ttqa_elim in H9. lia. }
          }
        }
      }
      { simpl in H8. destruct H8.
      (*GT case*)
        { subst m. simpl. assert (In (ask_of f) (a::l0)). (*GT: Base case*)
          apply H5. simpl. left. auto. assert (In f (f::l)). auto.
          specialize (H4 f). apply H4 in H9. assert (ask_of f >= a).
          eapply Sorted_elim2 with (x:=ask_of f) in H2.
          unfold by_sp in H2.
          move /orP in H2. destruct H2.
          { move /ltP in H2. lia. }
          { move /andP in H2. destruct H2. move /eqP in H2. lia. }
          auto. exact. unfold rational in H9. unfold rational. simpl. lia.
        }
        { case l0 as [|a0 A'] eqn: HB.  (*GT: IH case*)
          { rewrite FOA_aux_triv in H8. inversion H8. }
          { eapply H1 in H8.
            all: try auto.
            { simpl. intros. destruct H9. subst m0.
            simpl. move /leP in Hle. lia. auto. }
            { eauto. }
            { eauto. }
            { revert H3. constructor. eauto. intros.  simpl.
            eapply Sorted_elim2  with (x0:=x) in H3. unfold m_sp in H3.
            unfold m_sp. simpl. exact. eauto. eauto. }
            { unfold Is_IR. simpl. intros.
            destruct H9. subst m0. unfold rational.
            simpl. apply H4. auto. apply H4. eauto. }
            {
            simpl.
            move /leP in Hle. simpl in H7.
            destruct (a_eqb a (ask_of f)) eqn: Hbm.
            move /eqP in Heq. lia. move /eqP in Hbm.
            assert (In a (asks_of l) \/ ~In a (asks_of l)). eauto.
            destruct H9.
            { simpl in H5.
              eapply Sorted_elim4 with (a1:=a)(x:=ask_of f) in H2.
               eapply m_sp_and_by_sp in H3. simpl in H3.
               eapply Sorted_elim4 with (a1 := (ask_of f))(x:=a) in H3.
               assert (a=(ask_of f)). apply by_sp_antisymmetric. apply /andP.
               auto. subst. destruct Hbm. auto.
               exact.  eapply included_elim2. eauto.
            }
            { simpl in H5.
              eapply Subset_elim0 with (a1:=(ask_of f))(a2:=a)
              (l2:=(a0::A')) in H5. eauto. eauto. eauto.
            }
           }
           { eauto. intros.  simpl. specialize (H6 a1). simpl in H6.
           destruct (a_eqb a1 (ask_of f)).
           lia. exact H6. }
           { simpl.  specialize (H6 a0). simpl in H6.
           destruct (a_eqb a0 (ask_of f)). lia. lia. }
         }
       }
     }
  }
}
Qed.

Lemma FOA_IR (M: list fill_type)(A: list Ask)
(NZT:(forall m, In m M -> (tq m) > 0) )
(NDA:NoDup A):
Sorted by_sp A ->
Sorted m_sp M ->
Is_IR M ->
(asks_of M) [<=] A ->
(forall a0, ttqa M a0 <= sq a0) ->
Is_IR (FOA M A).
Proof. unfold FOA. intros.
case A eqn:HA. rewrite FOA_aux_triv. unfold Is_IR.
intros. elim H4.
eapply FOA_aux_IR_t with (t:=0)(a:=a)(A:=l).
all: auto. eauto. specialize (H3 a);lia. Qed.

(*####################################################################*)

(*Uniform FOA*)

(*####################################################################*)

Lemma FOA_uniform (M:list fill_type)(A: list Ask):
Uniform M -> Uniform (FOA M A).
Proof. unfold Uniform. intros.
assert(trade_prices_of (FOA M A) [<=] trade_prices_of M).
apply FOA_aux_tp_subset. eauto. Qed.

(*####################################################################*)

(*Corrolary: Total traded quantity of FOA M B is same as M *)

(*####################################################################*)
Lemma FOA_size (M: list fill_type)(B: list Bid)(A:list Ask)
(NDA:NoDup A)(NDB:NoDup B) (NZT: forall m : fill_type, In m M -> tq m > 0):
matching_in B A M ->  QM(M)=QM(FOA M A).
Proof. unfold FOA. intros. destruct H. destruct H.
destruct H0. destruct H1.
rewrite <- QM_equal_QMb with (M:=M)(B:=B).
rewrite <- QM_equal_QMb with (M:=(FOA_aux M A 0))(B:=B).
eapply QMb_equal_QMb with (M1:= M) (M2:=(FOA_aux M A 0)).
intros. eapply FOA_aux_bids_invariant_t.
auto. cut (QM M <=  QA A). lia.
rewrite <- QM_equal_QMa with (A:=A).
eapply fill_size_vs_ask_size.
all:auto. intros. specialize (H3 a).
assert((In a (asks_of M))\/~In a (asks_of M)).
eauto. destruct H5. apply H3 in H5. auto.
apply ttqa_elim in H5. lia.
assert((bids_of (FOA_aux M A 0)) [<=] (bids_of M)).
apply FOA_subA. eauto. Qed.

(*####################Used in compositions #########################*)

Lemma FOA_bids_M_subset_bids_FOA (M: list fill_type)(A: list Ask)(NDA:NoDup A)
(NZT: forall m : fill_type, In m M -> tq m > 0):
(forall a : Ask, In a (asks_of M) -> ttqa M a <= sq a) ->
asks_of M [<=]A ->
bids_of M [<=] bids_of (FOA M A).
Proof.
unfold FOA. intros.
assert(QA A>=QM M).
rewrite <- QM_equal_QMa with (A:=A).
eapply fill_size_vs_ask_size.
all:auto. intros. eauto.
apply ttqb_equal_implies_subet. auto.
intros.
apply FOA_bids_invariant with (M:=M)(A:=A). auto. lia. Qed.

(*##########################################################################*)

(*Lemmas: Total traded quantity for each bids and asks in FOA is less than
their limit quantity *)

(*#######################################################################*)
Lemma FOA_aux_ttqa_top_t (M: list fill_type)(B: list Bid)(A:list Ask)
(t:nat)(a:Ask)(NDA:NoDup (a::A)):
ttqa (FOA_aux M (a::A) t) a <= sq a - t.
Proof. {
revert t. induction M as [ | m M'].
{ intro. simp FOA_aux. simpl;lia. }
{ intro. simp FOA_aux.
  destruct (Nat.eqb (tq m) (sq a - t)) eqn:Heq.
  { move /eqP in Heq. simpl. replace (a_eqb a a) with true.
    cut(ttqa (FOA_aux M' A 0) a = 0). lia.
    assert(~In a A). eauto. assert(asks_of ((FOA_aux M' A 0)) [<=] A).
    eapply FOA_aux_asks_subset. assert (~In a (asks_of (FOA_aux M' A 0))).
    eauto. eapply ttqa_elim in H1. exact. auto.
  }
  { destruct (Nat.leb (tq m) (sq a - t)) eqn:Hle.
    {  simpl. replace (a_eqb a a) with true.
       move /leP in Hle.
       cut(ttqa (FOA_aux M' (a :: A) (t + tq m)) a <= sq a - (t+tq m)).
       lia. eapply IHM'. auto.
    }
    { simpl.
      replace (a_eqb a a) with true.
      cut(ttqa
      (FOA_aux
      ({|
       bid_of := bid_of m;
       ask_of := ask_of m;
       tq := tq m - (sq a - t);
       tp := tp m
      |} :: M') A 0) a = 0). lia.
      assert(~In a A). eauto.
      assert(asks_of ((FOA_aux
      ({|
       bid_of := bid_of m;
       ask_of := ask_of m;
       tq := tq m - (sq a - t);
       tp := tp m |} :: M') A 0)) [<=] A).
      eapply FOA_aux_asks_subset. assert (~In a (asks_of (FOA_aux
      ({|
       bid_of := bid_of m;
       ask_of := ask_of m;
       tq := tq m - (sq a - t);
       tp := tp m |} :: M') A 0))).
      eauto. eapply ttqa_elim in H1. exact. auto.
    }
   }
 }
}Qed.

Lemma FOA_aux_ttqa_top0 (M: list fill_type)(A: list Ask)
(B:list Bid)(a:Ask)(NDA:NoDup (a::A)):
ttqa (FOA_aux M (a::A) 0) a <= sq a.
Proof. cut(ttqa (FOA_aux M (a :: A) 0) a <= sq a - 0). lia.
eapply FOA_aux_ttqa_top_t. eauto. exact. Qed.

Lemma FOA_aux_ttqa_t (M: list fill_type)(B: list Bid)(A:list Ask)(t:nat)(a a1:Ask)
(NDA:NoDup (a::A)):
(a1=a -> ttqa (FOA_aux M (a::A) t) a1 <= sq a1 - t)/\
(a1<>a -> ttqa (FOA_aux M (a::A) t) a1 <= sq a1).
Proof.
revert a1. funelim (FOA_aux M (a::A) t).
{ split;intros;simp FOA_aux;simpl;lia. }
{ intros. destruct (a_eqb a1 a ) eqn: Hbb1.
  { move /eqP in Hbb1. subst a1. split.
    intros. eapply FOA_aux_ttqa_top_t. auto. eauto.
    intros. elim H2. auto.
  }
  { split;intros.
    { subst a1. move /eqP in Hbb1. elim Hbb1. auto. }
    { rewrite<- Heqcall.
      destruct (Nat.eqb (tq f) (sq a - t)) eqn:Hmb. (*EQ case when b1<>b *)
      { simpl. rewrite Hbb1. case l0 as [|a0 A'] eqn:Hl0.
        rewrite FOA_aux_triv. simpl;lia.
        destruct (a_eqb a1 a0 ) eqn: Hb0b1.
        { move /eqP in Hb0b1. subst a0.
          assert(ttqa (FOA_aux l (a1 :: A') 0) a1 <= sq a1 - 0). eapply H.
          all:try auto. eauto. lia.
        }
        { eapply H. auto. auto. eauto. auto.
          auto. move /eqP in Hb0b1;auto.
        }
      }
      { destruct (Nat.leb (tq f) (sq a - t)) eqn: Hle.
           (*Less than case *)
        { simpl. rewrite Hbb1.
          eapply H0. auto. auto. simpl. auto.
        }
        { case l0 as [|a0 A'] eqn:Hl0.
          rewrite FOA_aux_triv. simpl. rewrite Hbb1. lia.
          destruct (a_eqb a1 a0 ) eqn: Hb0b1.
          {
          simpl. rewrite Hbb1.
          move /eqP in Hb0b1. subst a1.
          assert(ttqa
          (FOA_aux
          ({|
             bid_of := bid_of f;
             ask_of := ask_of f;
             tq := tq f - (sq a - t);
             tp := tp f
            |} :: l) (a0 :: A') 0) a0 <= sq a0 - 0). eapply H1.
          all:try auto. eauto. lia.
          }
          {
           simpl. rewrite Hbb1.
           eapply H1. all:try auto. eauto.
           move /eqP in Hb0b1;auto.
          }
        }
      }
    }
  }
} Qed.

Lemma FOA_ttqa (M: list fill_type)(B: list Bid)(A:list Ask)(a:Ask)(NDA:NoDup A):
matching_in B A M-> (ttqa (FOA M A)) a <= sq a.
Proof. unfold FOA. intros.
     destruct H. destruct H0. destruct H.
     destruct H2.
     case A as [| a0 A'] eqn: HA.
     rewrite FOA_aux_triv. simpl;lia.
     destruct (a_eqb a0 a) eqn: Hbb0.
     move /eqP in Hbb0.
     subst a0.
     eapply FOA_aux_ttqa_top0.
     eauto. eauto.
     eapply FOA_aux_ttqa_t.
     auto. eauto. move /eqP in Hbb0. auto.
     Qed.

Lemma FOA_ttqb (M: list fill_type)(B: list Bid)(A:list Ask)(b:Bid)
(NDA:NoDup A)(NDB:NoDup B) (NZT:(forall m, In m M -> (tq m) > 0)):
matching_in B A M -> (ttqb (FOA M A)) b <= bq b.
Proof.
     unfold FOA. intros.
     destruct H. destruct H0. destruct H.
     destruct H2.
     assert(ttqb M b = ttqb (FOA_aux M A 0) b).
     eapply FOA_bids_invariant with (M:=M)(A:=A)(b:=b).
     auto.
     rewrite <- QM_equal_QMa with (A:=A).
     eapply fill_size_vs_ask_size.
     all:auto. intros. specialize (H3 a).
     assert((In a (asks_of M))\/~In a (asks_of M)).
     eauto. destruct H5. apply H3 in H5. auto.
     apply ttqa_elim in H5. lia.
     rewrite <- H4. specialize (H2 b).
     assert((In b (bids_of M))\/~In b (bids_of M)).
     eauto. destruct H5. apply H2 in H5. auto.
     apply ttqb_elim in H5. lia. Qed.

(******************FOB_NZT*************************)

Lemma FOA_aux_NZT (M: list fill_type)(A:list Ask)(t:nat)(a:Ask)
(NZT:(forall m, In m M -> (tq m) > 0))(NDA:NoDup (a::A))
(NZA:(forall a0, In a0 (a::A) -> (sq a0) > 0))
:
(sq a) > t-> (forall m, In m (FOA_aux M (a::A) t) -> (tq m) > 0).
Proof. { funelim ((FOA_aux M (a::A) t)).
+ intros. simp FOA_aux in H0.
+ intros. rewrite <- Heqcall in H3.
destruct (Nat.eqb (tq f) (sq a - t)) eqn: Heq.
{ simpl in H3. destruct H3. subst m. simpl. lia.
  case l0 as [|a0 A'] eqn:Hl0. rewrite FOA_aux_triv in H3.
  elim H3. apply H in H3. all:auto. eauto.
}
{ destruct (Nat.leb (tq f) (sq a - t)) eqn: Hle.
  { simpl in H3. destruct H3. subst m. simpl. apply NZT.
    auto. apply H0 in H3. all:auto. move /leP in Hle.
    move /eqP in Heq.
    lia.
  }
{ simpl in H3. destruct H3. subst m. simpl. lia.
  case l0 as [|a0 A'] eqn:Hl0. rewrite FOA_aux_triv in H3.
  elim H3. apply H1 in H3. all:auto.
  intros. simpl in H4. destruct H4.
  subst m0. simpl. move /leP in Hle.
    move /eqP in Heq.
    lia. eauto. eauto.
} } } Qed.

Lemma FOA_NZT (M: list fill_type)(A:list Ask)
(NZT:(forall m, In m M -> (tq m) > 0))(NDA:NoDup (A))
(NZA:(forall a0, In a0 A -> (sq a0) > 0))
:
(forall m, In m (FOA M A) -> (tq m) > 0).
Proof. unfold FOA. induction A. rewrite FOA_aux_triv.
       simpl. intros. elim H.
       apply FOA_aux_NZT. auto. eauto. eauto. auto. Qed.

(*#############END:NZT FOB######################*)

Lemma FOA_matching (M: list fill_type)(B: list Bid)(A:list Ask)
(NDA:NoDup A)(NDB:NoDup B) (NZT:(forall m, In m M -> (tq m) > 0)):
matching_in B A M ->
matching_in B A (FOA (sort m_sp M) (sort by_sp A)).
Proof. unfold matching_in. unfold matching.
       intros. assert(bids_of M [<=] B /\ asks_of M [<=] A).
           apply H. destruct H0.

           split.
       { split.
         { apply FOA_matchable. intros.
           assert(In m M). eapply sort_elim. eauto. auto. eauto.
           auto. eapply sort_correct. apply by_sp_P.
           apply by_sp_P. eapply sort_correct. apply m_sp_P.
           apply m_sp_P. eauto. eauto. intros.
           assert(ttqa (sort m_sp M) a0 = ttqa M a0).
           eapply ttqa_inv. eauto. rewrite H2.
           assert(In a0 (asks_of M)\/~In a0 (asks_of M)). eauto.
           destruct H3. apply H. auto. apply ttqa_elim in H3. lia.
         }
         split.
         {
          intros. apply FOA_ttqb with (B:=B).
           eauto. eauto. eauto. assert(perm M (sort m_sp M) ). eauto.
           assert(perm A (sort by_sp A)). eauto.
           eapply match_inv with (A':=(sort by_sp A)) (M':=(sort m_sp M))(B':=B) in H3.
           auto. eauto. eauto. apply H.
         }
         {
          intros. apply FOA_ttqa with (B:=B).
           eauto. assert(matching_in B A M). auto.
           eapply match_inv with (A':=(sort by_sp A)) (M':=(sort m_sp M))(B':=B) in H3.
           auto. eauto. auto. eauto.
         } }
      {
      split. assert(bids_of (FOA (sort m_sp M) (sort by_sp A))[<=](bids_of (sort m_sp M))).
      apply FOA_subA. eauto.
      assert(asks_of (FOA (sort m_sp M) (sort by_sp A))[<=](sort by_sp A)).
      eapply FOA_subB. eauto.
      }
Qed.

Theorem FOA_exists_and_correct (M: list fill_type)(B: list Bid)(A:list Ask)
(NDA:NoDup A)(NDB:NoDup B)(NZT:(forall m, In m M -> (tq m) > 0)):
matching_in B A M ->
(exists M', (matching_in B A M')/\(fair_on_asks M' A)/\(QM(M) = QM(M'))).
Proof. exists (FOA (sort m_sp M) (sort by_sp A)).
split.
     { eapply FOA_matching in H. all:auto. }
split.
     { unfold fair_on_asks. intros.
       assert(Ha:In s (asks_of (FOA (sort m_sp M) (sort by_sp A)))).
       eapply FOA_aux_more_competative_in with (a1:=s)(a2:=s').
       all: auto. eauto. eapply sort_correct. apply by_sp_P.
       apply by_sp_P. destruct H0. eapply sort_intro in H0. eauto.
       destruct H0. eauto. split. auto.
       eapply FOA_asks_fair with (a1:=s)(a2:=s'). all:auto. eauto.
       apply sort_correct. apply by_sp_P.
       apply by_sp_P.
     }
     replace (QM(M)) with (QM(sort m_sp M)). eapply FOA_size.

     all:eauto. eapply match_inv with (A':=(sort by_sp A)) (M':=(sort m_sp M))(B':=B) in H.
     auto. eauto. eauto. eauto.
Qed.

End Fair_Ask.


(*
Copyright 2013 IMDEA Software Institute
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)

(******************************************************************************)
(* This file defines the generalized mutex type.                              *)
(* We need a notion of mutex where the options are not just nown/own but      *)
(* an arbitrary number of elements in-between. This reflects the possible     *)
(* stages of acquiring a lock. Once a thread embarks on the first stage, it   *)
(* excludes others, but it may require more steps to fully acquire the lock.  *)
(******************************************************************************)

From Coq Require Import ssreflect ssrbool ssrfun.
From Coq Require Setoid.
From mathcomp Require Import ssrnat eqtype seq.
From pcm Require Import options prelude pred.
From pcm Require Import pcm morphism natmap.

(***********************)
(* Generalized mutexes *)
(***********************)

Module GeneralizedMutex.
Section GeneralizedMutex.
Variable T : Type. (* the mutex stages, excluding undef and unit *)

Inductive mutex := undef | nown | mx of T.

Definition join' x y :=
  match x, y with
    undef, _ => undef
  | _, undef => undef
  | nown, x => x
  | x, nown => x
  | mx _, mx _ => undef
  end.

Definition valid' x := if x is undef then false else true.

Lemma joinC : commutative join'.
Proof. by case=>[||x]; case=>[||y]. Qed.

Lemma joinA : associative join'.
Proof. by case=>[||x]; case=>[||y]; case=>[||z]. Qed.

Lemma unitL : left_id nown join'.
Proof. by case. Qed.

Lemma validL x y : valid' (join' x y) -> valid' x.
Proof. by case: x. Qed.

Lemma valid_unit : valid' nown.
Proof. by []. Qed.

Definition mutexPCMMix := PCMMixin joinC joinA unitL validL valid_unit.
Canonical mutexPCM := Eval hnf in PCM mutex mutexPCMMix.

(* cancelativity *)

Lemma joinmK (m1 m2 m : mutexPCM) : valid (m1 \+ m) -> m1 \+ m = m2 \+ m -> m1 = m2.
Proof. by case: m m1 m2=>[||m][||m1][||m2]; rewrite !pcmE. Qed.

Definition mutexCPCMMix := CPCMMixin joinmK.
Canonical mutexCPCM := Eval hnf in CPCM mutex mutexCPCMMix.

(* topped structure *)

Lemma unitb (x : mutex) : reflect (x = Unit) (if x is nown then true else false).
Proof. by case: x=>[||x]; constructor; rewrite !pcmE. Qed.

Lemma join0E (x y : mutex) : x \+ y = Unit -> x = Unit /\ y = Unit.
Proof. by case: x y=>[||x][||y]. Qed.

Lemma valid3 (x y z : mutex) : valid (x \+ y \+ z) =
        [&& valid (x \+ y), valid (y \+ z) & valid (x \+ z)].
Proof. by case: x y z=>[||x][||y][||z]. Qed.

Lemma valid_undef : ~~ valid undef.
Proof. by []. Qed.

Lemma undef_join x : undef \+ x = undef.
Proof. by []. Qed.

Definition mutexTPCMMix := TPCMMixin unitb valid_undef undef_join.
Canonical mutexTPCM := Eval hnf in TPCM mutex mutexTPCMMix.

End GeneralizedMutex.

Section Equality.
Variable T : eqType.

Definition mutex_eq (x y : mutex T) :=
  match x, y with
    undef, undef => true
  | nown, nown => true
  | mx x', mx y' => x' == y'
  | _, _ => false
  end.

Lemma mutex_eqP : Equality.axiom mutex_eq.
Proof.
case=>[||x]; case=>[||y] /=; try by constructor.
by case: eqP=>[->|H]; constructor=>//; case=>/H.
Qed.

Definition mutexEqMix := EqMixin mutex_eqP.
Canonical mutexEqType := Eval hnf in EqType (mutex T) mutexEqMix.
Canonical mutexEQPCM := Eval hnf in EQPCM (mutex T) (mutexPCMMix T).

End Equality.

Module Exports.
Canonical mutexPCM.
Canonical mutexCPCM.
Canonical mutexEqType.
Canonical mutexTPCM.
Canonical mutexEQPCM.
Notation mutex := mutex.
Notation mx_undef := undef.
Notation nown := nown.
Notation mx := mx.
Notation mutexPCM := mutexPCM.
Notation mutexTPCM := mutexTPCM.
Arguments mx_undef {T}.
Arguments nown {T}.
Arguments mx [T].

(* mutexes with distingusihed own element *)
Notation mtx T := (mutex (option T)).
Notation mtx2 := (mtx False).
Notation mtx3 := (mtx unit).
Notation own := (mx None).
Notation auth x := (mx (Some x)).
Notation auth1 := (mx (Some tt)).
End Exports.
End GeneralizedMutex.

Export GeneralizedMutex.Exports.

(* some lemmas for generalized mutexes *)

Section MutexLemmas.
Variable T : Type.
Implicit Types (t : T) (x y : mutex T).

Variant mutex_spec x : mutex T -> Type :=
| mutex_undef of x = mx_undef : mutex_spec x mx_undef
| mutex_nown of x = Unit : mutex_spec x Unit
| mutex_mx t of x = mx t : mutex_spec x (mx t).

Lemma mxP x : mutex_spec x x.
Proof. by case: x=>[||t]; constructor. Qed.

Lemma mxE0 x y : x \+ y = Unit -> (x = Unit) * (y = Unit).
Proof. exact: GeneralizedMutex.join0E. Qed.

(* a form of cancelativity, more useful than the usual form *)
Lemma cancelMx t1 t2 x : (mx t1 \+ x = mx t2) <-> (t1 = t2) * (x = Unit).
Proof. by case: x=>[||x] //=; split=>//; case=>->. Qed.

Lemma cancelxM t1 t2 x : (x \+ mx t1 = mx t2) <-> (t1 = t2) * (x = Unit).
Proof. by rewrite joinC cancelMx. Qed.

Lemma mxMx t x : valid (mx t \+ x) -> x = Unit.
Proof. by case: x. Qed.

Lemma mxxM t x : valid (x \+ mx t) -> x = Unit.
Proof. by rewrite joinC=>/mxMx. Qed.

Lemma mxxyM t x y : valid (x \+ (y \+ mx t)) -> x \+ y = Unit.
Proof. by rewrite joinA=>/mxxM. Qed.

Lemma mxMxy t x y : valid (mx t \+ x \+ y) -> x \+ y = Unit.
Proof. by rewrite -joinA=>/mxMx. Qed.

Lemma mxxMy t x y : valid (x \+ (mx t \+ y)) -> x \+ y = Unit.
Proof. by rewrite joinCA=>/mxMx. Qed.

Lemma mxyMx t x y : valid (y \+ mx t \+ x) -> y \+ x = Unit.
Proof. by rewrite joinAC=>/mxMx. Qed.

(* inversion principle for join *)
(* own and mx are prime elements, and unit does not factor *)
Variant mxjoin_spec (x y : mutex T) : mutex T -> mutex T -> mutex T -> Type :=
| bothnown of x = nown & y = nown : mxjoin_spec x y nown nown nown
| leftmx t of x = mx t & y = nown : mxjoin_spec x y (mx t) (mx t) nown
| rightmx t of x = nown & y = mx t : mxjoin_spec x y (mx t) nown (mx t)
| invalid of ~~ valid (x \+ y) : mxjoin_spec x y undef x y.

Lemma mxPJ x y : mxjoin_spec x y (x \+ y) x y.
Proof. by case: x y=>[||x][||y]; constructor. Qed.

End MutexLemmas.

Prenex Implicits mxMx mxxM mxxyM mxMxy mxxMy mxyMx.

Section OwnMutex.
Variables T : Type.
Implicit Types x y : mtx T.

Lemma mxOx x : valid (own \+ x) -> x = Unit.
Proof. by apply: mxMx. Qed.

Lemma mxxO x : valid (x \+ own) -> x = Unit.
Proof. by apply: mxxM. Qed.

Lemma mxxyO x y : valid (x \+ (y \+ own)) -> x \+ y = Unit.
Proof. by apply: mxxyM. Qed.

Lemma mxOxy x y : valid (own \+ x \+ y) -> x \+ y = Unit.
Proof. by apply: mxMxy. Qed.

Lemma mxxOy x y : valid (x \+ (own \+ y)) -> x \+ y = Unit.
Proof. by apply: mxxMy. Qed.

Lemma mxyOx x y : valid (y \+ own \+ x) -> y \+ x = Unit.
Proof. by apply: mxyMx. Qed.
End OwnMutex.

Prenex Implicits  mxOx mxxO mxxyO mxOxy mxxOy mxyOx.

(* specific lemmas for binary mutexes *)

Lemma mxON (x : mtx2) : valid x -> x != own -> x = nown.
Proof. by case: x=>//; case. Qed.

Lemma mxNN (x : mtx2) : valid x -> x != nown -> x = own.
Proof. by case: x=>//; case=>//; case. Qed.

(* the next batch of lemmas is for automatic simplification *)

Section MutexRewriting.
Variable T : eqType.
Implicit Types (t : T) (x : mutex T).

Lemma mxE1 :  (((@mx_undef T == nown) = false) *
               ((@nown T == mx_undef) = false)).
Proof. by []. Qed.

Lemma mxE2 t : (((mx t == nown) = false) *
                ((nown == mx t) = false)) *
               (((mx t == mx_undef) = false) *
                ((mx_undef == mx t) = false)).
Proof. by []. Qed.

Lemma mxE3 t x : ((((mx t \+ x == nown) = false) *
                   ((x \+ mx t == nown) = false)) *
                  (((nown == mx t \+ x) = false) *
                   ((nown == x \+ mx t) = false))).
Proof. by case: x. Qed.

Lemma mxE5 t1 t2 x :
       (((mx t1 \+ x == mx t2) = (t1 == t2) && (x == Unit)) *
        ((x \+ mx t1 == mx t2) = (t1 == t2) && (x == Unit))) *
       (((mx t1 == mx t2 \+ x) = (t1 == t2) && (x == Unit)) *
        ((mx t1 == x \+ mx t2) = (t1 == t2) && (x == Unit))).
Proof.
have L : forall t1 t2 x, (mx t1 \+ x == mx t2) = (t1 == t2) && (x == Unit).
- by move=>*; apply/eqP/andP=>[/cancelMx[]->->|[]/eqP->/eqP->].
by do !split=>//; rewrite ?L // eq_sym L eq_sym.
Qed.

Lemma mx_valid t : valid (mx t).
Proof. by []. Qed.

Lemma mx_injE t1 t2 : (mx t1 == mx t2) = (t1 == t2).
Proof. by []. Qed.

Definition mxE := ((((mxE1, mxE2), (mxE3)), ((mxE5, mx_injE),
                   (mx_valid))),
                   (* plus a bunch of safe simplifications *)
                   (((unitL, unitR), (valid_unit, eq_refl)),
                   ((valid_undef, undef_join), join_undef))).

End MutexRewriting.

(* function mapping all mx's to own *)
Definition mxown T (x : mutex T) : mtx2 :=
  match x with
    mx_undef => mx_undef
  | nown => nown
  | _ => own
  end.

(* this is a morphism under full domain *)
Lemma mxown_morph_ax T : morph_axiom (@sepT _) (@mxown T).
Proof. by split=>[|x y] //; case: x=>//; case: y. Qed.

Canonical mxown_pmorph T := Morphism' (@mxown T) (mxown_morph_ax T).

(* the key inversion property is the following *)
(* we could use simple case analysis in practice *)
(* but this appears often, so we might just as well have a lemma for it *)
Lemma mxownP T (x : mutex T) : mxown x = nown -> x = nown.
Proof. by case: x. Qed.

Definition mxundef T (x : mtx T) : mtx2 :=
  match x with
  | nown => nown
  | mx None => own
  | _ => undef
  end.

Definition sep_mxundef T (x y : mtx T) :=
  if x \+ y is (nown | mx None) then true else false.

Lemma mxundef_seprel_ax T : seprel_axiom (@sep_mxundef T).
Proof. by split=>//; case=>[||x] // [||y] // [||[]] //=; case: y. Qed.

Canonical mxundef_seprel T :=
  Eval hnf in seprel (@sep_mxundef T) (mxundef_seprel_ax T).

Lemma mxundef_ax T : morph_axiom (@sep_mxundef T) (@mxundef T).
Proof. by split=>//; case=>[||x] // [||[]] //; case: x. Qed.

Canonical mxundef_pmorph T := Morphism' (@mxundef T) (mxundef_ax T).

Prenex Implicits mxown mxundef.

(* inversion principle for mxundef *)
Variant mxundef_spec T (x : mtx T) : mtx2 -> mtx T -> Type :=
| mxundef_nown of x = nown : mxundef_spec x nown nown
| mxundef_own of x = own : mxundef_spec x own own
| mxundef_undef of x = undef : mxundef_spec x undef undef
| mxundef_mx t of x = auth t : mxundef_spec x undef (auth t).

Lemma mxundefP T (x : mtx T) : mxundef_spec x (mxundef x) x.
Proof. by case: x=>[||[t|]]; constructor. Qed.

(* nats into mtx *)
(* notice this is not a morphism *)
Definition nxown n : mtx2 := if n is 0 then nown else own.

Variant nxown_spec n : mtx2 -> Type :=
| nxZ of n = 0 : nxown_spec n nown
| nxS m of n = m.+1 : nxown_spec n own.

Lemma nxP n : nxown_spec n (nxown n).
Proof. by case: n=>[|n]; [apply: nxZ | apply: (@nxS _ n)]. Qed.

Variant nxownjoin_spec n1 n2 : mtx2 -> Type :=
| nxjZ of n1 = 0 & n2 = 0 : nxownjoin_spec n1 n2 nown
| nxjS m of n1 + n2 = m.+1 : nxownjoin_spec n1 n2 own.

Lemma nxPJ n1 n2 : nxownjoin_spec n1 n2 (nxown (n1 \+ n2)).
Proof.
case: n1 n2=>[|n1][|n2] /=.
- by constructor.
- by apply: (@nxjS _ _ n2).
- by apply: (@nxjS _ _ n1); rewrite addn0 //.
apply: (@nxjS _ _ (n1 + n2).+1).
by rewrite addSn addnS.
Qed.

(**********************************)
(* Morphisms on locking histories *)
(**********************************)

(* Morphism on locking histories that provides mutual exclusion: *)
(* when one thread has locked, the other can't proceed. *)
(* Because the morphism just looks into the last history entry *)
(* we call it *omega*, or omg for short. *)

Section OmegaMorph.
Let U := nat_mapPCM (bool * bool).

Definition omg_s := fun x y : U =>
  [&& last_atval false x ==> (last_key y < last_key x) &
      last_atval false y ==> (last_key x < last_key y)].

Lemma omg_sep_ax : seprel_axiom omg_s.
Proof.
rewrite /omg_s; split=>[|x y|x y|x y z] /=; first by rewrite lastatval0.
- by rewrite andbC.
- move=>V /andP [H _]; rewrite lastkey0 lastatval0.
  by case: (x in x ==> _) H=>// /(leq_trans _) ->.
move=>V /andP [X Y] /andP [].
rewrite !lastkeyUn !lastatvalUn !(validLE3 V).
rewrite {1 2}maxnC {1 2}/maxn gtn_max leq_max /=.
case: (ltngtP (last_key x) (last_key y)) X Y=>H X Y Kx Kz;
 rewrite ?H ?X ?(negbTE Y) fun_if if_arg ?implybT ?Kx Kz if_same //= ?andbT.
by case: (x in x ==> _) Kz=>// /(ltn_trans H) ->.
Qed.

Canonical omg_seprel := Eval hnf in seprel omg_s omg_sep_ax.

Definition omg (x : U) : mtx2 := if last_atval false x then own else nown.

Lemma omg_morph_ax : morph_axiom omg_seprel omg.
Proof.
rewrite /omg; split=>[|x y V /andP [X Y]]; first by rewrite lastatval0.
rewrite lastatvalUn V; case: ltngtP X Y=>H X Y;
by rewrite ?(negbTE X) ?(negbTE Y) //; case: ifP.
Qed.

Canonical omg_morph := Morphism' omg omg_morph_ax.

(* transfer lemmas *)

Lemma omgPos (V : pcm) (v : V) (ht : V -> natmap (bool * bool)) :
        last_atval false (ht v) = (omg (ht v) == own).
Proof. by rewrite /omg /=; case: ifP. Qed.

Lemma omgPosMorph (V : pcm) (v1 v2 : V) (D : sep_rel V) (ht : @morphism V U D):
        valid (v1 \+ v2) -> 'preim ht omg_s v1 v2 ->
        last_atval false (ht v1 \+ ht v2) = (omg (ht v1) \+ omg (ht v2) == own).
Proof.
move=>W /andP [G] /andP []; rewrite /omg /= in G *.
rewrite lastatvalUn (pfVf ht W G); case: ltngtP=>H H1 H2;
by rewrite ?(negbTE H1) ?(negbTE H2) //; case: ifP.
Qed.

Lemma omgNeg (V : pcm) (v : V) (ht : V -> natmap (bool * bool)) :
       ~~ last_atval false (ht v) = (omg (ht v) == nown).
Proof. by rewrite /omg /=; case: ifP. Qed.

Lemma omgNegMorph (V : pcm) (v1 v2 : V) (D : sep_rel V) (ht : @morphism V U D) :
         valid (v1 \+ v2) ->'preim ht omg_s v1 v2 ->
         ~~ last_atval false (ht v1 \+ ht v2) = (omg (ht v1) \+ omg (ht v2) == nown).
Proof.
move=>W /andP [G] /andP []; rewrite /= /omg in G *.
rewrite lastatvalUn (pfVf ht W G); case: ltngtP=>H H1 H2;
by rewrite ?(negbTE H1) ?(negbTE H2) //; case: ifP.
Qed.

Lemma omgidPos (v : U) :
        last_atval false v = (omg v == own).
Proof. by rewrite (omgPos _ id). Qed.

Lemma omgidPosMorph (v1 v2 : U) :
        valid (v1 \+ v2) -> omg_s v1 v2 ->
        last_atval false (v1 \+ v2) = (omg v1 \+ omg v2 == own).
Proof. by move=> W S; rewrite (@omgPosMorph _ _ _ _ (id_morph _)). Qed.

Lemma omgidNeg (v : U) :
        ~~ last_atval false v = (omg v == nown).
Proof. by rewrite (omgNeg _ id). Qed.

Lemma omgidNegMorph (v1 v2 : U) :
        valid (v1 \+ v2) -> omg_s v1 v2 ->
         ~~last_atval false (v1 \+ v2) = (omg v1 \+ omg v2 == nown).
Proof. by move=>W S; rewrite (@omgNegMorph _ _ _ _ (id_morph _)). Qed.

Definition omgP := ((omgidNegMorph, omgidPosMorph, omgPosMorph, omgNegMorph), (omgidPos, omgidNeg, omgPos, omgNeg)).

Canonical omg_seprel.
Canonical omg_morph.

Lemma omg_fresh_val (V : pcm) (v1 v2 : V) (D : sep_rel V) (ht : @morphism V U D) :
      valid (v1 \+ v2) ->
      D v1 v2 ->
      (omg (fresh (ht v1 \+ ht v2) \-> (false, true) \+ ht v1) = own) *
      (omg (fresh (ht v1 \+ ht v2) \-> (true, false) \+ ht v1) = nown) *
      (omg (fresh (ht v1 \+ ht v2) \-> (false, true) \+ ht v2) = own) *
      (omg (fresh (ht v1 \+ ht v2) \-> (true, false) \+ ht v2) = nown).
Proof.
move=>A O; have Vh : valid (ht v1 \+ ht v2).
- by move/pfV2: O; move/(_ _ ht A).
by rewrite /omg !lastatval_freshUn.
Qed.

Lemma omg_fresh_sep (V : pcm) (v1 v2 : V) (D : sep_rel V) (ht : @morphism V U D) op :
        valid (v1 \+ v2) ->
        D v1 v2 ->
        (omg (ht v2) = nown ->
          omg_s (fresh (ht v1 \+ ht v2) \-> op \+ ht v1) (ht v2)) *
        (omg (ht v1) = nown ->
          omg_s (ht v1) (fresh (ht v1 \+ ht v2) \-> op \+ ht v2)).
Proof.
move=>A O; have Vh : valid (ht v1 \+ ht v2).
- by move/pfV2: O; move/(_ _ ht A).
rewrite /omg_s lastatval_freshUn // lastkey_freshUn //.
split=>N; first by rewrite omgP N /fresh lastkeyUn Vh ltnS leq_maxr implybT.
by rewrite omgP N lastkey_freshUn //= ltnS lastkeyUn Vh leq_maxl implybT.
Qed.

Definition omg_fresh := (omg_fresh_val, omg_fresh_sep).

Lemma omg_eta (h : natmap (bool * bool)):
        valid h -> omg h = own ->
        exists h' v, [/\ h' = free h (last_key h),
          h = last_key h \-> (v, true) \+ h',
          last_key h != 0,
          last_key h \in dom h,
          last_key h \notin dom h' &
          last_key h' < last_key h].
Proof.
rewrite /omg; case: ifP=>// N V _; set k := last_key h.
have D : k \in dom h.
- rewrite /last_atval /atval /oapp in N.
  by case: dom_find N=>[->//|].
have K : k != 0 by apply: dom_cond D.
case: (um_eta D); case=>v1 v2 [Ef Eh].
set h' := free h k in Eh *; set q := k \-> (v1, true).
have Nd : k \notin dom h'.
- rewrite Eh in V; case: validUn V=>// _ _ X _; apply: X.
  by rewrite domPt inE /= K eq_refl.
exists h', v1; split=>//.
- by rewrite /last_atval /atval Ef /= in N; rewrite -N.
have: last_key h' <= k.
- by rewrite /k Eh; apply: lastkeyUnf; rewrite -Eh.
rewrite leq_eqVlt; case/orP=>// /eqP E.
rewrite -E in Nd; apply: contraR Nd=>/= _.
by apply: (dom_lastkeyE (a:=0)); rewrite E; case: (k) K.
Qed.

(* specialize to alternating histories *)
Lemma omg_eta_all (h : natmap (bool * bool)) :
        valid h -> omg h = own -> um_all (fun k v => v.2 = ~~ v.1) h ->
        exists h', [/\ h' = free h (last_key h),
          h = last_key h \-> (false, true) \+ h',
          last_key h != 0,
          last_key h \in dom h,
          last_key h \notin dom h' &
          last_key h' < last_key h].
Proof.
move=>V H A; case: (omg_eta V H)=>h' [v][H1 H2 H3 H4 H5 H6].
exists h'; split=>//; rewrite H2 in V A; case: (umallPtUnE V A)=>/=.
by case: v {A} V H2.
Qed.

Lemma omg_lastkey x y :
        (omg x = own -> valid (x \+ y) -> omg_s x y ->
           last_key (x \+ y) = last_key x) *
        (omg y = own -> valid (x \+ y) -> omg_s x y ->
           last_key (x \+ y) = last_key y).
Proof.
rewrite /omg_s /omg; split=>L V S; case: ifP L=>L // _;
rewrite L /= in S; rewrite lastkeyUn V; case/andP: S=>S1 S2.
 by rewrite maxnC /maxn S1.
by rewrite /maxn S2.
Qed.

End OmegaMorph.


Add LoadPath "somePath".

Require Export rel_cons.

(*----------genBES----------*)

Inductive booleanEquation := bEqn : propVar -> propForm -> booleanEquation.

Record block:=makeBlock{
  theBlock:> list booleanEquation;
  blockType:bool;
  non_empty: exists beqn:booleanEquation, In beqn theBlock (*blocks are non-empty*)
}.

Fixpoint alternating_list_block (theList:list block):Prop:=
match theList with
| nil => true
| b1::l => match l with
           | nil => true
           | b2::l' => (eqb (blockType b1) (negb (blockType b2))) /\ alternating_list_block l
           end
end.

Record genBES := make_genBES {
  the_genBES:> list block;
  block_alternates: alternating_list_block the_genBES
}.

Fixpoint bnd_block (E:list booleanEquation)(x:propVar):Prop:=
match E with
| nil => False
| cons (bEqn y _) E' => x=y \/ bnd_block E' x
end.

Fixpoint bnd (E:list block)(x:propVar) : Prop :=
match E with
| nil => False
| cons bl E' => bnd_block bl x \/ bnd E' x
end.

Fixpoint bnd_cnt_block (bl:list booleanEquation)(x:propVar): nat :=
match bl with
| nil => 0
| bEqn y _ :: bl' => if (beq_nat x y) then S(bnd_cnt_block bl' x) else bnd_cnt_block bl' x
end.

Fixpoint bnd_cnt (E:list block)(x:propVar) : nat :=
match E with
| nil => 0
| cons bl E' => bnd_cnt_block bl x + bnd_cnt E' x
end.

Fixpoint occ_block (E:list booleanEquation)(x:propVar) : Prop :=
match E with
| nil => False
| cons (bEqn _ f) E' => (uses f x) \/ (occ_block E' x)
end.

Fixpoint occ (E:list block)(x:propVar):Prop:=
match E with
| nil => False
| cons bl E' => occ_block bl x \/ occ E' x
end.


Require Import core.utils.CpdtTactics.

Definition isNone (A: Type) (e : option A) : bool :=
 match e with
  | None => true
  | Some a => false
 end.

Lemma option_res_dec :
   forall {A B: Type} (f: A -> option B),
      forall a: A, f a <> None <->
      (exists (b: B),
          f a = Some b).
Proof.
  intros.
  split.
  - destruct (f a) as [ fa | ].
    -- exists fa. reflexivity.
    -- congruence.
  - intro.
    crush.
Qed.

Theorem None_is_not_non_None :
  forall {T : Type} (x : option T), not (x <> None) -> x = None.
Proof.
  intros. destruct x.
  - destruct H. discriminate.
  - reflexivity.
Qed.


Require Import TLC.LibTactics.
Require Import ZArith.
Open Scope Z_scope.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Require Import Psatz. (* nia *)
Require Import Big.
Require Import TLC.LibLogic.
Require Import TLC.LibWf.

(* A small ad-hoc library of iterated big sums *)

Open Scope list_scope.

Fixpoint seqZ (start : Z) (len : nat) : list Z :=
  match len with
  | 0%nat => nil
  | S len => start :: seqZ (start + 1) len
  end.

Lemma seqZ_S_r : forall len start,
  seqZ start (S len) = seqZ start len ++ (start + Z.of_nat len) :: nil.
Proof.
  induction len.
  { intros. cbn. rewrite~ Z.add_0_r. }
  { intros. cbn. f_equal. cbn in IHlen. rewrite IHlen.
    f_equal. f_equal. lia. }
Qed.

Definition interval (lo hi : Z) : list Z :=
  seqZ lo (Z.to_nat (hi - lo)).

Lemma Z_to_nat_pos_inv : forall x n,
  (0 < n)%nat ->
  Z.to_nat x = n ->
  0 < x.
Proof. intros. destruct x; cbn in *; lia. Qed.

Lemma Z_to_nat_zero_inv : forall x,
  Z.to_nat x = 0%nat ->
  x <= 0.
Proof. intros. destruct x; cbn in *; lia. Qed.

Lemma interval_empty : forall lo hi,
  hi <= lo ->
  interval lo hi = nil.
Proof.
  intros. unfold interval.
  assert (Z.to_nat (hi - lo) = 0%nat) as ->.
  { apply LibInt.to_nat_neg. rewrite LibInt.le_zarith. lia. }
  reflexivity.
Qed.

Lemma interval_cons_l : forall lo hi,
  lo < hi ->
  interval lo hi = lo :: interval (lo + 1) hi.
Proof.
  intros. unfold interval.
  gen_eq d: (Z.to_nat (hi - lo)). intro Hd. destruct d.
  { zify. rewrite Z2Nat.id in *; lia. }
  { symmetry in Hd. forwards~: Z_to_nat_pos_inv Hd. lia.
    cbn. f_equal. f_equal. zify. rewrite Z2Nat.id in *; lia. }
Qed.

Lemma interval_cons_r' : forall lo hi,
  lo <= hi ->
  interval lo (hi + 1) = interval lo hi ++ hi :: nil.
Proof.
  intros. unfold interval.
  gen_eq d: (Z.to_nat (hi - lo)). intro Hd. symmetry in Hd. destruct d.
  { apply Z_to_nat_zero_inv in Hd. cbn.
    assert (hi + 1 - lo = 1) as -> by lia. cbv. f_equal. lia. }
  { set (d' := S d) in *.
    assert (Z.to_nat (hi + 1 - lo) = S d') as ->.
    { zify. rewrite Z2Nat.id in *; lia. }
    rewrite seqZ_S_r. f_equal. f_equal. zify. rewrite Z2Nat.id in *; lia. }
Qed.

Lemma interval_cons_r : forall lo hi,
  lo < hi ->
  interval lo hi = interval lo (hi - 1) ++ (hi - 1) :: nil.
Proof.
  intros. assert (hi = (hi - 1) + 1) as -> by lia.
  rewrite interval_cons_r'. 2: lia. repeat f_equal; lia.
Qed.

Lemma interval_destruct_l : forall lo hi,
  (hi <= lo /\ interval lo hi = nil) \/
  (lo < hi /\ interval lo hi = lo :: interval (lo + 1) hi).
Proof.
  intros. tests~: (hi <= lo).
  { left. splits~. rewrite~ interval_empty. }
  { right. splits~. lia. rewrite~ interval_cons_l. lia. }
Qed.

Lemma interval_destruct_r : forall lo hi,
  (hi <= lo /\ interval lo hi = nil) \/
  (lo < hi /\ interval lo hi = interval lo (hi - 1) ++ (hi - 1) :: nil).
Proof.
  intros. tests~: (hi <= lo).
  { left. splits~. rewrite~ interval_empty. }
  { right. splits~. lia. rewrite~ interval_cons_r. lia. }
Qed.

Ltac interval_case_l lo hi :=
  let H := fresh in
  destruct (interval_destruct_l lo hi) as [[H ->]|[H ->]]; revert H.
Ltac interval_case_r lo hi :=
  let H := fresh in
  destruct (interval_destruct_r lo hi) as [[H ->]|[H ->]]; revert H.

Ltac downto :=
  unfold downto; rewrite ?LibInt.le_zarith, ?LibInt.lt_zarith; try lia.
Ltac upto :=
  unfold upto; rewrite ?LibInt.le_zarith, ?LibInt.lt_zarith; try lia.

Lemma interval_app : forall lo mid hi,
  lo <= mid ->
  mid <= hi ->
  interval lo mid ++ interval mid hi = interval lo hi.
Proof.
  intros lo mid. induction_wf: (upto mid) lo. intros.
  interval_case_l lo mid.
  { intros. rewrite List.app_nil_l. assert (mid = lo) as -> by lia. auto. }
  { intros. rewrite <-List.app_comm_cons, IH; auto; try lia; try upto.
    rewrite~ <-interval_cons_l. lia. }
Qed.

Lemma in_interval_lo :
  forall x lo hi,
  List.In x (interval lo hi) ->
  lo <= x.
Proof.
  intros *. induction_wf: (downto lo) hi.
  interval_case_r lo hi.
  { cbn. tauto. }
  { rewrite List.in_app_iff. cbn. intros ? [?|[?|?]]; try tauto.
    { applys~ IH (hi - 1). downto. } { lia. } }
Qed.

Lemma in_interval_hi :
  forall x lo hi,
  List.In x (interval lo hi) ->
  x < hi.
Proof.
  intros *. induction_wf: (upto hi) lo.
  interval_case_l lo hi.
  { cbn. tauto. }
  { cbn. intros ? [?|?]. lia. applys~ IH (lo + 1). upto. }
Qed.

Lemma big_const_Z :
  forall lo hi c,
  lo <= hi ->
  \big[Z.add]_(_ <- interval lo hi) c = (hi - lo) * c.
Proof.
  intros *. induction_wf: (upto hi) lo.
  interval_case_l lo hi.
  { cbn. nia. }
  { cbn. unfold Big.big in IH. cbn in IH. intros.
    rewrite IH. nia. upto. lia. }
Qed.

Lemma big_zero_Z :
  forall lo hi,
  \big[Z.add]_(_ <- interval lo hi) 0 = 0.
Proof.
  intros *. induction_wf: (upto hi) lo.
  interval_case_l lo hi.
  { cbn. nia. }
  { cbn. unfold Big.big in IH. cbn in IH. intros. rewrite~ IH. upto. }
Qed.

Lemma big_nonneg_Z :
  forall lo hi (f : Z -> Z),
  (forall x, lo <= x -> x < hi -> 0 <= f x) ->
  0 <= \big[Z.add]_(i <- interval lo hi) f i.
Proof.
  intros.
  rewrite <-big_covariant with
    (R := Z.le)
    (f := fun _ => 0);
  try typeclass.
  { rewrite big_zero_Z. lia. }
  { introv HIn. forwards~: in_interval_lo HIn. forwards~: in_interval_hi HIn. }
Qed.

Definition cumul (lo hi : Z) (f : Z -> Z) : Z :=
  \big[Z.add]_(i <- interval lo hi) f i.

Lemma cumulP :
  forall lo hi (f : Z -> Z),
  cumul lo hi f = \big[Z.add]_(i <- interval lo hi) f i.
Proof. reflexivity. Qed.

Lemma cumul_const : forall lo hi c,
  lo <= hi ->
  cumul lo hi (fun _ => c) = (hi - lo) * c.
Proof. apply big_const_Z. Qed.

Lemma cumul_const' : forall lo hi c,
  cumul lo hi (fun _ => c) = (Z.max 0 (hi - lo)) * c.
Proof.
  intros. tests~: (lo <= hi). rewrite~ cumul_const; nia.
  unfold cumul; rewrite~ interval_empty; cbn. nia. lia.
Qed.

Lemma cumul_nonneg : forall lo hi (f: Z -> Z),
  (forall x, lo <= x -> x < hi -> 0 <= f x) ->
  0 <= cumul lo hi f.
Proof.
  intros. rewrite cumulP, <-big_nonneg_Z; auto with zarith.
Qed.

Lemma cumul_split (k : Z) : forall lo hi (f : Z -> Z),
  lo <= k ->
  k <= hi ->
  cumul lo hi f = cumul lo k f + cumul k hi f.
Proof.
  intros. unfold cumul.
  rewrite~ <-(@interval_app lo k hi). rewrite List.map_app, big_app.
  auto. typeclass.
Qed.

Arguments cumul_split k [lo] [hi] f _ _.

Lemma cumul_minus_one : forall f lo hi,
  lo <= hi ->
  cumul lo hi f = (hi - lo) + cumul lo hi (fun x => f x - 1).
Proof.
  intros *. induction_wf: (upto hi) lo.
  unfold cumul. interval_case_l lo hi.
  { intros. cbn. lia. }
  { intros. cbn. unfold cumul, Big.big in IH. rewrite IH.
    2: upto. 2: lia. cbn. lia. }
Qed.

Lemma cumul_cons_l : forall lo hi (f : Z -> Z),
  lo < hi ->
  cumul lo hi f = f lo + cumul (lo + 1) hi f.
Proof. intros. unfold cumul. rewrite~ interval_cons_l. Qed.

Lemma cumul_cons_r : forall lo hi (f : Z -> Z),
  lo < hi ->
  cumul lo hi f = cumul lo (hi - 1) f + f (hi - 1).
Proof.
  intros. unfold cumul. rewrite~ interval_cons_r.
  rewrite~ List.map_app. cbn. rewrite big_app. cbn.
  rewrite Z.add_0_r. reflexivity. typeclass.
Qed.

Lemma cumul_triangle : forall lo hi (f : Z -> Z),
  Z.abs (cumul lo hi f) <= cumul lo hi (fun x => Z.abs (f x)).
Proof.
  intros *. induction_wf: (upto hi) lo. unfold cumul. interval_case_l lo hi.
  { intros. cbn. lia. }
  { intros. cbn. unfold cumul, Big.big in IH. rewrite Z.abs_triangle, IH.
    2: upto. cbn. lia. }
Qed.


From Hammer Require Import Hammer.

Set Implicit Arguments.

Require Import Datatypes.
Require Export Logic.

Definition notT (A:Type) := A -> False.

Section identity_is_a_congruence.

Variables A B : Type.
Variable f : A -> B.

Variables x y z : A.

Lemma identity_sym : identity x y -> identity y x.
Proof. hammer_hook "Logic_Type" "Logic_Type.identity_sym".
destruct 1; trivial.
Defined.

Lemma identity_trans : identity x y -> identity y z -> identity x z.
Proof. hammer_hook "Logic_Type" "Logic_Type.identity_trans".
destruct 2; trivial.
Defined.

Lemma identity_congr : identity x y -> identity (f x) (f y).
Proof. hammer_hook "Logic_Type" "Logic_Type.identity_congr".
destruct 1; trivial.
Defined.

Lemma not_identity_sym : notT (identity x y) -> notT (identity y x).
Proof. hammer_hook "Logic_Type" "Logic_Type.not_identity_sym".
red; intros H H'; apply H; destruct H'; trivial.
Qed.

End identity_is_a_congruence.

Definition identity_ind_r :
forall (A:Type) (a:A) (P:A -> Prop), P a -> forall y:A, identity y a -> P y.
intros A x P H y H0; case identity_sym with (1 := H0); trivial.
Defined.

Definition identity_rec_r :
forall (A:Type) (a:A) (P:A -> Set), P a -> forall y:A, identity y a -> P y.
intros A x P H y H0; case identity_sym with (1 := H0); trivial.
Defined.

Definition identity_rect_r :
forall (A:Type) (a:A) (P:A -> Type), P a -> forall y:A, identity y a -> P y.
intros A x P H y H0; case identity_sym with (1 := H0); trivial.
Defined.

Hint Immediate identity_sym not_identity_sym: core.

Notation refl_id := identity_refl (compat "8.3").
Notation sym_id := identity_sym (compat "8.3").
Notation trans_id := identity_trans (compat "8.3").
Notation sym_not_id := not_identity_sym (compat "8.3").