(*  Title:      CCL/Wfd.thy
    Author:     Martin Coen, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section {* Well-founded relations in CCL *}

theory Wfd
imports Trancl Type Hered
begin

definition Wfd :: "[i set] \<Rightarrow> o"
  where "Wfd(R) == ALL P.(ALL x.(ALL y.<y,x> : R \<longrightarrow> y:P) \<longrightarrow> x:P) \<longrightarrow> (ALL a. a:P)"

definition wf :: "[i set] \<Rightarrow> i set"
  where "wf(R) == {x. x:R \<and> Wfd(R)}"

definition wmap :: "[i\<Rightarrow>i,i set] \<Rightarrow> i set"
  where "wmap(f,R) == {p. EX x y. p=<x,y> \<and> <f(x),f(y)> : R}"

definition lex :: "[i set,i set] => i set"      (infixl "**" 70)
  where "ra**rb == {p. EX a a' b b'. p = <<a,b>,<a',b'>> \<and> (<a,a'> : ra | (a=a' \<and> <b,b'> : rb))}"

definition NatPR :: "i set"
  where "NatPR == {p. EX x:Nat. p=<x,succ(x)>}"

definition ListPR :: "i set \<Rightarrow> i set"
  where "ListPR(A) == {p. EX h:A. EX t:List(A). p=<t,h$t>}"

lemma wfd_induct:
  assumes 1: "Wfd(R)"
    and 2: "\<And>x. ALL y. <y,x>: R \<longrightarrow> P(y) \<Longrightarrow> P(x)"
  shows "P(a)"
  apply (rule 1 [unfolded Wfd_def, rule_format, THEN CollectD])
  using 2 apply blast
  done

lemma wfd_strengthen_lemma:
  assumes 1: "\<And>x y.<x,y> : R \<Longrightarrow> Q(x)"
    and 2: "ALL x. (ALL y. <y,x> : R \<longrightarrow> y : P) \<longrightarrow> x : P"
    and 3: "\<And>x. Q(x) \<Longrightarrow> x:P"
  shows "a:P"
  apply (rule 2 [rule_format])
  using 1 3
  apply blast
  done

method_setup wfd_strengthen = {*
  Scan.lift Args.name_inner_syntax >> (fn s => fn ctxt =>
    SIMPLE_METHOD' (fn i =>
      res_inst_tac ctxt [(("Q", 0), s)] @{thm wfd_strengthen_lemma} i THEN assume_tac ctxt (i+1)))
*}

lemma wf_anti_sym: "\<lbrakk>Wfd(r); <a,x>:r; <x,a>:r\<rbrakk> \<Longrightarrow> P"
  apply (subgoal_tac "ALL x. <a,x>:r \<longrightarrow> <x,a>:r \<longrightarrow> P")
   apply blast
  apply (erule wfd_induct)
  apply blast
  done

lemma wf_anti_refl: "\<lbrakk>Wfd(r); <a,a>: r\<rbrakk> \<Longrightarrow> P"
  apply (rule wf_anti_sym)
  apply assumption+
  done

subsection {* Irreflexive transitive closure *}

lemma trancl_wf:
  assumes 1: "Wfd(R)"
  shows "Wfd(R^+)"
  apply (unfold Wfd_def)
  apply (rule allI ballI impI)+
(*must retain the universal formula for later use!*)
  apply (rule allE, assumption)
  apply (erule mp)
  apply (rule 1 [THEN wfd_induct])
  apply (rule impI [THEN allI])
  apply (erule tranclE)
   apply blast
  apply (erule spec [THEN mp, THEN spec, THEN mp])
   apply assumption+
  done

subsection {* Lexicographic Ordering *}

lemma lexXH:
  "p : ra**rb \<longleftrightarrow> (EX a a' b b'. p = <<a,b>,<a',b'>> \<and> (<a,a'> : ra | a=a' \<and> <b,b'> : rb))"
  unfolding lex_def by blast

lemma lexI1: "<a,a'> : ra \<Longrightarrow> <<a,b>,<a',b'>> : ra**rb"
  by (blast intro!: lexXH [THEN iffD2])

lemma lexI2: "<b,b'> : rb \<Longrightarrow> <<a,b>,<a,b'>> : ra**rb"
  by (blast intro!: lexXH [THEN iffD2])

lemma lexE:
  assumes 1: "p : ra**rb"
    and 2: "\<And>a a' b b'. \<lbrakk><a,a'> : ra; p=<<a,b>,<a',b'>>\<rbrakk> \<Longrightarrow> R"
    and 3: "\<And>a b b'. \<lbrakk><b,b'> : rb; p = <<a,b>,<a,b'>>\<rbrakk> \<Longrightarrow> R"
  shows R
  apply (rule 1 [THEN lexXH [THEN iffD1], THEN exE])
  using 2 3
  apply blast
  done

lemma lex_pair: "\<lbrakk>p : r**s; \<And>a a' b b'. p = <<a,b>,<a',b'>> \<Longrightarrow> P\<rbrakk> \<Longrightarrow>P"
  apply (erule lexE)
   apply blast+
  done

lemma lex_wf:
  assumes 1: "Wfd(R)"
    and 2: "Wfd(S)"
  shows "Wfd(R**S)"
  apply (unfold Wfd_def)
  apply safe
  apply (wfd_strengthen "\<lambda>x. EX a b. x=<a,b>")
   apply (blast elim!: lex_pair)
  apply (subgoal_tac "ALL a b.<a,b>:P")
   apply blast
  apply (rule 1 [THEN wfd_induct, THEN allI])
  apply (rule 2 [THEN wfd_induct, THEN allI]) back
  apply (fast elim!: lexE)
  done

subsection {* Mapping *}

lemma wmapXH: "p : wmap(f,r) \<longleftrightarrow> (EX x y. p=<x,y> \<and> <f(x),f(y)> : r)"
  unfolding wmap_def by blast

lemma wmapI: "<f(a),f(b)> : r \<Longrightarrow> <a,b> : wmap(f,r)"
  by (blast intro!: wmapXH [THEN iffD2])

lemma wmapE: "\<lbrakk>p : wmap(f,r); \<And>a b. \<lbrakk><f(a),f(b)> : r; p=<a,b>\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (blast dest!: wmapXH [THEN iffD1])

lemma wmap_wf:
  assumes 1: "Wfd(r)"
  shows "Wfd(wmap(f,r))"
  apply (unfold Wfd_def)
  apply clarify
  apply (subgoal_tac "ALL b. ALL a. f (a) = b \<longrightarrow> a:P")
   apply blast
  apply (rule 1 [THEN wfd_induct, THEN allI])
  apply clarify
  apply (erule spec [THEN mp])
  apply (safe elim!: wmapE)
  apply (erule spec [THEN mp, THEN spec, THEN mp])
   apply assumption
   apply (rule refl)
  done

