(**************************************************************************
* TLC: A library for Coq                                                  *
* Executable operations for lists                                         *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
From TLC Require Import LibTactics LibReflect.
From TLC Require Export LibList.

(* ---------------------------------------------------------------------- *)
(* ** Autorewrite *)

Module RewListExec.

Tactic Notation "rew_list_exec" :=
  autorewrite with rew_list_exec.
Tactic Notation "rew_list_exec" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_list_exec).
  (* autorewrite with rew_list_exec in *. *)
Tactic Notation "rew_list_exec" "in" hyp(H) :=
  autorewrite with rew_list_exec in H.

End RewListExec.

(* ---------------------------------------------------------------------- *)
(* ** [is_nil] and [is_not_nil] *)

Definition is_nil A (l:list A) : bool :=
  match l with
  | nil => true
  | _ => false
  end.

Lemma is_nil_eq : forall A (l:list A),
  is_nil l = isTrue (l = nil).
Proof using. intros. destruct l; simpl; rew_bool_eq; auto_false. Qed.

Definition is_not_nil A (l:list A) : bool :=
  match l with
  | nil => false
  | _ => true
  end.

Lemma is_not_nil_eq : forall A (l:list A),
  is_not_nil l = isTrue (l <> nil).
Proof.
  intros. destruct l; simpl; rew_bool_eq; auto_false.
Qed.

#[global]
Hint Rewrite is_nil_eq is_not_nil_eq : rew_list_exec.

(* ---------------------------------------------------------------------- *)
(* ** [length] *)

Definition length : forall A, list A -> nat :=
  @List.length.

Lemma length_eq :
  length = LibList.length.
Proof using. extens ;=> A l. induction l; simpl; rew_list; auto. Qed.

#[global]
Hint Rewrite length_eq : rew_list_exec.

(* ---------------------------------------------------------------------- *)
(* ** [app] *)

Definition app : forall A, list A -> list A -> list A :=
  @List.app.

Lemma app_eq :
  app = LibList.app.
Proof using.
  extens ;=> A L1 L2. induction L1; simpl; rew_list; congruence.
Qed.

#[global]
Hint Rewrite app_eq : rew_list_exec.

(* ---------------------------------------------------------------------- *)
(* ** [rev] *)

Definition rev : forall A, list A -> list A :=
  @List.rev.

Lemma rev_eq : forall A, (* --LATER: why fails if A is not quantified here? *)
  @List.rev A = @LibList.rev A.
Proof using.
  extens ;=> L. induction L; simpl; rew_list. { auto. }
  { rewrite IHL. rewrite <- app_eq. unfold app. fequals. }
Qed.

#[global]
Hint Rewrite rev_eq : rew_list_exec.

(* ---------------------------------------------------------------------- *)
(* ** [fold_right] *)

Definition fold_right : forall A B, (B->A->A) -> A -> list B -> A :=
  @List.fold_right.

Lemma fold_right_eq : forall A B (f:B->A->A) (a:A) (l:list B),
  fold_right f a l = LibList.fold_right f a l.
Proof using. intros. induction l; simpl; rew_listx; fequals. Qed.

#[global]
Hint Rewrite fold_right_eq : rew_list_exec.

(* ---------------------------------------------------------------------- *)
(* ** [map] *)

Definition map : forall A B, (A->B) -> list A -> list B :=
  @List.map.

Lemma map_eq :
  map = LibList.map.
Proof using.
  extens ;=> A B f L. induction L; simpl; rew_listx; congruence.
Qed.

#[global]
Hint Rewrite map_eq : rew_list_exec.

(* ---------------------------------------------------------------------- *)
(* ** [combine] *)

Definition combine : forall A B, list A -> list B -> list (A*B) :=
  @List.combine.

Lemma combine_eq : forall A B (L1:list A) (L2:list B),
  LibList.length L1 = LibList.length L2 ->
  combine L1 L2 = LibList.combine L1 L2.
Proof using. (* --LATER: conduct proof using list2_ind *)
  introv E. gen L2.
  induction L1 as [|x1 L1']; intros; destruct L2 as [|x2 L2']; tryfalse.
  { auto. }
  { rew_list in E. rew_listx. simpl. fequals~. }
Qed.

#[global]
Hint Rewrite combine_eq : rew_list_exec.

(* ---------------------------------------------------------------------- *)
(* ** [mem] *)

Fixpoint mem A (cmp:A->A->bool) (x:A) (l:list A) : bool :=
  match l with
  | nil => false
  | y::l' => cmp x y || mem cmp x l'
  end.

Lemma mem_exec_eq : forall A (cmp:A->A->bool) x l,
  is_beq cmp ->
  mem cmp x l = isTrue (LibList.mem x l).