subsection {* Projections *}

lemma wfstI: "<xa,ya> : r \<Longrightarrow> <<xa,xb>,<ya,yb>> : wmap(fst,r)"
  apply (rule wmapI)
  apply simp
  done

lemma wsndI: "<xb,yb> : r \<Longrightarrow> <<xa,xb>,<ya,yb>> : wmap(snd,r)"
  apply (rule wmapI)
  apply simp
  done

lemma wthdI: "<xc,yc> : r \<Longrightarrow> <<xa,<xb,xc>>,<ya,<yb,yc>>> : wmap(thd,r)"
  apply (rule wmapI)
  apply simp
  done

subsection {* Ground well-founded relations *}

lemma wfI: "\<lbrakk>Wfd(r);  a : r\<rbrakk> \<Longrightarrow> a : wf(r)"
  unfolding wf_def by blast

lemma Empty_wf: "Wfd({})"
  unfolding Wfd_def by (blast elim: EmptyXH [THEN iffD1, THEN FalseE])

lemma wf_wf: "Wfd(wf(R))"
  unfolding wf_def
  apply (rule_tac Q = "Wfd(R)" in excluded_middle [THEN disjE])
   apply simp_all
  apply (rule Empty_wf)
  done

lemma NatPRXH: "p : NatPR \<longleftrightarrow> (EX x:Nat. p=<x,succ(x)>)"
  unfolding NatPR_def by blast

lemma ListPRXH: "p : ListPR(A) \<longleftrightarrow> (EX h:A. EX t:List(A).p=<t,h$t>)"
  unfolding ListPR_def by blast

lemma NatPRI: "x : Nat \<Longrightarrow> <x,succ(x)> : NatPR"
  by (auto simp: NatPRXH)

lemma ListPRI: "\<lbrakk>t : List(A); h : A\<rbrakk> \<Longrightarrow> <t,h $ t> : ListPR(A)"
  by (auto simp: ListPRXH)

lemma NatPR_wf: "Wfd(NatPR)"
  apply (unfold Wfd_def)
  apply clarify
  apply (wfd_strengthen "\<lambda>x. x:Nat")
   apply (fastforce iff: NatPRXH)
  apply (erule Nat_ind)
   apply (fastforce iff: NatPRXH)+
  done

lemma ListPR_wf: "Wfd(ListPR(A))"
  apply (unfold Wfd_def)
  apply clarify
  apply (wfd_strengthen "\<lambda>x. x:List (A)")
   apply (fastforce iff: ListPRXH)
  apply (erule List_ind)
   apply (fastforce iff: ListPRXH)+
  done

subsection {* General Recursive Functions *}

lemma letrecT:
  assumes 1: "a : A"
    and 2: "\<And>p g. \<lbrakk>p:A; ALL x:{x: A. <x,p>:wf(R)}. g(x) : D(x)\<rbrakk> \<Longrightarrow> h(p,g) : D(p)"
  shows "letrec g x be h(x,g) in g(a) : D(a)"
  apply (rule 1 [THEN rev_mp])
  apply (rule wf_wf [THEN wfd_induct])
  apply (subst letrecB)
  apply (rule impI)
  apply (erule 2)
  apply blast
  done

lemma SPLITB: "SPLIT(<a,b>,B) = B(a,b)"
  unfolding SPLIT_def
  apply (rule set_ext)
  apply blast
  done

lemma letrec2T:
  assumes "a : A"
    and "b : B"
    and "\<And>p q g. \<lbrakk>p:A; q:B;
              ALL x:A. ALL y:{y: B. <<x,y>,<p,q>>:wf(R)}. g(x,y) : D(x,y)\<rbrakk> \<Longrightarrow>
                h(p,q,g) : D(p,q)"
  shows "letrec g x y be h(x,y,g) in g(a,b) : D(a,b)"
  apply (unfold letrec2_def)
  apply (rule SPLITB [THEN subst])
  apply (assumption | rule letrecT pairT splitT assms)+
  apply (subst SPLITB)
  apply (assumption | rule ballI SubtypeI assms)+
  apply (rule SPLITB [THEN subst])
  apply (assumption | rule letrecT SubtypeI pairT splitT assms |
    erule bspec SubtypeE sym [THEN subst])+
  done

lemma lem: "SPLIT(<a,<b,c>>,\<lambda>x xs. SPLIT(xs,\<lambda>y z. B(x,y,z))) = B(a,b,c)"
  by (simp add: SPLITB)

lemma letrec3T:
  assumes "a : A"
    and "b : B"
    and "c : C"
    and "\<And>p q r g. \<lbrakk>p:A; q:B; r:C;
       ALL x:A. ALL y:B. ALL z:{z:C. <<x,<y,z>>,<p,<q,r>>> : wf(R)}.
                                                        g(x,y,z) : D(x,y,z) \<rbrakk> \<Longrightarrow>
                h(p,q,r,g) : D(p,q,r)"
  shows "letrec g x y z be h(x,y,z,g) in g(a,b,c) : D(a,b,c)"
  apply (unfold letrec3_def)
  apply (rule lem [THEN subst])
  apply (assumption | rule letrecT pairT splitT assms)+
  apply (simp add: SPLITB)
  apply (assumption | rule ballI SubtypeI assms)+
  apply (rule lem [THEN subst])
  apply (assumption | rule letrecT SubtypeI pairT splitT assms |
    erule bspec SubtypeE sym [THEN subst])+
  done

lemmas letrecTs = letrecT letrec2T letrec3T

subsection {* Type Checking for Recursive Calls *}

lemma rcallT:
  "\<lbrakk>ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x);
    g(a) : D(a) \<Longrightarrow> g(a) : E;  a:A;  <a,p>:wf(R)\<rbrakk> \<Longrightarrow> g(a) : E"
  by blast

lemma rcall2T:
  "\<lbrakk>ALL x:A. ALL y:{y:B.<<x,y>,<p,q>>:wf(R)}.g(x,y):D(x,y);
    g(a,b) : D(a,b) \<Longrightarrow> g(a,b) : E; a:A; b:B; <<a,b>,<p,q>>:wf(R)\<rbrakk> \<Longrightarrow> g(a,b) : E"
  by blast

lemma rcall3T:
  "\<lbrakk>ALL x:A. ALL y:B. ALL z:{z:C.<<x,<y,z>>,<p,<q,r>>>:wf(R)}. g(x,y,z):D(x,y,z);
    g(a,b,c) : D(a,b,c) \<Longrightarrow> g(a,b,c) : E;
    a:A; b:B; c:C; <<a,<b,c>>,<p,<q,r>>> : wf(R)\<rbrakk> \<Longrightarrow> g(a,b,c) : E"
  by blast

lemmas rcallTs = rcallT rcall2T rcall3T

subsection {* Instantiating an induction hypothesis with an equality assumption *}

lemma hyprcallT:
  assumes 1: "g(a) = b"
    and 2: "ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x)"
    and 3: "ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x) \<Longrightarrow> b=g(a) \<Longrightarrow> g(a) : D(a) \<Longrightarrow> P"
    and 4: "ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x) \<Longrightarrow> a:A"
    and 5: "ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x) \<Longrightarrow> <a,p>:wf(R)"
  shows P
  apply (rule 3 [OF 2, OF 1 [symmetric]])
  apply (rule rcallT [OF 2])
    apply assumption
   apply (rule 4 [OF 2])
  apply (rule 5 [OF 2])
  done

lemma hyprcall2T:
  assumes 1: "g(a,b) = c"
    and 2: "ALL x:A. ALL y:{y:B.<<x,y>,<p,q>>:wf(R)}.g(x,y):D(x,y)"
    and 3: "\<lbrakk>c = g(a,b); g(a,b) : D(a,b)\<rbrakk> \<Longrightarrow> P"
    and 4: "a:A"
    and 5: "b:B"
    and 6: "<<a,b>,<p,q>>:wf(R)"
  shows P
  apply (rule 3)
    apply (rule 1 [symmetric])
  apply (rule rcall2T)
      apply (rule 2)
     apply assumption
    apply (rule 4)
   apply (rule 5)
  apply (rule 6)
  done

lemma hyprcall3T:
  assumes 1: "g(a,b,c) = d"
    and 2: "ALL x:A. ALL y:B. ALL z:{z:C.<<x,<y,z>>,<p,<q,r>>>:wf(R)}.g(x,y,z):D(x,y,z)"
    and 3: "\<lbrakk>d = g(a,b,c); g(a,b,c) : D(a,b,c)\<rbrakk> \<Longrightarrow> P"
    and 4: "a:A"
    and 5: "b:B"
    and 6: "c:C"
    and 7: "<<a,<b,c>>,<p,<q,r>>> : wf(R)"
  shows P
  apply (rule 3)
   apply (rule 1 [symmetric])
  apply (rule rcall3T)
       apply (rule 2)
      apply assumption
     apply (rule 4)
    apply (rule 5)
   apply (rule 6)
  apply (rule 7)
  done

lemmas hyprcallTs = hyprcallT hyprcall2T hyprcall3T

subsection {* Rules to Remove Induction Hypotheses after Type Checking *}

lemma rmIH1: "\<lbrakk>ALL x:{x:A.<x,p>:wf(R)}.g(x):D(x); P\<rbrakk> \<Longrightarrow> P" .

lemma rmIH2: "\<lbrakk>ALL x:A. ALL y:{y:B.<<x,y>,<p,q>>:wf(R)}.g(x,y):D(x,y); P\<rbrakk> \<Longrightarrow> P" .

lemma rmIH3:
 "\<lbrakk>ALL x:A. ALL y:B. ALL z:{z:C.<<x,<y,z>>,<p,<q,r>>>:wf(R)}.g(x,y,z):D(x,y,z); P\<rbrakk> \<Longrightarrow> P" .

lemmas rmIHs = rmIH1 rmIH2 rmIH3

subsection {* Lemmas for constructors and subtypes *}

(* 0-ary constructors do not need additional rules as they are handled *)
(*                                      correctly by applying SubtypeI *)

lemma Subtype_canTs:
  "\<And>a b A B P. a : {x:A. b:{y:B(a).P(<x,y>)}} \<Longrightarrow> <a,b> : {x:Sigma(A,B).P(x)}"
  "\<And>a A B P. a : {x:A. P(inl(x))} \<Longrightarrow> inl(a) : {x:A+B. P(x)}"
  "\<And>b A B P. b : {x:B. P(inr(x))} \<Longrightarrow> inr(b) : {x:A+B. P(x)}"
  "\<And>a P. a : {x:Nat. P(succ(x))} \<Longrightarrow> succ(a) : {x:Nat. P(x)}"
  "\<And>h t A P. h : {x:A. t : {y:List(A).P(x$y)}} \<Longrightarrow> h$t : {x:List(A).P(x)}"
  by (assumption | rule SubtypeI canTs icanTs | erule SubtypeE)+

lemma letT: "\<lbrakk>f(t):B; \<not>t=bot\<rbrakk> \<Longrightarrow> let x be t in f(x) : B"
  apply (erule letB [THEN ssubst])
  apply assumption
  done

lemma applyT2: "\<lbrakk>a:A; f : Pi(A,B)\<rbrakk> \<Longrightarrow> f ` a  : B(a)"
  apply (erule applyT)
  apply assumption
  done

lemma rcall_lemma1: "\<lbrakk>a:A; a:A \<Longrightarrow> P(a)\<rbrakk> \<Longrightarrow> a : {x:A. P(x)}"
  by blast

lemma rcall_lemma2: "\<lbrakk>a:{x:A. Q(x)}; \<lbrakk>a:A; Q(a)\<rbrakk> \<Longrightarrow> P(a)\<rbrakk> \<Longrightarrow> a : {x:A. P(x)}"
  by blast

lemmas rcall_lemmas = asm_rl rcall_lemma1 SubtypeD1 rcall_lemma2

subsection {* Typechecking *}