Proof using.
  introv M. induction l as [|y l']; simpl; rew_listx; rew_isTrue; fequals.
Qed.


From Undecidability.TM Require Import TM Code  ProgrammingTools.
From Undecidability.TM Require CodeTM.

Import Retracts.

Definition prefixInjective (sig: Type) (X: Type) (encode : X -> list sig) :=
  forall (x x' :X) t t', encode x ++ t = encode x' ++ t' -> x = x'.

Module ContainsEncoding.
  Section containsEncoding.
    Local Unset Implicit Arguments.

    Context {sig tau:Type} {X:Type}.
    Context (encode : X -> list sig) (f : sig -> tau).

    Definition Rel : pRel tau bool 1 :=
      fun tin '(yout, tout) =>
        match yout with
          true => exists (x:X),
                 tape_local tin[@Fin0] = map f (encode x) ++ right tout[@Fin0]
                 /\ tape_local_l tout[@Fin0] = map f (rev (encode x)) ++ left tin[@Fin0]
        | false => forall (x:X) t__R, tape_local tin[@Fin0] <> map f (encode x) ++ t__R
        end /\ exists k, tout[@Fin0] = nat_rect _ tin[@Fin0] (fun _ => @tape_move_right _) k .

    Definition Rel_legacy : pRel tau bool 1 :=
      fun tin '(yout, tout) =>
        match yout with
          true => exists (x:X) t__L t__R,
                 (exists x__hd x__tl, encode x = x__hd::x__tl /\  tin[@Fin0] = midtape t__L (f x__hd) (map f x__tl++t__R) )
                 /\ exists x__init x__last , encode x = x__init ++ [x__last] /\ tout[@Fin0] = midtape (map f (rev x__init)++ t__L) (f x__last) t__R
        | false => (forall t__L (x:X) t__R,
                      exists x__hd x__tl, map f (encode x) = x__hd::x__tl /\
                                 tin[@Fin0] <> midtape t__L x__hd (x__tl++t__R))
        end /\ exists k, tout[@Fin0] = nat_rect _ tin[@Fin0] (fun _ => @tape_move_right _) k .

    Lemma legacy_iff :
      (forall x, encode x <> [])
      -> forall t y, Rel t y <-> Rel_legacy t y.
    Proof.
      intros Hnil. unfold Rel, Rel_legacy. intros t [y t'].
      eapply Morphisms_Prop.and_iff_morphism_obligation_1. 2:easy.
      destruct y.
      -eapply Morphisms_Prop.ex_iff_morphism. intros x. specialize (Hnil x). destruct (encode x) eqn:Heqx. easy. clear Hnil.
       destruct (t[@Fin0]). 1-3:cbn;now firstorder congruence.
       cbn - [rev]. destruct rev eqn:Hr. length_not_eq in Hr.
       apply (f_equal (@rev _) )in Hr. autorewrite with list in Hr. setoid_rewrite Hr at 2. cbn.
       split.
       +intros [[= -> ->] Ht]. destruct (t'[@Fin0]). 1-3:now length_not_eq in Ht. inv Ht. repeat eexists. cbn. now autorewrite with list.
       +intros (?&?&(?&?&[= <- <-]&[= -> -> ->])&(?&?&Hrev%(f_equal (@rev _))&->)).
        cbn in *. autorewrite with list in *.  inv Hrev. intuition.
      -split;intros.
       +specialize (Hnil x). destruct encode eqn:Hx. easy. do 3 eexists. cbn. easy. intros H'. eapply (H x). now rewrite H',Hx.
       +specialize (Hnil x). destruct encode eqn:Hx. easy. destruct t[@Fin0]. 1-3:easy. cbn.
        edestruct H with (x:=x) as (?&?&H1&H2). rewrite Hx in H1. inv H1. intros [= -> ->]. eapply H2. f_equal.
    Qed.

    Lemma functional_true :
      (forall x, encode x <> []) ->
      prefixInjective (fun x => map f (encode x)) ->
      functional (fun t t' => Rel t (true,t')).
    Proof.
      hnf.
      intros Hnnil pInj t tr1 tr2 [H1 (k1&H1')] [H2 (k2&H2')].
      destruct H1 as (x1&H1&Hr1). destruct H2 as (x2&H2&Hr2). specialize (Hnnil x1).
      unfold tapes in *. destruct_vector. cbn in *. f_equal.
      rewrite H2 in H1.
      replace x2 with x1 in * by now specialize (pInj _ _ _ _ H1). clear x2. apply app_inv_head in H1.
      rewrite <- Hr2 in Hr1. destruct h;destruct h0. all:cbn in *. all:inv H1. all:inv Hr1. all:try reflexivity.
      all:destruct encode;[easy | ]. all:length_not_eq in Hr2.
    Qed.

    (* Depricated? never used? *)
    (*Definition Ter c: tRel tau 1 :=
      fun t k => exists l, length (tape_local t[@Fin0]) <= l
                   /\ (forall (x:X) t__R, tape_local t[@Fin0] = map f (encode x) ++ t__R -> l <= length (encode x))
                   /\ l * c + c <= k.*)
  End containsEncoding.
End ContainsEncoding.

(* MOVE *)
Lemma map_retract_prefix_inj X Y `{Retract X Y} (x:list X) xs y (ys: list Y):
  map Retr_f x ++ xs = map Retr_f y ++ ys -> { xs' & {ys' & x++xs' = y++ys' }}.
Proof.
  induction x in xs,y,ys|-*.
  1:{ cbn. intros ->. eexists _,[]. now autorewrite with list. }
  destruct y.
  1:{ cbn. intros <-. eexists [],_. now autorewrite with list. }
  cbn. intros [= ->%retract_f_injective (?&?&Heq)%IHx ].
  do 2 eexists _. rewrite Heq. easy.
Qed.

Arguments ContainsEncoding.Rel : simpl never.
From Undecidability.TM Require Import ProgrammingTools MoveToSymbol.
Module CheckTapeContains.
  Section fixx.
    Import CodeTM.
    Context {sig:Type} {tau:finType} {n:nat} {X:Type}.
    Context (cX : codable sig X) (I : Retract sig tau).

    Let Rel : pRel (tau ^+) bool 1 :=
      fun t '(b,t') => inhabited (reflect (exists x, tape_contains I t[@Fin0] x) b)
                    /\ (b = true -> t = t').

    Variable M_checkX : pTM (tau ^+) bool 1.

    Definition M : pTM (tau ^+) bool 1:=
      If (Relabel ReadChar (fun c => match Option.bind Retr_g c with Some (inl START) => true | _ => false end))
         (If (Move Rmove;;M_checkX)
             (Move Rmove;;
                   If (Relabel ReadChar (fun c => match Option.bind Retr_g c with Some (inl STOP) => true | _ => false end))
                   (Move Rmove;;
                         If (Relabel ReadChar (Option.apply (fun _ => false) true))
                         (Move Lmove;;Return (MoveToSymbol_L (fun x => match x with (inl START) => true | _ => false end) id) true)
                         (Return Nop false)
                   )
                   (Return Nop false)
             )
             (Return Nop false)
         )
         (Return Nop false)
    .

    Lemma Realise (Realises_M_checkX : M_checkX ⊨ ContainsEncoding.Rel (X:=X) encode Retr_f) (prefInj : prefixInjective cX)
        : M ⊨ Rel.
    Proof.
      Local Set Printing Depth 30.
      unfold M,Rel.
      eapply Realise_monotone.
      { TM_Correct. eassumption. }
      hnf;cbn. intros t0(y&tout) H. remember t0[@Fin0] as tin eqn:eqt0.
      destruct H as [H|H].
      2:{ destruct H as (?&(?&Hf&->&->)&(->&_&<-)).
          split. 2:easy. split. constructor. intros (x&?&Heq). setoid_rewrite Heq in Hf. now cbn in Hf. }
      destruct H as (?&(?&Hc&->&->)&H).
      destruct (t0[@Fin0]) as [ | | | t__L c t__R] eqn:eqt0';cbn in Hc. 1-3:now inv Hc. revert Hc. destruct c as [ [] | ]. 2-4:subst tin;easy.
      rewrite eqt0 at 1. intros _. destruct H as [H|H].
      2:{ destruct H as (?&(_&t1&Ht1&Ht2)&(->&_&<-)). split. 2:easy. split. constructor. subst tin.
          intros (x&?&[= -> ->]). hnf in Ht2. destruct Ht2 as [H _].
          eapply H. rewrite Ht1. cbn. rewrite tape_local_move_right'. rewrite map_map. reflexivity.
      }
      destruct H as (t2&(_&t1&Ht1&Henc)&_&t3&Ht3&H).
      hnf in Henc. rename t__R into t__R'. destruct Henc as [(x&Hxt1&Hxt2) _].
      erewrite Ht1, tape_local_move_right in Hxt1. 2:easy. subst t__R'.
      destruct H as [H|H].
      2:{ destruct H as (?&(?&Hc&->&->)&->&?&<-). split. 2:easy.
          split. constructor. intros (x'&?&Heq);revert Heq. rewrite eqt0 at 1. cbn. rewrite map_map. intros[= <- Heq].
          replace x' with x in *.
          2:{ eassert (H:=map_retract_prefix_inj (X:= sig) (Y:=tau ^+)). specialize H with (1:=Heq) as (?&?&Heq').
              now eapply prefInj in Heq'. }
          apply app_inv_head in Heq as Ht2'. rewrite Ht3 in Hc.
          destruct (t2[@Fin0]) as [ | | | ? ? []];cbn in Hc,Ht2'. all:inv Ht2'. all:easy.
      }
      destruct H as (_&(?&Hc&->&->)&(?&t4&Ht4&H)).
      destruct (t3[@Fin0]) as [ | | | t__L' c t__R];cbn in Hc. 1-3:now inv Hc. revert Hc. destruct c as [ [] | ]. 1,3,4:now subst tin. intros _.
      destruct t2[@Fin0];cbn in Ht4,Ht3.  1,3:easy. 1:{ destruct (cX x);cbn in *. now rewrite Ht1 in Hxt2. now length_not_eq in Hxt2. }
      cbn in Hxt2.
      revert Ht3. destruct l0;cbn. all:intros [= -> <- <-].
      cbn in Hxt2. cbn [right] in *.
      destruct H as [H|H].
      2:{ destruct H as (?&(?&Hc&->&->)&(->&_&<-)). split. 2:easy. split. constructor.
          intros (x'&?&Heq);revert Heq. rewrite eqt0 at 1. cbn. rewrite map_map. intros[= <- Heq].
          replace x' with x in *.
          2:{ eassert (H:=map_retract_prefix_inj (X:= sig) (Y:=tau ^+)). specialize H with (1:=Heq) as (?&?&Heq').
              now eapply prefInj in Heq'. }
          apply app_inv_head in Heq as [= ->]. now rewrite Ht4 in Hc. }
      destruct H as (_&(?&Hc&->&->)&(?&t5&Ht5&->&_&Hout)).
      destruct t__R.
      2:{ exfalso. rewrite Ht4 in Hc. now cbn in Hc. }
      cbn in Ht4. rewrite Ht4 in *. cbn in Hc. clear Hc. clear t4 Ht4. cbn in Ht5.
      rewrite Ht5 in Hout.  clear Ht5 t5 x0 x1.
      split. 2:intros _.
      -split. constructor. exists x. eexists. unfold Encode_map;cbn. unfold retract_inr_f in *. rewrite map_map.  exact eqt0.
      -rewrite Hxt2 in *.
       erewrite MoveToSymbol_L_correct with (x:=inl START) (str1:=inl STOP :: _) in Hout.
       4:{ cbn. rewrite Ht1;cbn. rewrite tape_left_move_right'. reflexivity. } 3:easy.
       2:{ cbn. intros ?. unfold retract_inr_f. intuition try now subst. now apply in_map_iff in H0 as (?&<-&?). }
       unfold tapes in t0,tout. destruct_vector. f_equal. cbn in Hout,eqt0'. rewrite Hout,eqt0'.
       f_equal.
       unfold retract_inr_f. autorewrite with list. unfold id. rewrite map_map , <- map_rev,rev_involutive. easy.
    Qed.

    Import Ring Arith.

    Lemma Terminates
      (Realises_M_checkX : M_checkX ⊨ ContainsEncoding.Rel (X:=X) encode Retr_f)
      {T__X} (Terminates_M_checkX : projT1 M_checkX ↓ T__X):
        projT1 M ↓ (fun t k => exists k', T__X ([|tape_move_right t[@Fin0]|]) k'
        /\ k' + 4 * S(| right t[@Fin0] |) + 19 <= k ).
    Proof.
      eapply TerminatesIn_monotone.
      { unfold M. TM_Correct. all:eassumption. }
      intros t k (k'&HT__X&?). infTer 3. shelve.
      cbn. intros tout b (?&Hb&->&->).
      destruct b. 2:now apply Nat.le_0_l.
      infTer 8. 1:{ intros ? _ Heq. unfold tapes in t,tout. destruct_vector;cbn in *.
                    rewrite <- Heq in HT__X. eassumption. }
      intros ? ? (_&t1&Ht&Hx). destruct b. 2:now apply Nat.le_0_l.
      infTer 4. intros t2 _ Ht2.
      infTer 4. intros ? b' (?&Hb'&->&->).
      destruct b'. 2:now apply Nat.le_0_l.
      infTer 4. intros t3 _ Ht3.
      infTer 4. intros ? b2 (?&Hb2&->&->). destruct b2.  2:now apply Nat.le_0_l.
      infTer 4. intros t4 _ ->.
      destruct (current t3[@Fin0]) eqn: Hc3;inv Hb2.
      destruct (current t2[@Fin0]) as [[[] | ]| ] eqn: Hc2 ;inv Hb'.
      erewrite Ht3,tape_move_right_left. 2:eassumption. rewrite Ht3 in Hc3.
      rewrite Ht2. hnf in Hx. destruct Hx as [(x&Ht1&Htout) _].
      (destruct (current _)  as [ [ [] | ] | ] eqn:Hct in *;inv Hb);[].
      rewrite Ht2 in Hc2,Hc3;cbn in Hc2.
      erewrite Ht,tape_left_move_right in Htout. 2:eassumption.
      destruct (tout[@Fin0]) as [ | ? [] | | ? ? [ | [] [] ] ] eqn:eq. all:cbn in Hc2,Hc3.
      all:revert Hc2. all:intros [= ->]. now length_not_eq in Htout. easy. 2:easy.
      cbn - [plus mult] in *.
      rewrite MoveToSymbol_L_steps_local with (sym:=inl START). 3:easy.
      2:{ cbn in *.  rewrite Htout. instantiate (2:=(_::_)). reflexivity. }
      repeat (cbn [length] in *;autorewrite with list in * ). cbn - [mult plus] in *.
      rewrite Ht in Ht1.
      destruct t[@Fin0] as [ | | | ? ? t__R] eqn:Ht'. all:inv Hct. cbn - [mult plus] in *.
      rewrite tape_local_move_right' in Ht1. subst t__R. autorewrite with list in *. cbn - [mult plus] in *.
      instantiate (1 := k - k' - 15). Lia.nia.
      Unshelve.
      ring_simplify. Lia.nia.
    Qed.

  End fixx.
End CheckTapeContains.


Generalizable All Variables.

(*******************************************************************************)
(* Chapter 9.8: Freyd's Adjoint Functor Theorem                                *)
(*******************************************************************************)


(*  DEC 2.0 language specification.
   Paolo Torrini
   Universite' de Lille - CRIStAL-CNRS
*)

Require Import List.

Require Import ModTypI1.
Require Import TypSpecI1.

Import ListNotations.

(** * DEC 2.0 language specification *)

(** Syntax definition *)

Module LangSpec (IdT: ModTyp) <: ModTyp.
Export IdT.

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

(** Generic effect record *)

Record XFun (T1 T2: VTyp) : Type := {
    inpT : Type := sVTyp T1 ;
    outT : Type := sVTyp T2 ;
    x_mod : inpT -> W -> prod outT W ;
    x_eval : inpT -> W -> outT :=
      fun input state => fst (x_mod input state) ;
    x_exec : inpT -> W -> W :=
      fun input state => snd (x_mod input state) ;
    x_name : Id ;
}.

(** Value expressions *)

(** - The internal type of values, parametrised by Gallina types *)

Inductive ValueI (T: VTyp) : Type := Cst (v: sVTyp T).

(** - The external type of values, hiding Gallina types *)

Definition Value : Type := sigT ValueI.

(** - Smart value constructor *)

Definition cst (T: VTyp) (v: sVTyp T) : Value :=
           @existT VTyp ValueI T (Cst T v).

(** - Extractors *)

(* Definition ValueI2T (T: VTyp) (v: ValueI T) : sVTyp T := *)
Definition sValueI (t: VTyp) (v: ValueI t) : sVTyp t :=
    match v with Cst _ x => x end.

(* Definition cstExt (v: Value) : cVTyp (projT1 v) := *)
Definition sValue (v: Value) : sVTyp (projT1 v) :=
    sValueI (projT1 v) (projT2 v).

Definition valueVTyp (v: Value) : VTyp := projT1 v.

Definition valueSTyp (v: Value) : Type :=  sVTyp (projT1 v).

(***********************************************************************)

Definition FCall : Type := Id * nat * FTyp.

Definition callName (c: FCall) : Id := fst (fst c).

Definition callFuel (c: FCall) : nat := snd (fst c).

Definition callFTyp (c: FCall) : FTyp := snd c.

(*********************************************************************)

(** - Value typing contexts *)

Definition valTC : Type := list (Id * VTyp).

(** - Function typing contexts *)

Definition funTC : Type := list (Id * FTyp).

(** - Value environments *)

Definition valEnv : Type := list (Id * Value).

(** - Local function environment *)

Definition lfEnv : Type := list (Id * Id).

(** - Function call typed environment *)

Definition tfcEnv : Type := list (Id * FCall).

(** - Bounded call environment *)

Definition fcEnv : Type := list (Id * (Id * nat)).

(*************************************************************************)

(** Program terms *)

(** Syntactic categories defined by mutual induction:
    expressions and parameters *)

Inductive Exp : (** - Expressions *)
       Type :=
         | Val (v: Value)
         | Var (x: Id)
         | BindN (e1: Exp) (e2: Exp)
         | BindS (x: Id) (mt: option VTyp) (e1: Exp) (e2: Exp)
         | BindMS (venv: valEnv) (e: Exp)
         | IfThenElse (e1: Exp) (e2: Exp) (e3: Exp)
         | Apply (x: Id) (ps: Prms) (e: Exp)
         | Call (x: Id) (ps: Prms)
         | Modify (t1 t2: VTyp)
                  (XF: XFun t1 t2) (e: Exp)
with Prms : (** - Parameters *)
   Type := PS (es: list Exp).

Scheme Exp_mut := Induction for Exp Sort Type
with Prms_mut := Induction for Prms Sort Type.

Inductive Fun : (** - Functions *)
  Type := FC (tenv: valTC) (v: Value) (e: Exp).

Definition funVTyp (f: Fun) : VTyp :=
  match f with (FC _ v _) => projT1 v end.

Definition funValTC (f: Fun) : valTC :=
  match f with (FC tenv _ _) => tenv end.

Definition funFTyp (f: Fun) : FTyp :=
  match f with (FC tenv v _) => FT (PT (map snd tenv)) (projT1 v) end.

Definition funTypLS (f: Fun) : list VTyp :=
  match f with (FC tenv _ _) => map snd tenv end.

Definition funArity (f: Fun) : nat :=
  match f with (FC tenv _ _) => length tenv end.

Definition funPTyp (f: Fun) : PTyp :=
  match f with (FC tenv _ _) => PT (map snd tenv) end.

Definition fun0Exp (f: Fun) : Value :=
  match f with (FC _ v _) => v end.

Definition funSExp (f: Fun) : Exp :=
  match f with (FC _ _ e) => e end.

(** Function environments *)

Definition funEnv : Type := Envr Id Fun.

(** Top-level programs *)

Definition Prog : Type := Exp * funEnv.

(** Auxiliary functions *)

(** - Conversion from typing contexts to type lists *)

Definition env2ptyp (m: valTC) : PTyp := PT (map snd m).

(** - Creation of value environments *)

Definition mkVEnv (tenv: valTC) (vs: list Value) : valEnv :=
     interleave (map fst tenv) vs.

(*************************************************************************)

(** Abbreviations *)

Definition NatCst (v: nat) : Value := cst Nat v.

Definition UnitCst (v: unit) : Value := cst Unit v.

Definition BoolCst (v: bool) : Value := cst Bool v.

Definition TrueV : Exp := Val (cst Bool true).

Definition FalseV : Exp := Val (cst Bool false).

Definition UnitV : Exp := Val (cst Unit tt).

Definition Skip : Exp := BindN UnitV UnitV.

Definition BindV (x: Id) (mt: option VTyp) (v: Value) : Exp :=
                     BindS x mt (Val v) (Var x).

Definition Return (x: Id) (mt: option VTyp) (e: Exp) : Exp :=
                     BindS x mt e (Var x).

Definition NoRet (e: Exp) : Exp := BindN e Skip.

Definition xf_read {t: VTyp} (f: W -> sVTyp t) (x: Id) : XFun Unit t := {|
   x_mod := fun _ x => (f x, x); x_name := x
|}.

Definition xf_write {t: VTyp} (f: sVTyp t -> W) (x: Id) : XFun t Unit := {|
   x_mod := fun x _ => (sValue (cst Unit tt), f x); x_name := x
|}.

Definition Read (t: VTyp) (f: W -> sVTyp t) (x: Id) : Exp :=
  Modify Unit t (xf_read f x) (Val (cst Unit tt)).

Definition Write (t: VTyp) (f: sVTyp t -> W) (e: Exp) (x: Id) : Exp :=
  Modify t Unit (xf_write f x) e.

End LangSpec.


(*Add LoadPath "/home/user/Downloads/archives/math-comp-mathcomp-1.7.0/".*)
(*Add mathcomp "/home/user/Downloads/archives/math-comp-mathcomp-1.7.0/mathcomp".*)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype seq.
From mathcomp Require Import ssrnat.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Definition SetVars  := nat.

Definition FuncSymb := nat.

Record FSV := {
 fs : FuncSymb;
 fsv : nat;
}.

Unset Elimination Schemes.
Inductive preterm :=
| Vari :> SetVars -> preterm
| Node : FSV -> list preterm -> preterm.
Set Elimination Schemes.

Section Ind.

Variable T : preterm -> Type.
Variable HVari : forall sv, T (Vari sv).
Variable HNode : forall fv ts,
foldr (fun t acc => T t * acc)%type unit ts -> T (Node fv ts).

Fixpoint preterm_rect (t : preterm) : T t :=
  match t with
  | Vari sv => HVari sv
  | Node fv ts =>
    let fix loop ts : foldr (fun t acc => T t * acc)%type unit ts :=
        match ts with
        | [::] => tt
        | t :: ts => (preterm_rect t, loop ts)
        end in
    HNode fv (loop ts)
  end.

End Ind.

Definition preterm_ind := preterm_rect.

Require Import Arith Omega.
From Equations Require Import Equations.
(*Derive Signature Subterm for preterm.*)

Fixpoint is_term (t : preterm) : bool :=
  match t with
  | Vari _ => true
  | Node fv ts => (fsv fv == length ts) && all is_term ts
  end.

Theorem thm0 fv (t:preterm) ts (H : is_term (Node fv (cons t ts))) : is_term t.
Proof. simpl in * |- *.
revert H.
move/andP.
intro H;destruct H;revert H0.
move/andP.
firstorder.
Abort.
Theorem thm0 fv(t:preterm)ts:forall (H : is_term (Node fv (cons t ts))), is_term t.
Proof.
by move/and3P => [X1 X2 X3].
(* destruct Q as [X1 X2 X3]; exact X2.*)
Defined.

Record term := Term { tval : preterm; irt : is_term tval }.

Section let_will_not_survive.
Let fu u  := let: ( m, n ) := u in m + n .
End let_will_not_survive.
Fail Check fu.

Canonical term_subType := [subType for tval].
(*
Print  term_subType.
Print  subType. *)
Definition term_args (t:preterm) : list term :=
  match  t with
  | Vari _     => [::]
  | Node fv ts => pmap insub ts
  end.

Section other.
Fixpoint minilemma (ts:list preterm) (H:all is_term ts) {struct ts}: list term.
Proof.
destruct ts.
exact []%list.
simpl in H.
revert H. move/andP => [H1 H2].
refine ( _ :: _)%list.
exact (@Term p H1).
exact (minilemma ts H2).
Defined.

Definition just_args (t:term) : list preterm.
Proof.
destruct t as [[A1|A2] B].
exact [::].
exact l.
Defined.

Definition allisterm (t:term) : all is_term (just_args t).
Proof.
destruct t.
destruct tval0; simpl in * |- *. exact irt0.
revert irt0; by move/andP => [H1 H2].
Defined.

Definition my_term_args (t:term) : list term.
Proof.
unshelve simple eapply minilemma.
exact (just_args t).
exact (allisterm t).
Defined.

Print FSV.
Print preterm.
Theorem lmma a b l p (J:is_term p)
(H:(is_term (Node (Build_FSV a b) l))) :
(is_term (Node (Build_FSV a (S b)) (p::l)%list)).
Proof.
simpl in * |- *.
revert H; move/andP => [H1 H2].
apply/and3P;split;trivial.
Defined.

Theorem amml a b l p (J:is_term p)
(H: is_term (Node (Build_FSV a (S b)) (p::l)%list)):
((is_term (Node (Build_FSV a b) l))).
Proof.
simpl in * |- *.
revert H; move/and3P => [H1 H2 H3].
apply/andP;split;trivial.
Defined.

Theorem lmma2 a b l p (J:is_term p)
(H:(is_term (Node (Build_FSV a b) l))) : { nfs | (is_term (Node nfs (p::l)%list)) }.
Proof.
unshelve eapply exist.
exact {| fs := a; fsv := S b |}.
simpl.
revert H; move/andP => [H1 H2].
apply/and3P;split;trivial.
Defined.

Print Assumptions lmma2.
(*Reset lmma2. !!
Fail Check lmma2. *)

Theorem and_elim a b : (a && b) -> a /\ b.
Proof.
intro H.  destruct (@andP a b). exact a0. inversion H.
Defined.

Lemma eq_bool_prop (D:eqType) (x y:D) : x==y -> x=y.
Proof. (by move/eqP). Defined.

Definition tta0 fv ts (Q:is_term (Node fv ts)) :
my_term_args (@Term (Node fv ts) Q)=@minilemma _ (allisterm (@Term (Node fv ts) Q)).
Proof. trivial. Defined.

Check just_args.
Fixpoint tta1 fv (ts:seq preterm) (Q:is_term (Node fv ts)) :
(just_args (@Term (Node fv ts) Q)) = ts.
Proof. destruct ts; simpl in * |- *; trivial. Defined.

Lemma UTQ C (a b:C) l1 l2 (H:a=b) (J:l1=l2) : a::l1 = b::l2.
Proof.
rewrite H.
rewrite J.
reflexivity.
Defined.

Lemma match_cons (A B:Prop) (a:A) (b:B)(C:Type) p (l:seq C) : (match conj a b with |conj H1 H2 => p::l end ) =
(match conj a b with |conj H1 H2 => p end)::(match conj a b with |conj H1 H2 => l end)
.
simpl.
destruct (conj a b);trivial.
Defined.

Fixpoint tta fv ts (Q:is_term (Node fv ts)) :
(map tval (my_term_args (@Term (Node fv ts) Q)))=ts.
(*Fixpoint tta fv ts (Q:is_term (Node fv ts)) :
let M := @Term (Node fv ts) Q in
(map tval (my_term_args M))=ts.*)
Proof.
unfold my_term_args.
unfold minilemma.
pose ( rew := @tta1 fv ts Q).
set (BBJ := (just_args {| tval := Node fv ts; irt := Q |})).
fold BBJ in rew.
change BBJ with ts.
destruct ts; simpl in * |- *; trivial.
Check elimTF andP match elimTF andP Q with
                            | conj _ H2 => H2
                            end .
pose (R := elimTF andP match elimTF andP Q with
                            | conj _ H2 => H2
                            end).
change (elimTF andP match elimTF andP Q with
                            | conj _ H2 => H2
                            end)  with R.
simpl in R.
destruct R eqn:w.

Check match_cons.
(**
pose (M:=@map_cons _ _ tval
(match elimTF andP match elimTF andP Q with
                            | conj _ H2 => H2
                            end with
          | conj H1 H2 =>
              {| tval := p; irt := H1 |} end)).
pose (S:= M
( match elimTF andP match elimTF andP Q with
                            | conj _ H2 => H2
                            end with
          | conj H1 H2 =>
(fix
                  minilemma (ts0 : seq preterm) (H : all is_term ts0) {struct
                            ts0} : seq term :=
                    match ts0 as l return (all is_term l -> seq term) with
                    | []%list => fun _ : true => []%list
                    | p0 :: ts1 =>
                        fun H0 : is_term p0 && all is_term ts1 =>
                        match elimTF andP H0 with
                        | conj H3 H4 =>
                            {| tval := p0; irt := H3 |} :: minilemma ts1 H4
                        end
                    end H) ts H2
   end)
).
simpl in S.
rewrite S. **)
Check @match_cons.
assert (BW:

[seq tval i
   | i <- match elimTF andP match elimTF andP Q with
                            | conj _ H2 => H2
                            end with
          | conj H1 H2 =>
              {| tval := p; irt := H1 |}
          end
          ::
          match elimTF andP match elimTF andP Q with
                            | conj _ H2 => H2
                            end with
          | conj H1 H2 =>  (fix
                  minilemma (ts0 : seq preterm) (H : all is_term ts0) {struct
                            ts0} : seq term :=
                    match ts0 as l return (all is_term l -> seq term) with
                    | []%list => fun _ : true => []%list
                    | p0 :: ts1 =>
                        fun H0 : is_term p0 && all is_term ts1 =>
                        match elimTF andP H0 with
                        | conj H3 H4 =>
                            {| tval := p0; irt := H3 |} :: minilemma ts1 H4
                        end
                    end H) ts H2
          end] = p :: ts
).
2 :  admit.
rewrite map_cons.
simpl.

apply UTQ.
destruct (elimTF andP match elimTF andP Q with
                    | conj _ H2 => H2
                    end).
simpl.
reflexivity.
fold my_term_args.
admit.
Admitted.

apply tta.
Check @match_cons _ _ i i0.

rewrite -> w.
(* change (match elimTF andP match elimTF andP Q with
                            | conj _ H2 => H2
                            end with
          | conj H1 H2 =>
              {| tval := p; irt := H1 |}
              :: (fix
                  minilemma (ts0 : seq preterm) (H : all is_term ts0) {struct
                            ts0} : seq term :=
                    match ts0 as l return (all is_term l -> seq term) with
                    | []%list => fun _ : true => []%list
                    | p0 :: ts1 =>
                        fun H0 : is_term p0 && all is_term ts1 =>
                        match elimTF andP H0 with
                        | conj H3 H4 =>
                            {| tval := p0; irt := H3 |} :: minilemma ts1 H4
                        end
                    end H) ts H2
          end)
with
(match R with
          | conj H1 H2 =>
              {| tval := p; irt := H1 |}
              :: (fix
                  minilemma (ts0 : seq preterm) (H : all is_term ts0) {struct
                            ts0} : seq term :=
                    match ts0 as l return (all is_term l -> seq term) with
                    | []%list => fun _ : true => []%list
                    | p0 :: ts1 =>
                        fun H0 : is_term p0 && all is_term ts1 =>
                        match elimTF andP H0 with
                        | conj H3 H4 =>
                            {| tval := p0; irt := H3 |} :: minilemma ts1 H4
                        end
                    end H) ts H2
          end).*)
(****************************************)
change BBJ with ts.
fold R.
 as [H1 H2].
simpl.
compute.
rewrite map_cons.
simpl.
fold minilemma.
unfold minilemma.

compute.
simpl.
rewrite <- rew .
simpl.
rewrite -> BBJ in rew.

replace -> (just_args {| tval := Node fv ts; irt := Q |}) in BBJ.

set (f j => expr'). replace expr with f i.

(@tta1 fv ts Q).

destruct fv.
destruct ts; simpl in * |- *.
trivial.
destruct (and_elim Q) as [A1 A2].
Check (eq_bool_prop A1).
revert Q.
rewrite -> (eq_bool_prop A1).
intro Q.

Print my_term_args.
Abort. (* tta *)

Definition perevod (ts : seq preterm) (R : all is_term ts) : seq term
:= @minilemma ts R.

rewrite map_cons.
compute.
simpl.
Print eq_op.
Abort.
Check reflect.
Check andP.

elim Q.
Check proj2 (pair_andP (fsv0 == (length ts).+1) ((is_term p)&&(all is_term ts))).
pose (Y:=proj2 (pair_andP (fsv0 == (length ts).+1) ((is_term p)&&(all is_term ts))) ).
destruct (@and3P (fsv0 == (length ts).+1) (is_term p) (all is_term ts)).

revert Q.
move/and3P.
unfold my_term_args.
unfold allisterm.
(*move/and3P. => [H1 H2 H3].
rewrite map_cons.
simpl.
unfold minilemma.*)
Abort. tta

(***********************************************************************************)
End other.

Fixpoint substT (t:preterm) (xi: SetVars) (u:preterm): preterm.
Proof.
destruct u.
2 : { refine (Node f _).
exact (map (substT t xi) l). }
destruct (PeanoNat.Nat.eqb s xi).
exact t.
exact s.
Show Proof.
Abort.

Definition substT :=
(fix substT (t : preterm) (xi : SetVars) (u : preterm) {struct u} : preterm :=
   match u return preterm with
   | Vari s =>
       let b : bool := Nat.eqb s xi in
       match b return preterm with
       | true => t
       | false => Vari s
       end
   | Node f l => Node f (@map preterm preterm (substT t xi) l : list preterm)
   end).

Check 0.

(* not finished
Fixpoint substIsTerm (t:term) (xi: SetVars) (u:term): is_term (substT t xi u).
destruct u as [tval0 i0].
simpl.

revert t xi tval0 i0. fix Hyp 3. intros.
Show Proof.
destruct tval0 as [ s | f l ].
simpl.
destruct (PeanoNat.Nat.eqb s xi) .
exact (irt t).
exact (i0).
simpl.
apply/andP.
split.
Locate " <- ]".
Locate length.
pose (q:= List.map_length).
rewrite -> q.
simpl in i0.
destruct (@andP (fsv f == length l) (all is_term l)) as [B1|B2].
firstorder.
exfalso.
exact (not_false_is_true i0).
Locate all.
simpl in i0.
destruct (@andP (fsv f == length l) (all is_term l)) as [B1|B2].
2 : { exfalso; exact (not_false_is_true i0). }
destruct B1. (* *)
Check all.
Locate conj.
pose (P1 := (fun a b => proj1 (List.forallb_forall a b)) _ _ H0).
apply (fun a b => proj2 (List.forallb_forall a b)).
intros.
simpl in *|-*.

Check (fun x1 x2 x3 x4 x5 => proj1 (@List.in_map_iff x1 x2 x3 x4 x5)).
Check (Hyp t xi x).
Check List.in_map_iff.
(* usilit hyp ili rewrite H1
y := x
f := substT t xi
l := L
*)
Check (substT t xi).
pose lm1 := (@List.in_map_iff _ _ (substT t xi) l x).
pose lm2 := (proj1 lm1 H1).
destruct lm2 as [x0 [J0 J1]].
rewrite <- J0.
apply Hyp.
apply P1.
exact J1.
Defined.
Abort.*)

Check 0.

Section heredity.
Hypotheses (t : term) (xi : SetVars).
Fixpoint Hyp (tval0 : preterm) :
      is_term tval0 -> is_term (substT t xi tval0).
(*apply/implyP.
move/implyP.*)
intro H.
induction tval0 eqn:w.
simpl.
destruct (sv =? xi ).
simpl.
exact (irt t).
exact H.
simpl in * |- *.
apply/andP.
split.
revert H. move/andP. intro H. destruct H.
pose (q:= List.map_length).
rewrite -> q.
firstorder.
revert H. move/andP. intro H. destruct H.
rewrite <- all_map; fold is_term.
simpl in * |- *.
Abort.

End heredity.

(* big proof *)
Fixpoint substIsTerm (t:term) (xi: SetVars) (u:term):
is_term (substT t xi u).
destruct u as [tval0 i0].
simpl.
revert t xi tval0 i0. fix Hyp 3. intros.
Show Proof.
destruct tval0 as [ s | f l ].
simpl.
destruct (PeanoNat.Nat.eqb s xi) .
exact (irt t).
exact (i0).
simpl.
destruct l.
simpl in * |- *.
exact i0.
simpl in * |- *.
apply/andP.
split.
pose (q:= List.map_length).
rewrite -> q.
simpl in i0.
destruct (@andP (fsv f == (length l).+1) (all is_term l))
 as [B1|B2].
firstorder.

(* i0 must be destructed *)
(*destruct (@andP (fsv f == length l) (all is_term l)) as [B1|B2].*)

(* NOT BAD
exfalso.
exact (not_false_is_true i0).
Locate all.
simpl in i0.
destruct (@andP (fsv f == length l) (all is_term l)) as [B1|B2].
2 : { exfalso; exact (not_false_is_true i0). }
destruct B1. (* *)
Check all.
Locate conj.
pose (P1 := (fun a b => proj1 (List.forallb_forall a b)) _ _ H0).
apply (fun a b => proj2 (List.forallb_forall a b)).
intros.
simpl in *|-*.

Check (fun x1 x2 x3 x4 x5 => proj1 (@List.in_map_iff x1 x2 x3 x4 x5)).
Check (Hyp t xi x).
Check List.in_map_iff.
(* usilit hyp ili rewrite H1
y := x
f := substT t xi
l := L
*)
Check (substT t xi).
pose lm1 := (@List.in_map_iff _ _ (substT t xi) l x).
pose lm2 := (proj1 lm1 H1).
destruct lm2 as [x0 [J0 J1]].
rewrite <- J0.
apply Hyp.
apply P1.
exact J1.*)
Abort.


Require Import ssreflect ssrbool.
Require Export Lists.List.
Require Export GenReflect SetSpecs.
Require Export DecList.
Require Export DecSort.
Require Export mBidAsk.
Require Export Quantity.
Require Export mMatching.
Require Export MatchingAlter.
Require Export MQFair.

Section Uniqueness.

(*
Definition Optimal_IR_Uniform (M:list fill_type)(B:list Bid)(A:list Ask):
matching_in B A M/\ Is_IR M /\ Uniform M/\(forall M', (matching_in B A M'/\Is_IR M' /\ Uniform M') -> QM(M')<=QM(M)).
*)
Lemma less_Q_implies_less_qa (M1 M2: list fill_type)(A:list Ask):
QMa M1 A < QMa M2 A ->
exists a' : Ask, (In a' A)/\(ttqa M1 a' < ttqa M2 a').
Proof. revert M1 M2. induction A. intros. simpl in H.
lia. intros. simpl in H.
assert(Ha:(ttqa M1 a < ttqa M2 a)\/(ttqa M1 a >= ttqa M2 a)).
lia. destruct Ha. exists a. auto. assert(QMa M1 A < QMa M2 A).
lia. apply IHA in H1. destruct H1. destruct H1. exists x. auto. Qed.

Lemma size_equal_and_gt_imply_lt_ask (M1 M2: list fill_type)(A:list Ask)
(a:Ask):
(QMa M1 A = QMa M2 A) -> In a A -> (ttqa M1 a > ttqa M2 a) ->
(exists a', (In a' A)/\(ttqa M1 a' < ttqa M2 a')).

Proof. intros.
       induction A. elim H0.
       simpl in H0. destruct H0. subst a0.
       simpl in H. assert(HM:QMa M1 A < QMa M2 A).
       lia. apply less_Q_implies_less_qa with (A:=A) in HM.
       destruct HM. destruct H0. exists x. auto.
       simpl in H.
       assert(Ha:(ttqa M1 a0 < ttqa M2 a0)
       \/(ttqa M1 a0 = ttqa M2 a0)
       \/(ttqa M1 a0 > ttqa M2 a0)).
       lia.
       destruct Ha.
       exists a0. auto.
       destruct H2.
       assert(QMa M1 A = QMa M2 A).
       lia. apply IHA in H3.
       destruct H3. destruct H3. exists x. auto.
       auto.
       assert(QMa M1 A < QMa M2 A). lia.
       apply less_Q_implies_less_qa with (A:=A) in H3.
       destruct H3. destruct H3. exists x. auto. Qed.

Lemma Qsize_equal_and_gt_imply_lt_ask (M1 M2: list fill_type)(A:list Ask)
(NDA: NoDup A)(a:Ask):
(QM(M1) = QM(M2)) -> (ttqa M1 a > ttqa M2 a) -> asks_of M1 [<=] A
-> asks_of M2 [<=] A ->
(exists a', (In a' A)/\(ttqa M1 a' < ttqa M2 a')).
Proof. intros. apply QM_equal_QMa in H1 as H3. apply QM_equal_QMa in H2 as H4.
       rewrite <- H3 in H. rewrite <- H4 in H.
       assert(Ha1:In a (asks_of M1)). apply ttqa_intro1. lia.
       assert (Ha2: In a A). eauto.
       apply size_equal_and_gt_imply_lt_ask with (a:=a). all:auto. Qed.

Theorem completeness_asks (M1 M2: list fill_type) (B:list Bid) (A:list Ask)
(NZB: forall b, In b B -> (bq b)>0)
(NZA: forall a, In a A -> (sq a)>0)
(NDA: NoDup A)(a:Ask):
  (matching_in B A M1)/\ (matching_in B A M2)
  /\(QM(M1) = QM(M2))
  /\(fair_on_asks M1 A) /\ (fair_on_asks M2 A)
    -> (ttqa M1 a = ttqa M2 a).
Proof. intros. destruct H. destruct H0. destruct H1. destruct H2.
unfold fair_on_asks in H2. unfold fair_on_asks in H3.
assert(Hta:ttqa M1 a = ttqa M2 a\/ttqa M1 a <> ttqa M2 a).
eauto. destruct Hta. auto.
assert(Hga:ttqa M1 a > ttqa M2 a\/ttqa M1 a < ttqa M2 a).
 lia. destruct Hga.
  (*Case when there exists an ask a such that it's total trade quantities is more in M1 than M2*)
  { assert(exists a', (In a' A)/\(ttqa M1 a' < ttqa M2 a')).
    {
      apply Qsize_equal_and_gt_imply_lt_ask with (a:=a). all:auto.
      apply H. apply H0.
    }
    destruct H6 as [a' H6]. destruct H6.
    assert(Ha: (by_sp a a')\/(by_sp a' a)). apply by_sp_P.
    destruct Ha.
    (*Case when a is more competitive ask than a' *)
    { assert(ttqa M2 a = 0\/ttqa M2 a <>0) by eauto.
      destruct H9.  (*Case when more competitive does not belongs to M2*)
        { destruct (a_eqb a a') eqn:Haa'. move /eqP in Haa'. subst. lia.
          assert(HqaM1: ttqa M1 a>0). lia. assert(HM1A:In a (asks_of M1)).
          { apply ttqa_intro1. lia. }
          assert(HA:In a A). apply H in  HM1A. auto.
          assert(HqaM2: ttqa M2 a'>0). lia. assert(HM2A:In a' (asks_of M2)).
          { apply ttqa_intro1. lia. }
          assert(HA2:In a' A). apply H0 in  HM2A. auto.
          apply H3 in H8. destruct H8. specialize (NZA a).
          apply NZA in  HA. lia. auto. move /eqP in Haa'.  auto.
          auto. lia.
        } (*Case when more competitive belongs to M2*)
        { assert(ttqa M1 a = 0\/ttqa M1 a <>0) by eauto.
          destruct H10.
          { lia. }
          { destruct (a_eqb a a') eqn:Haa'. move /eqP in Haa'. subst. lia.
            assert(HqaM1: ttqa M1 a>0). lia. assert(HM1A:In a (asks_of M1)).
            { apply ttqa_intro1. lia. }
            assert(HA:In a A). apply H in  HM1A. auto.
            assert(HqaM2: ttqa M2 a'>0). lia. assert(HM2A:In a' (asks_of M2)).
            { apply ttqa_intro1. lia. }
            assert(HA2:In a' A). apply H0 in  HM2A. auto.
            assert(ttqa M2 a' >0) by lia.
            apply H3 with (s:=a)(s':=a') in H11 as H13.
            destruct H13. assert(ttqa M1 a <= sq a). apply H.
            auto. lia.
            all:auto. move /eqP in Haa'. auto.
          }
        }
      }
    (*Case when a' is more competitive ask than a *)
    { assert(ttqa M1 a' = 0\/ttqa M1 a' <>0) by eauto.
      destruct H9.  (*Case when more competitive does not belongs to M1*)
        { destruct (a_eqb a a') eqn:Haa'. move /eqP in Haa'. subst. lia.
          assert(HqaM1: ttqa M2 a'>0). lia. assert(HM2A:In a' (asks_of M2)).
          { apply ttqa_intro1. lia. }
          assert(HA:In a' A). apply H0 in HM2A. auto.
          assert(HqaM2: ttqa M1 a>0). lia. assert(HM1A:In a (asks_of M1)).
          { apply ttqa_intro1. lia. }
          assert(HA2:In a A). apply H in  HM1A. auto.
          apply H2 in H8. destruct H8. specialize (NZA a').
          apply NZA in  HA. lia. auto. move /eqP in Haa'.  auto.
          auto. lia.
        } (*Case when more competitive belongs to M2*)
        { assert(ttqa M2 a' = 0\/ttqa M2 a' <>0) by eauto.
          destruct H10.
          { lia. }
          { destruct (a_eqb a a') eqn:Haa'. move /eqP in Haa'. subst. lia.
            assert(HqaM1: ttqa M2 a'>0). lia. assert(HM2A:In a' (asks_of M2)).
            { apply ttqa_intro1. lia. }
            assert(HA:In a' A). apply H0 in HM2A. auto.
            assert(HqaM2: ttqa M1 a>0). lia. assert(HM1A:In a (asks_of M1)).
            { apply ttqa_intro1. lia. }
            assert(HA2:In a A). apply H in  HM1A. auto.
            apply H2 with (s:=a')(s':=a) in H8 as H12. destruct H12.
            assert(ttqa M2 a' <= sq a'). apply H0.
            auto. lia.
            all:auto. move /eqP in Haa'. auto.
          }
        }
      }
    }
      (*Case when there exists an ask a such that it's total trade quantities is more in M1 than M2*)
  { assert(exists a', (In a' A)/\(ttqa M1 a' > ttqa M2 a')).
    {
      apply Qsize_equal_and_gt_imply_lt_ask with (a:=a). all:auto.
      apply H0. apply H.
    }
    destruct H6 as [a' H6]. destruct H6.
    assert(Ha: (by_sp a a')\/(by_sp a' a)). apply by_sp_P.
    destruct Ha.
    (*Case when a is more competitive ask than a' *)
    { assert(ttqa M1 a = 0\/ttqa M1 a <>0) by eauto.
      destruct H9.  (*Case when more competitive does not belongs to M2*)
        { destruct (a_eqb a a') eqn:Haa'. move /eqP in Haa'. subst. lia.
          assert(HqaM2: ttqa M2 a>0). lia. assert(HM2A:In a (asks_of M2)).
          { apply ttqa_intro1. lia. }
          assert(HA:In a A). apply H0 in  HM2A. auto.
          assert(HqaM1: ttqa M1 a'>0). lia. assert(HM1A:In a' (asks_of M1)).
          { apply ttqa_intro1. lia. }
          assert(HA2:In a' A). apply H0 in HM2A. auto.
          eapply H2 with (s:=a) in HqaM1. destruct HqaM1. specialize (NZA a).
          apply NZA in  HA. lia. auto. move /eqP in Haa'.  auto.
          auto. auto.
        } (*Case when more competitive belongs to M2*)
        { assert(ttqa M2 a = 0\/ttqa M2 a <>0) by eauto.
          destruct H10.
          { lia. }
          { destruct (a_eqb a a') eqn:Haa'. move /eqP in Haa'. subst. lia.
            assert(HqaM2: ttqa M2 a>0). lia. assert(HM2A:In a (asks_of M2)).
            { apply ttqa_intro1. lia. }
            assert(HA:In a A). apply H0 in  HM2A. auto.
            assert(HqaM1: ttqa M1 a'>0). lia. assert(HM1A:In a' (asks_of M1)).
            { apply ttqa_intro1. lia. }
            assert(HA2:In a' A). apply H0 in HM2A. auto.
            apply H2 with (s:=a)(s':=a') in HqaM1 as H13.
            destruct H13. assert(ttqa M2 a <= sq a). apply H0.
            auto. lia.
            all:auto. move /eqP in Haa'. auto.
          }
        }
      }
    (*Case when a' is more competitive ask than a *)
    { assert(ttqa M2 a' = 0\/ttqa M2 a' <>0) by eauto.
      destruct H9.  (*Case when more competitive does not belongs to M1*)
        { destruct (a_eqb a a') eqn:Haa'. move /eqP in Haa'. subst. lia.
          assert(HqaM2: ttqa M2 a>0). lia. assert(HM2A:In a (asks_of M2)).
          { apply ttqa_intro1. lia. }
          assert(HA:In a A). apply H0 in HM2A. auto.
          assert(HqaM1: ttqa M1 a'>0). lia. assert(HM1A:In a' (asks_of M1)).
          { apply ttqa_intro1. lia. }
          assert(HA2:In a' A). apply H in  HM1A. auto.
          apply H3 in H8. destruct H8. specialize (NZA a').
          apply NZA in  HA2. lia. auto. move /eqP in Haa'.  auto.
          auto. lia.
        } (*Case when more competitive belongs to M2*)
        { assert(ttqa M2 a = 0\/ttqa M2 a <>0) by eauto.
          destruct H10.
          { lia. }
          { destruct (a_eqb a a') eqn:Haa'. move /eqP in Haa'. subst. lia.
            assert(HqaM1: ttqa M2 a>0). lia. assert(HM2A:In a (asks_of M2)).
            { apply ttqa_intro1. lia. }
            assert(HA:In a A). apply H0 in HM2A. auto.
            assert(HqaM2: ttqa M1 a'>0). lia. assert(HM1A:In a' (asks_of M1)).
            { apply ttqa_intro1. lia. }
            assert(HA2:In a' A). apply H in  HM1A. auto.
            apply H3 with (s:=a')(s':=a) in H8 as H12. destruct H12.
            assert(ttqa M1 a' <= sq a'). apply H.
            auto. lia.
            all:auto. move /eqP in Haa'. auto.
          }
        }
      }
    } Qed.

Lemma less_Q_implies_less_qb (M1 M2: list fill_type)(B:list Bid):
QMb M1 B < QMb M2 B ->
exists b' : Bid, (In b' B)/\(ttqb M1 b' < ttqb M2 b').
Proof. revert M1 M2. induction B as [|b B']. intros. simpl in H.
lia. intros. simpl in H.
assert(Hb:(ttqb M1 b < ttqb M2 b)\/(ttqb M1 b >= ttqb M2 b)).
lia. destruct Hb. exists b. auto. assert(QMb M1 B' < QMb M2 B').
lia. apply IHB' in H1. destruct H1. destruct H1. exists x. auto. Qed.

Lemma size_equal_and_gt_imply_lt_bid (M1 M2: list fill_type)(B:list Bid)
(b:Bid):
(QMb M1 B = QMb M2 B) -> In b B -> (ttqb M1 b > ttqb M2 b) ->
(exists b', (In b' B)/\(ttqb M1 b' < ttqb M2 b')).

Proof. intros.
       induction B as [|b0 B']. elim H0.
       simpl in H0. destruct H0. subst b0.
       simpl in H. assert(HM:QMb M1 B' < QMb M2 B').
       lia. apply less_Q_implies_less_qb with (B:=B') in HM.
       destruct HM. destruct H0. exists x. auto.
       simpl in H.
       assert(Hb:(ttqb M1 b0 < ttqb M2 b0)
       \/(ttqb M1 b0 = ttqb M2 b0)
       \/(ttqb M1 b0 > ttqb M2 b0)).
       lia.
       destruct Hb.
       exists b0. auto.
       destruct H2.
       assert(QMb M1 B' = QMb M2 B').
       lia. apply IHB' in H3.
       destruct H3. destruct H3. exists x. auto.
       auto.
       assert(QMb M1 B' < QMb M2 B'). lia.
       apply less_Q_implies_less_qb with (B:=B') in H3.
       destruct H3. destruct H3. exists x. auto. Qed.

Lemma Qsize_equal_and_gt_imply_lt_bid (M1 M2: list fill_type)(B:list Bid)
(NDB: NoDup B)(b:Bid):
(QM(M1) = QM(M2)) -> (ttqb M1 b > ttqb M2 b) -> bids_of M1 [<=] B
-> bids_of M2 [<=] B ->
(exists b', (In b' B)/\(ttqb M1 b' < ttqb M2 b')).
Proof. intros. apply QM_equal_QMb in H1 as H3. apply QM_equal_QMb in H2 as H4.
       rewrite <- H3 in H. rewrite <- H4 in H.
       assert(Hb1:In b (bids_of M1)). apply ttqb_intro1. lia.
       assert (Hb2: In b B). eauto.
       apply size_equal_and_gt_imply_lt_bid with (b:=b). all:auto. Qed.

Theorem completeness_bids (M1 M2: list fill_type) (B:list Bid) (A:list Ask)
(NZB: forall b, In b B -> (bq b)>0)
(NZA: forall a, In a A -> (sq a)>0)
(NDB: NoDup B)(b:Bid):
  (matching_in B A M1)/\ (matching_in B A M2)
  /\(QM(M1) = QM(M2))
  /\(fair_on_bids M1 B) /\ (fair_on_bids M2 B)
    -> (ttqb M1 b = ttqb M2 b).
Proof. intros. destruct H. destruct H0. destruct H1. destruct H2.
unfold fair_on_bids in H2. unfold fair_on_bids in H3.
assert(Htb:ttqb M1 b = ttqb M2 b\/ttqb M1 b <> ttqb M2 b).
eauto. destruct Htb. auto.
assert(Hgb:ttqb M1 b > ttqb M2 b\/ttqb M1 b < ttqb M2 b).
 lia. destruct Hgb.
  (*Case when there exists a bid a such that it's total trade quantities is more in M1 than M2*)
  { assert(exists b', (In b' B)/\(ttqb M1 b' < ttqb M2 b')).
    {
      apply Qsize_equal_and_gt_imply_lt_bid with (b:=b). all:auto.
      apply H. apply H0.
    }
    destruct H6 as [b' H6]. destruct H6.
    assert(Hb: (by_dbp b b')\/(by_dbp b' b)). apply by_dbp_P.
    destruct Hb.
    (*Case when b is more competitive bid than b' *)
    { assert(ttqb M2 b = 0\/ttqb M2 b <>0) by eauto.
      destruct H9.  (*Case when more competitive does not belongs to M2*)
        { destruct (b_eqb b b') eqn:Hbb'. move /eqP in Hbb'. subst. lia.
          assert(HqbM1: ttqb M1 b>0). lia. assert(HM1B:In b (bids_of M1)).
          { apply ttqb_intro1. lia. }
          assert(HB:In b B). apply H in  HM1B. auto.
          assert(HqbM2: ttqb M2 b'>0). lia. assert(HM2B:In b' (bids_of M2)).
          { apply ttqb_intro1. lia. }
          assert(HB2:In b' B). apply H0 in  HM2B. auto.
          apply H3 in H8. destruct H8. specialize (NZB b).
          apply NZB in HB. lia. auto. move /eqP in Hbb'.  auto.
          auto. lia.
        } (*Case when more competitive belongs to M2*)
        { assert(ttqb M1 b = 0\/ttqb M1 b <>0) by eauto.
          destruct H10.
          { lia. }
          { destruct (b_eqb b b') eqn:Hbb'. move /eqP in Hbb'. subst. lia.
            assert(HqbM1: ttqb M1 b>0). lia. assert(HM1B:In b (bids_of M1)).
            { apply ttqb_intro1. lia. }
            assert(HB:In b B). apply H in  HM1B. auto.
            assert(HqbM2: ttqb M2 b'>0). lia. assert(HM2B:In b' (bids_of M2)).
            { apply ttqb_intro1. lia. }
            assert(HB2:In b' B). apply H0 in  HM2B. auto.
            assert(ttqb M2 b' >0) by lia.
            apply H3 with (b:=b)(b':=b') in H11 as H13.
            destruct H13. assert(ttqb M1 b <= bq b). apply H.
            auto. lia.
            all:auto. move /eqP in Hbb'. auto.
          }
        }
      }
    (*Case when b' is more competitive bid than b *)
    { assert(ttqb M1 b' = 0\/ttqb M1 b' <>0) by eauto.
      destruct H9.  (*Case when more competitive does not belongs to M1*)
        { destruct (b_eqb b b') eqn:Hbb'. move /eqP in Hbb'. subst. lia.
          assert(HqbM1: ttqb M2 b'>0). lia. assert(HM2B:In b' (bids_of M2)).
          { apply ttqb_intro1. lia. }
          assert(HB:In b' B). apply H0 in HM2B. auto.
          assert(HqbM2: ttqb M1 b>0). lia. assert(HM1B:In b (bids_of M1)).
          { apply ttqb_intro1. lia. }
          assert(HB2:In b B). apply H in  HM1B. auto.
          apply H2 in H8. destruct H8. specialize (NZB b').
          apply NZB in  HB. lia. auto. move /eqP in Hbb'.  auto.
          auto. lia.
        } (*Case when more competitive belongs to M2*)
        { assert(ttqb M2 b' = 0\/ttqb M2 b' <>0) by eauto.
          destruct H10.
          { lia. }
          { destruct (b_eqb b b') eqn:Hbb'. move /eqP in Hbb'. subst. lia.
            assert(HqbM1: ttqb M2 b'>0). lia. assert(HM2B:In b' (bids_of M2)).
            { apply ttqb_intro1. lia. }
            assert(HB:In b' B). apply H0 in HM2B. auto.
            assert(HqbM2: ttqb M1 b>0). lia. assert(HM1B:In b (bids_of M1)).
            { apply ttqb_intro1. lia. }
            assert(HB2:In b B). apply H in  HM1B. auto.
            apply H2 with (b:=b')(b':=b) in H8 as H12. destruct H12.
            assert(ttqb M2 b' <= bq b'). apply H0.
            auto. lia.
            all:auto. move /eqP in Hbb'. auto.
          }
        }
      }
    }
      (*Case when there exists an ask a such that it's total trade quantities is more in M1 than M2*)
  { assert(exists b', (In b' B)/\(ttqb M1 b' > ttqb M2 b')).
    {
      apply Qsize_equal_and_gt_imply_lt_bid with (b:=b). all:auto.
      apply H0. apply H.
    }
    destruct H6 as [b' H6]. destruct H6.
    assert(Hb: (by_dbp b b')\/(by_dbp b' b)). apply by_dbp_P.
    destruct Hb.
    (*Case when b is more competitive bid than b' *)
    { assert(ttqb M1 b = 0\/ttqb M1 b <>0) by eauto.
      destruct H9.  (*Case when more competitive does not belongs to M2*)
        { destruct (b_eqb b b') eqn:Hbb'. move /eqP in Hbb'. subst. lia.
          assert(HqbM2: ttqb M2 b>0). lia. assert(HM2B:In b (bids_of M2)).
          { apply ttqb_intro1. lia. }
          assert(HB:In b B). apply H0 in  HM2B. auto.
          assert(HqbM1: ttqb M1 b'>0). lia. assert(HM1B:In b' (bids_of M1)).
          { apply ttqb_intro1. lia. }
          assert(HB2:In b' B). apply H0 in HM2B. auto.
          eapply H2 with (b:=b) in HqbM1. destruct HqbM1. specialize (NZB b).
          apply NZB in  HB. lia. auto. move /eqP in Hbb'.  auto.
          auto. auto.
        } (*Case when more competitive belongs to M2*)
        { assert(ttqb M2 b = 0\/ttqb M2 b <>0) by eauto.
          destruct H10.
          { lia. }
          { destruct (b_eqb b b') eqn:Hbb'. move /eqP in Hbb'. subst. lia.
            assert(HqbM2: ttqb M2 b>0). lia. assert(HM2B:In b (bids_of M2)).
            { apply ttqb_intro1. lia. }
            assert(HB:In b B). apply H0 in  HM2B. auto.
            assert(HqbM1: ttqb M1 b'>0). lia. assert(HM1B:In b' (bids_of M1)).
            { apply ttqb_intro1. lia. }
            assert(HB2:In b' B). apply H0 in HM2B. auto.
            apply H2 with (b:=b)(b':=b') in HqbM1 as H13.
            destruct H13. assert(ttqb M2 b <= bq b). apply H0.
            auto. lia.
            all:auto. move /eqP in Hbb'. auto.
          }
        }
      }
    (*Case when b' is more competitive bid than b *)
    { assert(ttqb M2 b' = 0\/ttqb M2 b' <>0) by eauto.
      destruct H9.  (*Case when more competitive does not belongs to M1*)
        { destruct (b_eqb b b') eqn:Hbb'. move /eqP in Hbb'. subst. lia.
          assert(HqbM2: ttqb M2 b>0). lia. assert(HM2B:In b (bids_of M2)).
          { apply ttqb_intro1. lia. }
          assert(HB:In b B). apply H0 in HM2B. auto.
          assert(HqbM1: ttqb M1 b'>0). lia. assert(HM1B:In b' (bids_of M1)).
          { apply ttqb_intro1. lia. }
          assert(HB2:In b' B). apply H in  HM1B. auto.
          apply H3 in H8. destruct H8. specialize (NZB b').
          apply NZB in  HB2. lia. auto. move /eqP in Hbb'.  auto.
          auto. lia.
        } (*Case when more competitive belongs to M2*)
        { assert(ttqb M2 b = 0\/ttqb M2 b <>0) by eauto.
          destruct H10.
          { lia. }
          { destruct (b_eqb b b') eqn:Hbb'. move /eqP in Hbb'. subst. lia.
            assert(HqbM1: ttqb M2 b>0). lia. assert(HM2B:In b (bids_of M2)).
            { apply ttqb_intro1. lia. }
            assert(HB:In b B). apply H0 in HM2B. auto.
            assert(HqbM2: ttqb M1 b'>0). lia. assert(HM1B:In b' (bids_of M1)).
            { apply ttqb_intro1. lia. }
            assert(HB2:In b' B). apply H in  HM1B. auto.
            apply H3 with (b:=b')(b':=b) in H8 as H12. destruct H12.
            assert(ttqb M1 b' <= bq b'). apply H.
            auto. lia.
            all:auto. move /eqP in Hbb'. auto.
          }
        }
      }
    } Qed.

Theorem completeness (M1 M2: list fill_type) (B:list Bid) (A:list Ask)
(NZB: forall b, In b B -> (bq b)>0)
(NZA: forall a, In a A -> (sq a)>0)
(NDB: NoDup B)(NDA: NoDup A)
(b:Bid) (a:Ask):
(matching_in B A M1)/\ (matching_in B A M2) /\(QM(M1) = QM(M2))
/\(Is_fair M1 B A) /\ (Is_fair M2 B A)
-> (ttqa M1 a = ttqa M2 a)/\(ttqb M1 b = ttqb M2 b).
Proof. intros. split.
                { apply completeness_asks with (B:=B)(A:=A). all:auto.
                  split. apply H. split. apply H. split. apply H. split. apply H. apply H.
                }
                { apply completeness_bids with (B:=B)(A:=A). all:auto.
                  split. apply H. split. apply H. split. apply H. split. apply H. apply H.
                } Qed.

Lemma soundness_asks (M1 M2: list fill_type) (B:list Bid) (A:list Ask)
(NZB: forall b, In b B -> (bq b)>0)
(NZA: forall a, In a A -> (sq a)>0)
(NDA: NoDup A):
(matching_in B A M1)-> (matching_in B A M2) ->(forall a, (ttqa M1 a = ttqa M2 a))
->(fair_on_asks M1 A)
-> (fair_on_asks M2 A).
Proof. unfold fair_on_asks. intros. specialize (H1 s') as Hs'.  specialize (H1 s) as Hs.
                  assert(ttqa M1 s' > 0). lia.
                  eapply H2 with (s:=s)(s':=s') in H8. destruct H8.
                  assert(In s A). apply H. auto. assert(In s' A). apply H0. auto.
                  specialize (NZA s). apply NZA in H10. assert(ttqa M2 s = sq s). lia. split.
                  eapply ttqa_intro1.  lia. all: auto. apply ttqa_intro1. lia. Qed.

Lemma soundness_bids (M1 M2: list fill_type) (B:list Bid) (A:list Ask)
(NZB: forall b, In b B -> (bq b)>0)
(NZA: forall a, In a A -> (sq a)>0)
(NDA: NoDup B):
(matching_in B A M1)-> (matching_in B A M2) ->(forall b, (ttqb M1 b = ttqb M2 b))
->(fair_on_bids M1 B)
-> (fair_on_bids M2 B).
Proof. unfold fair_on_bids. intros. specialize (H1 b') as Hb'.  specialize (H1 b) as Hb.
                  assert(ttqb M1 b' > 0). lia.
                  eapply H2 with (b:=b)(b':=b') in H7. destruct H7.
                  assert(In b B). apply H. auto. assert(In b' B). apply H0. auto.
                  specialize (NZB b). apply NZB in H9. assert(ttqb M2 b = bq b). lia. split.
                  eapply ttqb_intro1.  lia. all: auto. apply ttqb_intro1. lia. Qed.

Theorem soundness (M1 M2: list fill_type) (B:list Bid) (A:list Ask)
(NZB: forall b, In b B -> (bq b)>0)
(NZA: forall a, In a A -> (sq a)>0)
(NDB: NoDup B)(NDA: NoDup A):
(matching_in B A M1)-> (matching_in B A M2) ->
(forall b, (ttqb M1 b = ttqb M2 b))/\(forall a, (ttqa M1 a = ttqa M2 a))
->(Is_fair M1 B A)
-> (Is_fair M2 B A).
Proof. intros. destruct H2. split.
                { apply soundness_asks with (B:=B)(A:=A)(M2:=M2) in H2. all:auto. apply H1.
                }
                { apply soundness_bids with (B:=B)(A:=A)(M2:=M2) in H3. all:auto. apply H1.
                } Qed.

End Uniqueness.