ML {*
local

val type_rls =
  @{thms canTs} @ @{thms icanTs} @ @{thms applyT2} @ @{thms ncanTs} @ @{thms incanTs} @
  @{thms precTs} @ @{thms letrecTs} @ @{thms letT} @ @{thms Subtype_canTs};

fun bvars (Const(@{const_name Pure.all},_) $ Abs(s,_,t)) l = bvars t (s::l)
  | bvars _ l = l

fun get_bno l n (Const(@{const_name Pure.all},_) $ Abs(s,_,t)) = get_bno (s::l) n t
  | get_bno l n (Const(@{const_name Trueprop},_) $ t) = get_bno l n t
  | get_bno l n (Const(@{const_name Ball},_) $ _ $ Abs(s,_,t)) = get_bno (s::l) (n+1) t
  | get_bno l n (Const(@{const_name mem},_) $ t $ _) = get_bno l n t
  | get_bno l n (t $ s) = get_bno l n t
  | get_bno l n (Bound m) = (m-length(l),n)

(* Not a great way of identifying induction hypothesis! *)
fun could_IH x = Term.could_unify(x,hd (prems_of @{thm rcallT})) orelse
                 Term.could_unify(x,hd (prems_of @{thm rcall2T})) orelse
                 Term.could_unify(x,hd (prems_of @{thm rcall3T}))

fun IHinst tac rls = SUBGOAL (fn (Bi,i) =>
  let val bvs = bvars Bi []
      val ihs = filter could_IH (Logic.strip_assums_hyp Bi)
      val rnames = map (fn x=>
                    let val (a,b) = get_bno [] 0 x
                    in (nth bvs a, b) end) ihs
      fun try_IHs [] = no_tac
        | try_IHs ((x,y)::xs) = tac [(("g", 0), x)] (nth rls (y - 1)) i ORELSE (try_IHs xs)
  in try_IHs rnames end)

fun is_rigid_prog t =
  (case (Logic.strip_assums_concl t) of
    (Const(@{const_name Trueprop},_) $ (Const(@{const_name mem},_) $ a $ _)) =>
      null (Term.add_vars a [])
  | _ => false)

in

fun rcall_tac ctxt i =
  let fun tac ps rl i = res_inst_tac ctxt ps rl i THEN atac i
  in IHinst tac @{thms rcallTs} i end
  THEN eresolve_tac @{thms rcall_lemmas} i

fun raw_step_tac ctxt prems i =
  ares_tac (prems@type_rls) i ORELSE
  rcall_tac ctxt i ORELSE
  ematch_tac ctxt [@{thm SubtypeE}] i ORELSE
  match_tac ctxt [@{thm SubtypeI}] i

fun tc_step_tac ctxt prems = SUBGOAL (fn (Bi,i) =>
    if is_rigid_prog Bi then raw_step_tac ctxt prems i else no_tac)

fun typechk_tac ctxt rls i = SELECT_GOAL (REPEAT_FIRST (tc_step_tac ctxt rls)) i

(*** Clean up Correctness Condictions ***)

fun clean_ccs_tac ctxt =
  let fun tac ps rl i = eres_inst_tac ctxt ps rl i THEN atac i in
    TRY (REPEAT_FIRST (IHinst tac @{thms hyprcallTs} ORELSE'
      eresolve_tac ([asm_rl, @{thm SubtypeE}] @ @{thms rmIHs}) ORELSE'
      hyp_subst_tac ctxt))
  end

fun gen_ccs_tac ctxt rls i =
  SELECT_GOAL (REPEAT_FIRST (tc_step_tac ctxt rls) THEN clean_ccs_tac ctxt) i

end
*}

method_setup typechk = {*
  Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD' (typechk_tac ctxt ths))
*}

method_setup clean_ccs = {*
  Scan.succeed (SIMPLE_METHOD o clean_ccs_tac)
*}

method_setup gen_ccs = {*
  Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD' (gen_ccs_tac ctxt ths))
*}

subsection {* Evaluation *}

named_theorems eval "evaluation rules"

ML {*
fun eval_tac ths =
  Subgoal.FOCUS_PREMS (fn {context = ctxt, prems, ...} =>
    let val eval_rules = Named_Theorems.get ctxt @{named_theorems eval}
    in DEPTH_SOLVE_1 (resolve_tac (ths @ prems @ rev eval_rules) 1) end)
*}

method_setup eval = {*
  Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD' (CHANGED o eval_tac ths ctxt))
*}

lemmas eval_rls [eval] = trueV falseV pairV lamV caseVtrue caseVfalse caseVpair caseVlam

lemma applyV [eval]:
  assumes "f ---> lam x. b(x)"
    and "b(a) ---> c"
  shows "f ` a ---> c"
  unfolding apply_def by (eval assms)

lemma letV:
  assumes 1: "t ---> a"
    and 2: "f(a) ---> c"
  shows "let x be t in f(x) ---> c"
  apply (unfold let_def)
  apply (rule 1 [THEN canonical])
  apply (tactic {*
    REPEAT (DEPTH_SOLVE_1 (resolve_tac (@{thms assms} @ @{thms eval_rls}) 1 ORELSE
      etac @{thm substitute} 1)) *})
  done

lemma fixV: "f(fix(f)) ---> c \<Longrightarrow> fix(f) ---> c"
  apply (unfold fix_def)
  apply (rule applyV)
   apply (rule lamV)
  apply assumption
  done

lemma letrecV:
  "h(t,\<lambda>y. letrec g x be h(x,g) in g(y)) ---> c \<Longrightarrow>
                 letrec g x be h(x,g) in g(t) ---> c"
  apply (unfold letrec_def)
  apply (assumption | rule fixV applyV  lamV)+
  done

lemmas [eval] = letV letrecV fixV

lemma V_rls [eval]:
  "true ---> true"
  "false ---> false"
  "\<And>b c t u. \<lbrakk>b--->true; t--->c\<rbrakk> \<Longrightarrow> if b then t else u ---> c"
  "\<And>b c t u. \<lbrakk>b--->false; u--->c\<rbrakk> \<Longrightarrow> if b then t else u ---> c"
  "\<And>a b. <a,b> ---> <a,b>"
  "\<And>a b c t h. \<lbrakk>t ---> <a,b>; h(a,b) ---> c\<rbrakk> \<Longrightarrow> split(t,h) ---> c"
  "zero ---> zero"
  "\<And>n. succ(n) ---> succ(n)"
  "\<And>c n t u. \<lbrakk>n ---> zero; t ---> c\<rbrakk> \<Longrightarrow> ncase(n,t,u) ---> c"
  "\<And>c n t u x. \<lbrakk>n ---> succ(x); u(x) ---> c\<rbrakk> \<Longrightarrow> ncase(n,t,u) ---> c"
  "\<And>c n t u. \<lbrakk>n ---> zero; t ---> c\<rbrakk> \<Longrightarrow> nrec(n,t,u) ---> c"
  "\<And>c n t u x. \<lbrakk>n--->succ(x); u(x,nrec(x,t,u))--->c\<rbrakk> \<Longrightarrow> nrec(n,t,u)--->c"
  "[] ---> []"
  "\<And>h t. h$t ---> h$t"
  "\<And>c l t u. \<lbrakk>l ---> []; t ---> c\<rbrakk> \<Longrightarrow> lcase(l,t,u) ---> c"
  "\<And>c l t u x xs. \<lbrakk>l ---> x$xs; u(x,xs) ---> c\<rbrakk> \<Longrightarrow> lcase(l,t,u) ---> c"
  "\<And>c l t u. \<lbrakk>l ---> []; t ---> c\<rbrakk> \<Longrightarrow> lrec(l,t,u) ---> c"
  "\<And>c l t u x xs. \<lbrakk>l--->x$xs; u(x,xs,lrec(xs,t,u))--->c\<rbrakk> \<Longrightarrow> lrec(l,t,u)--->c"
  unfolding data_defs by eval+

subsection {* Factorial *}

schematic_lemma
  "letrec f n be ncase(n,succ(zero),\<lambda>x. nrec(n,zero,\<lambda>y g. nrec(f(x),g,\<lambda>z h. succ(h))))
   in f(succ(succ(zero))) ---> ?a"
  by eval

schematic_lemma
  "letrec f n be ncase(n,succ(zero),\<lambda>x. nrec(n,zero,\<lambda>y g. nrec(f(x),g,\<lambda>z h. succ(h))))
   in f(succ(succ(succ(zero)))) ---> ?a"
  by eval

subsection {* Less Than Or Equal *}

schematic_lemma
  "letrec f p be split(p,\<lambda>m n. ncase(m,true,\<lambda>x. ncase(n,false,\<lambda>y. f(<x,y>))))
   in f(<succ(zero), succ(zero)>) ---> ?a"
  by eval

schematic_lemma
  "letrec f p be split(p,\<lambda>m n. ncase(m,true,\<lambda>x. ncase(n,false,\<lambda>y. f(<x,y>))))
   in f(<succ(zero), succ(succ(succ(succ(zero))))>) ---> ?a"
  by eval

schematic_lemma
  "letrec f p be split(p,\<lambda>m n. ncase(m,true,\<lambda>x. ncase(n,false,\<lambda>y. f(<x,y>))))
   in f(<succ(succ(succ(succ(succ(zero))))), succ(succ(succ(succ(zero))))>) ---> ?a"
  by eval

subsection {* Reverse *}

schematic_lemma
  "letrec id l be lcase(l,[],\<lambda>x xs. x$id(xs))
   in id(zero$succ(zero)$[]) ---> ?a"
  by eval

schematic_lemma
  "letrec rev l be lcase(l,[],\<lambda>x xs. lrec(rev(xs),x$[],\<lambda>y ys g. y$g))
   in rev(zero$succ(zero)$(succ((lam x. x)`succ(zero)))$([])) ---> ?a"
  by eval

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Right Unique\<close>
theory Binary_Relations_Right_Unique
  imports
    Binary_Relations_Injective
    HOL_Syntax_Bundles_Lattices
begin

consts right_unique_on :: "'a \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> bool"

overloading
  right_unique_on_pred \<equiv> "right_unique_on :: ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool"
begin
  definition "right_unique_on_pred P R \<equiv> \<forall>x y y'. P x \<and> R x y \<and> R x y' \<longrightarrow> y = y'"
end

lemma right_unique_onI [intro]:
  assumes "\<And>x y y'. P x \<Longrightarrow> R x y \<Longrightarrow> R x y' \<Longrightarrow> y = y'"
  shows "right_unique_on P R"
  using assms unfolding right_unique_on_pred_def by blast

lemma right_unique_onD:
  assumes "right_unique_on P R"
  and "P x"
  and "R x y" "R x y'"
  shows "y = y'"
  using assms unfolding right_unique_on_pred_def by blast

consts right_unique_at :: "'a \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> bool"

overloading
  right_unique_at_pred \<equiv> "right_unique_at :: ('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
begin
  definition "right_unique_at_pred P R \<equiv> \<forall>x y y'. P y \<and> P y' \<and> R x y \<and> R x y' \<longrightarrow> y = y'"
end

lemma right_unique_atI [intro]:
  assumes "\<And>x y y'. P y \<Longrightarrow> P y' \<Longrightarrow> R x y \<Longrightarrow> R x y' \<Longrightarrow> y = y'"
  shows "right_unique_at P R"
  using assms unfolding right_unique_at_pred_def by blast

lemma right_unique_atD:
  assumes "right_unique_at P R"
  and "P y"
  and "P y'"
  and "R x y" "R x y'"
  shows "y = y'"
  using assms unfolding right_unique_at_pred_def by blast

lemma right_unique_at_rel_inv_iff_rel_injective_on [iff]:
  "right_unique_at (P :: 'a \<Rightarrow> bool) (R\<inverse> :: 'b \<Rightarrow> 'a \<Rightarrow> bool) \<longleftrightarrow> rel_injective_on P R"
  by (blast dest: right_unique_atD rel_injective_onD)

lemma rel_injective_on_rel_inv_iff_right_unique_at [iff]:
  "rel_injective_on (P :: 'a \<Rightarrow> bool) (R\<inverse> :: 'a \<Rightarrow> 'b \<Rightarrow> bool) \<longleftrightarrow> right_unique_at P R"
  by (blast dest: right_unique_atD rel_injective_onD)

lemma right_unique_on_rel_inv_iff_rel_injective_at [iff]:
  "right_unique_on (P :: 'a \<Rightarrow> bool) (R\<inverse> :: 'a \<Rightarrow> 'b \<Rightarrow> bool) \<longleftrightarrow> rel_injective_at P R"
  by (blast dest: right_unique_onD rel_injective_atD)

lemma rel_injective_at_rel_inv_iff_right_unique_on [iff]:
  "rel_injective_at (P :: 'b \<Rightarrow> bool) (R\<inverse> :: 'a \<Rightarrow> 'b \<Rightarrow> bool) \<longleftrightarrow> right_unique_on P R"
  by (blast dest: right_unique_onD rel_injective_atD)

definition "right_unique (R :: 'a \<Rightarrow> _) \<equiv> right_unique_on (\<top> :: 'a \<Rightarrow> bool) R"

lemma right_unique_eq_right_unique_on:
  "right_unique (R :: 'a \<Rightarrow> _) = right_unique_on (\<top> :: 'a \<Rightarrow> bool) R"
  unfolding right_unique_def ..

lemma right_uniqueI [intro]:
  assumes "\<And>x y y'. R x y \<Longrightarrow> R x y' \<Longrightarrow> y = y'"
  shows "right_unique R"
  unfolding right_unique_eq_right_unique_on using assms by blast

lemma right_uniqueD:
  assumes "right_unique R"
  and "R x y" "R x y'"
  shows "y = y'"
  using assms unfolding right_unique_eq_right_unique_on
  by (auto dest: right_unique_onD)

lemma right_unique_eq_right_unique_at:
  "right_unique (R :: 'a \<Rightarrow> 'b \<Rightarrow> bool) = right_unique_at (\<top> :: 'b \<Rightarrow> bool) R"
  by (intro iffI right_uniqueI) (auto dest: right_unique_atD right_uniqueD)

lemma right_unique_on_if_right_unique:
  fixes P :: "'a \<Rightarrow> bool" and R :: "'a \<Rightarrow> _"
  assumes "right_unique R"
  shows "right_unique_on P R"
  using assms by (blast dest: right_uniqueD)

lemma right_unique_at_if_right_unique:
  fixes P :: "'a \<Rightarrow> bool" and R :: "'b \<Rightarrow> 'a \<Rightarrow> bool"
  assumes "right_unique R"
  shows "right_unique_at P R"
  using assms by (blast dest: right_uniqueD)

lemma right_unique_if_right_unique_on_in_dom:
  assumes "right_unique_on (in_dom R) R"
  shows "right_unique R"
  using assms by (blast dest: right_unique_onD)

lemma right_unique_if_right_unique_at_in_codom:
  assumes "right_unique_at (in_codom R) R"
  shows "right_unique R"
  using assms by (blast dest: right_unique_atD)

corollary right_unique_on_in_dom_iff_right_unique [iff]:
  "right_unique_on (in_dom R) R \<longleftrightarrow> right_unique R"
  using right_unique_if_right_unique_on_in_dom right_unique_on_if_right_unique
  by blast

corollary right_unique_at_in_codom_iff_right_unique [iff]:
  "right_unique_at (in_codom R) R \<longleftrightarrow> right_unique R"
  using right_unique_if_right_unique_at_in_codom right_unique_at_if_right_unique
  by blast

lemma right_unique_rel_inv_iff_rel_injective [iff]:
  "right_unique R\<inverse> \<longleftrightarrow> rel_injective R"
  by (blast dest: right_uniqueD rel_injectiveD)

lemma rel_injective_rel_inv_iff_right_unique [iff]:
  "rel_injective R\<inverse> \<longleftrightarrow> right_unique R"
  by (blast dest: right_uniqueD rel_injectiveD)

paragraph \<open>Instantiatiats\<close>

lemma right_unique_eq: "right_unique (=)"
  by (rule right_uniqueI) blast

end


(* License: LGPL *)
(*
Author: Julian Parsert <julian.parsert@gmail.com>
Author: Cezary Kaliszyk
*)

theory Exchange_Economy
  imports
    "../Preferences"
    "../Utility_Functions"
    "../Argmax"
    Consumers
    Common
begin

section \<open> Exchange Economy \<close>

text \<open> Define the exchange economy model \<close>

locale exchange_economy =
  fixes consumption_set :: "('a::ordered_euclidean_space) set"
  fixes agents :: "'i set"
  fixes \<E> :: "'i \<Rightarrow> 'a"
  fixes Pref :: "'i \<Rightarrow> 'a relation"
  fixes U :: "'i \<Rightarrow> 'a \<Rightarrow> real"
  assumes cons_set_props: "pre_arrow_debreu_consumption_set consumption_set"
  assumes agent_props: "i \<in> agents \<Longrightarrow> eucl_ordinal_utility consumption_set (Pref i) (U i)"
  assumes finite_agents: "finite agents" and "agents \<noteq> {}"

sublocale exchange_economy \<subseteq> pareto_ordering agents U
  .

context exchange_economy
begin

context
begin

notation U ("U[_]")
notation Pref ("Pr[_]")
notation \<E> ("\<E>[_]")

lemma base_pref_is_ord_eucl_rpr: "i \<in> agents \<Longrightarrow> rational_preference consumption_set Pr[i]"
  by (meson exchange_economy.agent_props exchange_economy_axioms
      ord_eucl_utility_imp_rpr real_vector_rpr.have_rpr)

private abbreviation calculate_value
  where
    "calculate_value P x \<equiv> P \<bullet> x"

subsection \<open> Feasibility \<close>

definition feasible_allocation
  where
    "feasible_allocation A E \<longleftrightarrow>
      (\<Sum>i\<in>agents. A i) \<le> (\<Sum>i\<in>agents. E i)"

subsection \<open> Pareto optimality \<close>

definition pareto_optimal_endow
  where
    "pareto_optimal_endow X E \<longleftrightarrow>
              (feasible_allocation X E \<and>
              (\<nexists>X'. feasible_allocation X' E \<and> X' \<succ>Pareto X))"

subsection \<open>Competitive Equilibrium in Exchange Economy \<close>

text \<open> Competitive Equilibirum or Walrasian Equilibrium definition. \<close>

definition comp_equilib_endow
  where
    "comp_equilib_endow P X E \<equiv>
      feasible_allocation X E \<and>
      (\<forall>i \<in> agents. X i \<in> arg_max_set U[i]
        (budget_constraint (calculate_value P) consumption_set (P \<bullet> E i)))"

subsection \<open> Lemmas for final result \<close>

lemma utility_function_def[iff]:
  assumes "i \<in> agents"
  shows "U[i] x \<ge> U[i] y \<longleftrightarrow> x \<succeq>[Pr[i]] y"
proof
  have "ordinal_utility consumption_set (Pref i) (U[i])"
    using agent_props assms eucl_ordinal_utility_def by auto
  then show " U[i] y \<le>  U[i] x \<Longrightarrow> x \<succeq>[Pref i] y"
    by (meson UNIV_I cons_set_props ordinal_utility.util_def_conf
        pre_arrow_debreu_consumption_set_def)
next
  show "x \<succeq>[Pref i] y \<Longrightarrow> U[i] y \<le> U[i] x"
    by (meson agent_props assms ordinal_utility_def eucl_ordinal_utility_def)
qed

lemma budget_constraint_is_feasible:
  assumes "i \<in> agents"
  assumes "X \<in> (budget_constraint (calculate_value P) consumption_set (P \<bullet> \<E>[i]))"
  shows "P \<bullet> X \<le> P \<bullet> \<E>[i]"
  using budget_constraint_def assms
  by (simp add: budget_constraint_def)

lemma arg_max_set_therefore_no_better :
  assumes "i \<in> agents"
  assumes "x \<in> arg_max_set U[i] (budget_constraint (calculate_value P) consumption_set (P \<bullet> \<E>[i]))"
  shows "U[i] y > U[i] x \<longrightarrow> y \<notin> budget_constraint (calculate_value P) consumption_set (P \<bullet> \<E>[i])"
  by (meson no_better_in_s assms)

text \<open> Since we need no restriction on the consumption set for the First Welfare Theorem \<close>

lemma consumption_set_member: "\<forall>x. x \<in> consumption_set"
proof -
  have "\<And>(x::'a). x \<in> consumption_set"
    using cons_set_props pre_arrow_debreu_consumption_set_def
    by (simp add: pre_arrow_debreu_consumption_set_def)
  thus ?thesis
    by blast
qed

text \<open> Under the assumption of Local non-satiation, agents will utilise their entire budget. \<close>

lemma argmax_entire_budget :
  assumes "i \<in> agents"
  assumes "local_nonsatiation consumption_set Pr[i]"
  assumes "X \<in> arg_max_set U[i] (budget_constraint (calculate_value P) consumption_set (P \<bullet> \<E>[i]))"
  shows "P \<bullet> X = P \<bullet> \<E>[i]"
proof -
  have leq : "(P \<bullet> X) \<le> (P \<bullet> \<E>[i])"
  proof-
    have "X \<in> budget_constraint (calculate_value P) consumption_set (P \<bullet> \<E>[i])"
      using argmax_sol_in_s[of X "U[i]" "budget_constraint (calculate_value P) consumption_set (P \<bullet> \<E>[i])"]
        assms by auto
    thus ?thesis
      using assms(1) budget_constraint_is_feasible by blast
  qed
  have not_less: "\<not>(P \<bullet> X < P \<bullet> \<E>[i])"
  proof
    assume cpos: "(P \<bullet> X) < (P \<bullet> \<E>[i])"
    define lesS where "lesS = {x. P \<bullet> x < P \<bullet> \<E>[i]}"
    obtain e where
      e: "0 < e" "ball X e \<subseteq> lesS"
      by (metis cpos lesS_def mem_Collect_eq
          open_contains_ball_eq open_halfspace_lt)
    obtain Y where
      Y: "Y \<succ>[Pref i] X " "Y \<in> ball X e"
      using e consumption_set_member assms by blast
    have "Y \<in> consumption_set"
      using consumption_set_member by blast
    hence "Y \<in> budget_constraint (calculate_value P) consumption_set (P \<bullet> \<E>[i])"
      using budget_constraint_def e lesS_def
        less_eq_real_def Y  by fastforce
    thus False
      by (meson assms Y all_leq utility_function_def)
  qed
  show ?thesis
    using leq not_less by auto
qed

text \<open> All bundles that would be strictly preferred to any argmax result, are more expensive. \<close>

lemma pref_more_expensive:
  assumes "i \<in> agents"
  assumes "x \<in> arg_max_set U[i] (budget_constraint (calculate_value P) consumption_set (P \<bullet> \<E>[i]))"
  assumes "U[i] y > U[i] x"
  shows "y \<bullet> P > P \<bullet> \<E>[i]"
proof (rule ccontr)
  assume cpos :  "\<not>(y \<bullet> P > P \<bullet> \<E>[i])"
  then have xp_leq : "y \<bullet> P \<le> P \<bullet>  \<E>[i]"
    by auto
  hence "x \<in> budget_constraint (calculate_value P) consumption_set (P \<bullet> \<E>[i])"
    using argmax_sol_in_s[of x " U[i]" "budget_constraint (calculate_value P) consumption_set (P \<bullet> \<E>[i])"]
      assms by auto
  hence xp_in: "y \<in> budget_constraint (calculate_value P) consumption_set (P \<bullet> \<E>[i])"
  proof -
    have "P \<bullet> y \<le> P \<bullet> \<E>[i]"
      by (metis xp_leq inner_commute)
    then show ?thesis
      using consumption_set_member by (simp add: budget_constraint_def)
  qed
  hence "y \<succ>[Pref i] x"
    using arg_max_set_therefore_no_better assms by blast
  hence "y \<succ>[Pref i] x \<and> y \<in> budget_constraint (calculate_value P) consumption_set (P \<bullet> \<E>[i])"
    using xp_in by blast
  hence "x \<notin> arg_max_set U[i] (budget_constraint (calculate_value P) consumption_set (P \<bullet> \<E>[i]))"
    by (meson assms exchange_economy.arg_max_set_therefore_no_better
        exchange_economy_axioms)
  then show False
    using assms(2) by auto
qed

text \<open> Greater or equal utility implies greater or equal price. \<close>

lemma same_util_is_equal_or_more_expensive:
  assumes "i \<in> agents"
  assumes "local_nonsatiation consumption_set Pr[i]"
  assumes "x \<in> arg_max_set U[i] (budget_constraint (calculate_value P) consumption_set (P \<bullet> \<E>[i]))"
  assumes "U[i] y \<ge> U[i] x"
  shows "y \<bullet> P \<ge> P \<bullet> \<E>[i]"
proof-
  have not_in: "y \<notin> arg_max_set U[i] (budget_constraint (calculate_value P) consumption_set (P \<bullet> \<E>[i]))
    \<Longrightarrow> y \<bullet> P > P \<bullet> \<E>[i]"
  proof-
    assume "y \<notin> arg_max_set U[i] (budget_constraint (calculate_value P) consumption_set (P \<bullet> \<E>[i]))"
    then have "y \<notin> budget_constraint (calculate_value P) consumption_set (P \<bullet> \<E>[i])"
      by (meson assms leq_all_in_sol assms)
    then show ?thesis
      by (simp add: budget_constraint_def inner_commute
          consumption_set_member)
  qed
  show ?thesis
    by (metis argmax_entire_budget not_in assms(1,2,3)
        dual_order.order_iff_strict inner_commute)
qed

lemma all_in_argmax_same_price:
  assumes "i \<in> agents"
  assumes "local_nonsatiation consumption_set Pr[i]"
  assumes "x \<in> arg_max_set U[i] (budget_constraint (calculate_value P) consumption_set (P \<bullet> \<E>[i]))"
    and  "y \<in> arg_max_set U[i] (budget_constraint (calculate_value P) consumption_set (P \<bullet> \<E>[i]))"
  shows "P \<bullet> x = P \<bullet> y"
  using argmax_entire_budget assms(1) assms(2) assms(3) assms(4) by presburger

text \<open> All rationally acting agents (which is every agent by assumption)
        will not decrease his utility \<close>
lemma individual_rationalism :
  assumes "comp_equilib_endow P X \<E>"
  shows "\<forall>i \<in> agents. X i \<succeq>[Pref i] \<E>[i]"
  by (metis pref_more_expensive comp_equilib_endow_def assms
      inner_commute less_irrefl not_le utility_function_def)

lemma walras_law_per_agent :
  assumes "\<And>i. i \<in> agents \<Longrightarrow> local_nonsatiation consumption_set Pr[i]"
  assumes "comp_equilib_endow P X \<E>"
  shows "\<forall>i \<in> agents. P \<bullet> X i = P \<bullet> \<E>[i]"
  by (meson argmax_entire_budget comp_equilib_endow_def assms)

text \<open> Walras Law holds in our Exchange Economy model. It states that in an equilibrium,
       demand equals supply \<close>

lemma walras_law:
  assumes "\<And>i. i \<in> agents \<Longrightarrow> local_nonsatiation consumption_set Pr[i]"
  assumes "comp_equilib_endow P X \<E>"
  shows "(\<Sum>i\<in>agents. P \<bullet> (X i)) - (\<Sum>i\<in>agents. P \<bullet> \<E>[i]) = 0"
  using assms walras_law_per_agent by auto

lemma inner_with_ge_0: "(P::(real, 'n::finite) vec) > 0 \<Longrightarrow> A \<ge> B \<Longrightarrow>  P \<bullet> A \<ge> P \<bullet> B"
  by (metis dual_order.order_iff_strict inner_commute
      interval_inner_leI(2) ord_class.atLeastAtMost_iff)

subsection \<open> First Welfare Theorem in Exchange Economy \<close>

text \<open> We prove the first welfare theorem in our Exchange Economy model. \<close>

theorem first_welfare_theorem_exchange:
  assumes lns : "\<And>i. i \<in> agents \<Longrightarrow> local_nonsatiation consumption_set Pr[i]"
    and price_cond: "Price > 0"
  assumes equilibrium : "comp_equilib_endow Price \<X> \<E>"
  shows "pareto_optimal_endow \<X> \<E>"
proof (rule ccontr)
  assume neg_ass : "\<not> pareto_optimal_endow \<X> \<E>"
  have equili_feasible : "feasible_allocation \<X> \<E>"
    using comp_equilib_endow_def equilibrium
    by (simp add: comp_equilib_endow_def)
  have price_g_zero : "Price > 0"
    by (simp add: price_cond)
  obtain Y where
    xprime_pareto: "feasible_allocation Y \<E> \<and>
            (\<forall>i \<in> agents. U[i] (Y i) \<ge> U[i] (\<X> i)) \<and>
            (\<exists>i \<in> agents. U[i] (Y i) > U[i] (\<X> i))"
    using equili_feasible neg_ass pareto_dominating_def
      pareto_optimal_endow_def by auto
  have is_feasible : "feasible_allocation Y \<E>"
    using xprime_pareto by blast
  have all_great_eq_value : "\<forall>i \<in> agents. Price \<bullet> (Y i) \<ge> Price \<bullet> (\<X> i)"
  proof
    fix i
    assume "i \<in> agents"
    show "Price \<bullet> (Y i) \<ge> Price \<bullet> (\<X> i)"
    proof -
      have x_in_agmx : "(\<X> i) \<in> arg_max_set U[i] (budget_constraint (calculate_value Price) consumption_set (Price \<bullet> \<E>[i]))"
        by (meson \<open>i \<in> agents\<close> comp_equilib_endow_def equilibrium)
      have "( U[i]) (\<X> i) - U[i] (Y i) \<le> 0"
        using \<open>i \<in> agents\<close> xprime_pareto by auto
      hence "Price \<bullet> (\<X> i) - Price \<bullet> (Y i) \<le> 0"
        by (metis \<open>i \<in> agents\<close> argmax_entire_budget diff_le_0_iff_le x_in_agmx
            inner_commute lns same_util_is_equal_or_more_expensive)
      then show ?thesis
        by auto
    qed
  qed
  have ex_greater_value : "\<exists>i \<in> agents. Price \<bullet> (Y i) > Price \<bullet> (\<X> i)"
  proof (rule ccontr)
    assume a1 : "\<not>(\<exists>i \<in> agents. Price \<bullet> (Y i) > Price \<bullet> (\<X> i))"
    obtain i where
      obt_witness : "i \<in> agents" "U[i] (Y i) > ( U[i]) (\<X> i)"
      using xprime_pareto by blast
    have "Price \<bullet> Y i \<noteq> Price \<bullet> \<X> i"
    proof -
      have "Price \<bullet> Y i > Price \<bullet> \<E> i"
        by (metis pref_more_expensive comp_equilib_endow_def
            equilibrium inner_commute obt_witness(1) obt_witness(2))
      have "Price \<bullet> \<E> i = Price \<bullet> \<X> i"
        using equilibrium lns obt_witness(1) walras_law_per_agent by auto
      then show ?thesis
        using \<open>Price \<bullet> \<E> i < Price \<bullet> Y i\<close> by linarith
    qed
    then show False
      using a1 all_great_eq_value obt_witness(1) by fastforce
  qed
  have dominating_more_exp : "Price \<bullet> (\<Sum>i\<in>agents. Y i) > Price \<bullet> (\<Sum>i\<in>agents. \<X> i)"
  proof -
    have mp_rule : "(\<Sum>i\<in>agents. Price \<bullet> Y i) > (\<Sum>i\<in>agents. Price \<bullet> \<X> i) \<Longrightarrow> ?thesis"
      by (simp add: inner_sum_right)
    have "(\<Sum>i\<in>agents. Price \<bullet> Y i) > (\<Sum>i\<in>agents. Price \<bullet> \<X> i)"
      by (simp add: all_great_eq_value finite_agents ex_greater_value sum_strict_mono_ex1)
    thus "Price \<bullet> (\<Sum>i\<in>agents. Y i) > Price \<bullet> (\<Sum>i\<in>agents. \<X> i)"
      using mp_rule by blast
  qed
  have equili_walras_law : "Price \<bullet> (\<Sum>i\<in>agents. \<X> i) = Price \<bullet> (\<Sum>i\<in>agents. \<E>[i])"
    by (metis (mono_tags) eq_iff_diff_eq_0 equilibrium
        inner_sum_right lns walras_law)
  have dominating_feasible : "Price \<bullet> (\<Sum>i\<in>agents. \<X> i) \<ge> Price \<bullet> (\<Sum>i\<in>agents. Y i)"
    by (metis atLeastAtMost_iff dual_order.order_iff_strict equili_walras_law
        feasible_allocation_def inner_commute interval_inner_leI(1) is_feasible price_g_zero)
  show False
    using dominating_more_exp equili_walras_law dominating_feasible
    by linarith
qed

text \<open> Monotone preferences can be used instead of local non-satiation.
       Many textbooks etc. do not introduce the concept of
       local non-satiation and use monotonicity instead. \<close>

corollary first_welfare_exch_thm_monot:
  assumes "\<forall>M \<in> carrier. (\<forall>x > M. x \<in> carrier)"
  assumes "\<And>i. i \<in> agents \<Longrightarrow> monotone_preference consumption_set Pr[i]"
  and price_cond: "Price > 0"
  assumes "comp_equilib_endow Price \<X> \<E>"
  shows "pareto_optimal_endow \<X> \<E>"
  by (meson assms exchange_economy.consumption_set_member
      first_welfare_theorem_exchange exchange_economy_axioms unbounded_above_mono_imp_lns)

end

end

end