theory Chapter3
  imports "~~/src/HOL/IMP/BExp"
          "~~/src/HOL/IMP/ASM"
begin

(* Exercise 3.1. To show that asimp_const really folds all subexpressions of
the form Plus (N i ) (N j ), define a function optimal :: aexp \<Rightarrow> bool that
checks that its argument does not contain a subexpression of the form Plus
(N i ) (N j ). Then prove optimal (asimp_const a). *)

fun optimal :: "aexp \<Rightarrow> bool" where
"optimal (N n) = True" |
"optimal (V x) = True" |
"optimal (Plus (N i) (N j)) = False" |
"optimal (Plus a1 a2) = (optimal a1 & optimal a2)"

lemma "optimal (asimp_const a)"
  apply(induction a)
   apply(auto split: aexp.split)
  done

(* Exercise 3.2. In this exercise we verify constant folding for aexp where we
sum up all constants, even if they are not next to each other. For example, Plus
(N 1) (Plus (V x ) (N 2)) becomes Plus (V x ) (N 3). This goes beyond asimp.
Define a function full_asimp :: aexp \<Rightarrow> aexp that sums up all constants and
prove its correctness: aval (full_asimp a) s = aval a s. *)

(* Strategy: Add all the constants first, ignoring variables. Then, add variables
to result using asimp *)

(* Add all constants, zero out variables *)
fun addN :: "aexp \<Rightarrow> int" where
"addN (N n) = n" |
"addN (V x) = 0" |
"addN (Plus a1 a2) = addN a1 + addN a2"

(* Manually checking that addN works as expected *)
value "addN (Plus (N 1) (Plus (V x) (N 2)))"
value "addN (Plus (N 1) (Plus (N 2) (V x)))"
value "addN (Plus (N 1) (Plus (N 2) (N 2)))"
value "addN (Plus (V x) (Plus (N 2) (N 2)))"

(* Add all variables, zero out constants *)
fun addV :: "aexp \<Rightarrow> aexp" where
"addV (N n) = N 0" |
"addV (V x) = V x" |
"addV (Plus a1 a2) = Plus (addV a1) (addV a2)"

(* Manually checking that addN works as expected *)
value "addV (Plus (N 1) (Plus (N 2) (N 2)))"
value "addV (Plus (V x) (Plus (N 2) (N 2)))"
value "addV (Plus (N 1) (Plus (V x) (N 2)))"
value "addV (Plus (N 1) (Plus (N 2) (V x)))"
value "addV (Plus (V x) (Plus (V y) (N 2)))"
value "addV (Plus (V x) (Plus (N 2) (V y)))"
value "addV (Plus (N 1) (Plus (V x) (V y)))"
value "addV (Plus (V x) (Plus (V y) (V z)))"

(* Define a function that combines the results of addN and addV *)
definition addNV :: "aexp \<Rightarrow> aexp" where
"addNV a = Plus (N (addN a)) (addV a)"

lemma addNV_equals_simp [simp]: "aval (addNV a) s = aval a s"
  apply(simp add: addNV_def)
  apply(induction a)
    apply(auto)
  done

(* fun full_asimp :: "aexp \<Rightarrow> aexp" where
"full_asimp (N n) = N n" |
"full_asimp (V x) = V x" |
"full_asimp (Plus a1 (Plus a2 a3)) = plus (full_asimp a1) (plus (full_asimp a2) (full_asimp a3))" |
"full_asimp (Plus (Plus a1 a2) a3) = plus (plus (full_asimp a1) (full_asimp a2)) (full_asimp a3)" |
"full_asimp (Plus a1 a2) = plus (full_asimp a1) (full_asimp a2)"
*)

(* Use addNV to define full_asimp, simplifying the aexp before passing it to asimp *)
definition full_asimp :: "aexp \<Rightarrow> aexp" where
"full_asimp a = asimp (addNV a)"

(* Manually verify that full_asimp works as expected *)
value "full_asimp (Plus (N 1) (Plus (V x) (V y)))"
value "full_asimp (Plus (N 1) (Plus (V x) (N 2)))"
value "full_asimp (Plus (N 1) (Plus (N 2) (V x)))"
value "full_asimp (Plus (N 1) (Plus (N 2) (N 3)))"
value "full_asimp (Plus (V x) (Plus (N 2) (N 3)))"
value "full_asimp (Plus (V x) (Plus (V y) (N 3)))"
value "full_asimp (Plus (V x) (Plus (N 2) (V y)))"
value "full_asimp (Plus (V x) (Plus (V y) (V z)))"

lemma "aval (full_asimp a) s = aval a s"
  apply(simp add: full_asimp_def)
  done

(* Exercise 3.3. Substitution is the process of replacing a variable by an ex-
pression in an expression. Define a substitution function subst :: vname \<Rightarrow>
aexp \<Rightarrow> aexp \<Rightarrow> aexp such that subst x a e is the result of replacing every
occurrence of variable x by a in e. For example:

subst ''x'' (N 3) (Plus (V ''x'' ) (V ''y'' )) = Plus (N 3) (V ''y'' )

Prove the so-called substitution lemma that says that we can either
substitute first and evaluate afterwards or evaluate with an updated state:
aval (subst x a e) s = aval e (s(x := aval a s)). As a consequence prove
aval a 1 s = aval a 2 s =\<Rightarrow> aval (subst x a 1 e) s = aval (subst x a 2 e) s. *)

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"subst x a (N n) = N n" |
"subst x a (V y) = (if x = y then a else (V y))" |
"subst x a (Plus a1 a2) = Plus (subst x a a1) (subst x a a2)"

lemma subst_lemma: "aval (subst x a e) s = aval e (s (x := aval a s))"
  apply(induction e)
    apply(auto)
  done

lemma "aval a1 s = aval a2 s \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
  apply(simp add: subst_lemma)
  done

(* Exercise 3.4. Take a copy of theory AExp and modify it as follows. Extend
type aexp with a binary constructor Times that represents multiplication.
Modify the definition of the functions aval and asimp accordingly. You can
remove asimp_const. Function asimp should eliminate 0 and 1 from multi-
plications as well as evaluate constant subterms. Update all proofs concerned. *)

(* See Chapter3AExp.thy *)

(* Exercise 3.5. Define a datatype aexp2 of extended arithmetic expressions
that has, in addition to the constructors of aexp, a constructor for modelling
a C-like post-increment operation x++, where x must be a variable. Define an
evaluation function aval2 :: aexp2 \<Rightarrow> state \<Rightarrow> val \<times> state that returns both
the value of the expression and the new state. The latter is required because
post-increment changes the state.
Extend aexp2 and aval2 with a division operation. Model partiality of
division by changing the return type of aval2 to (val \<times> state) option. In
case of division by 0 let aval2 return None. Division on int is the infix div. *)

datatype aexp2 = N2 int | V2 vname | Plus2 aexp2 aexp2 | Increment2 vname | Divide2 aexp2 aexp2

(* Used this to learn how to work with the option syntax:
https://github.com/gsomix/concrete-semantics-solutions/blob/cf1b864744f80091a1f91a85b14b3d8edf7e0f9f/Chapter3.thy#L144 *)

fun aval2 :: "aexp2 \<Rightarrow> state \<Rightarrow> (val \<times> state) option" where
"aval2 (N2 n) s = Some (n, s)" |
"aval2 (V2 v) s = Some (s v, s)" |
"aval2 (Plus2 a1 a2) s = Option.bind (aval2 a1 s) (\<lambda> (a1val, s1).
                        Option.bind (aval2 a2 s1) (\<lambda> (a2val, s2).
                        Some (a1val + a2val, s2)))" |
"aval2 (Increment2 x) s = Some ((s x), s (x := (s x) + 1))" |
"aval2 (Divide2 a1 a2) s = Option.bind (aval2 a1 s) (\<lambda> (a1val, s1).
                          Option.bind (aval2 a2 s1) (\<lambda> (a2val, s2).
                          if a2val = 0 then None else Some ((a1val div a2val), s2)))"

(* Manually checking that everything works as expected *)
value "aval2 (Plus2 (Increment2 ''x'') (Divide2 (N2 10) (V2 ''x''))) (<''x'' := -1>)"
value "aval2 (Plus2 (Increment2 ''x'') (Divide2 (N2 10) (V2 ''x''))) (<''x'' := 0>)"
value "aval2 (Plus2 (Increment2 ''x'') (Divide2 (N2 10) (V2 ''x''))) (<''x'' := 1>)"
value "aval2 (Plus2 (Increment2 ''x'') (Divide2 (N2 10) (V2 ''x''))) (<''x'' := 2>)"
value "aval2 (Plus2 (Increment2 ''x'') (Divide2 (N2 10) (V2 ''x''))) (<''x'' := 3>)"
value "aval2 (Plus2 (Increment2 ''x'') (Divide2 (N2 10) (V2 ''x''))) (<''x'' := 4>)"

(* Exercise 3.6. The following type adds a LET construct to arithmetic ex-
pressions:

datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp

The LET constructor introduces a local variable: the value of LET x e 1 e 2
is the value of e 2 in the state where x is bound to the value of e 1 in the
original state. Define a function lval :: lexp \<Rightarrow> state \<Rightarrow> int that evaluates
lexp expressions. Remember s(x := i ).
Define a conversion inline :: lexp \<Rightarrow> aexp. The expression LET x e 1 e 2
is inlined by substituting the converted form of e 1 for x in the converted form
of e 2. See Exercise 3.3 for more on substitution. Prove that inline is correct
w.r.t. evaluation. *)

datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> int" where
"lval (Nl n) s = n" |
"lval (Vl v) s = s v" |
"lval (Plusl a1 a2) s = (lval a1 s) + (lval a2 s)" |
"lval (LET x e1 e2) s = lval e2 (s(x := (lval e1 s)))"

fun inline :: "lexp \<Rightarrow> aexp" where
"inline (Nl n) = N n" |
"inline (Vl v) = V v" |
"inline (Plusl a1 a2) = Plus (inline a1) (inline a2)" |
"inline (LET x e1 e2) = subst x (inline e1) (inline e2)"

lemma inline_lexp_equals_aexp: "lval e s = aval (inline e) s"
  apply(induction e arbitrary: s)
     apply(simp_all add: subst_lemma)
  done

(* Exercise 3.7. Define functions Eq, Le :: aexp \<Rightarrow> aexp \<Rightarrow> bexp and prove
bval (Eq a 1 a 2 ) s = (aval a 1 s = aval a 2 s) and bval (Le a 1 a 2) s =
(aval a 1 s \<le> aval a 2 s). *)

definition Or :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"Or b1 b2 = Not (And (Not b1) (Not b2))"

definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Eq b1 b2 = And (Not (Less b1 b2)) (Not (Less b2 b1))"

definition Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Le b1 b2 = Or (Eq b1 b2) (Less b1 b2)"

lemma "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
  apply(auto simp add: Eq_def)
  done

lemma "bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)"
  apply(auto simp add: Le_def Or_def Eq_def)
  done

(* Exercise 3.8. Consider an alternative type of boolean expressions featuring
a conditional:

datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp

First define an evaluation function ifval :: ifexp \<Rightarrow> state \<Rightarrow> bool analogously
to bval. Then define two functions b2ifexp :: bexp \<Rightarrow> ifexp and if2bexp ::
ifexp \<Rightarrow> bexp and prove their correctness, i.e., that they preserve the value
of an expression. *)

datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
"ifval (Bc2 v) s = v" |
"ifval (If i1 i2 i3) s = (if (ifval i1 s) then (ifval i2 s) else (ifval i3 s))" |
"ifval (Less2 a1 a2) s = (aval a1 s < aval a2 s)"

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
"b2ifexp (Bc v) = (Bc2 v)" |
"b2ifexp (Not b) = (If (b2ifexp b) (Bc2 False) (Bc2 True))" |
"b2ifexp (And b1 b2) = (If (b2ifexp b1) (
                        (If (b2ifexp b2) (Bc2 True) (Bc2 False))
                       ) (Bc2 False))" |
"b2ifexp (Less a1 a2) = Less2 a1 a2"

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
"if2bexp (Bc2 v) = (Bc v)" |
"if2bexp (If i1 i2 i3) = Or (And (if2bexp i1) (if2bexp i2)) (And (Not (if2bexp i1)) (if2bexp i3))" |
"if2bexp (Less2 a1 a2) = Less a1 a2"

lemma ifval_b2ifexp: "ifval (b2ifexp b) s = bval b s"
  apply(induction b)
     apply(simp_all)
  done

lemma bval_if2bexp: "bval (if2bexp i) s = ifval i s"
  apply(induction i)
    apply(simp_all add: Or_def)
  done

(* Exercise 3.9. Define a new type of purely boolean expressions

datatype pbexp = VAR vname | NOT pbexp | AND pbexp pbexp | OR pbexp pbexp

where variables range over values of type bool:

fun pbval :: "pbexp \<Rightarrow> (vname \<Rightarrow> bool) \<Rightarrow> bool" where
"pbval (VAR x ) s = s x" |
"pbval (NOT b) s = (\<not> pbval b s)" |
"pbval (AND b 1 b 2 ) s = (pbval b1 s \<and> pbval b 2 s)" |
"pbval (OR b 1 b 2 ) s = (pbval b1 s \<or> pbval b 2 s)"

Define a function is_nnf :: pbexp \<Rightarrow> bool that checks whether a boolean
expression is in NNF (negation normal form), i.e., if NOT is only applied
directly to VARs. Also define a function nnf :: pbexp \<Rightarrow> pbexp that converts
a pbexp into NNF by pushing NOT inwards as much as possible. Prove that
nnf preserves the value (pbval (nnf b) s = pbval b s) and returns an NNF
(is_nnf (nnf b)).
An expression is in DNF (disjunctive normal form) if it is in NNF and if
no OR occurs below an AND. Define a corresponding test is_dnf :: pbexp \<Rightarrow>
bool. An NNF can be converted into a DNF in a bottom-up manner. The crit-
ical case is the conversion of AND b 1 b 2 . Having converted b 1 and b 2 , apply
distributivity of AND over OR. Define a conversion function dnf_of_nnf ::
pbexp \<Rightarrow> pbexp from NNF to DNF. Prove that your function preserves the
value (pbval (dnf_of_nnf b) s = pbval b s) and converts an NNF into a
DNF (is_nnf b =\<Rightarrow> is_dnf (dnf_of_nnf b)). *)

datatype pbexp = VAR vname | NOT pbexp | AND pbexp pbexp | OR pbexp pbexp

fun pbval :: "pbexp \<Rightarrow> (vname \<Rightarrow> bool) \<Rightarrow> bool" where
"pbval (VAR x) s = s x" |
"pbval (NOT b) s = (\<not> pbval b s)" |
"pbval (AND b1 b2 ) s = (pbval b1 s \<and> pbval b2 s)" |
"pbval (OR b1 b2 ) s = (pbval b1 s \<or> pbval b2 s)"

fun is_nnf :: "pbexp \<Rightarrow> bool" where
"is_nnf (VAR x) = True" |
"is_nnf (NOT (VAR x)) = True" |
"is_nnf (NOT b) = False" |
"is_nnf (AND b1 b2) = (is_nnf b1 \<and> is_nnf b2)" |
"is_nnf (OR b1 b2) = (is_nnf b1 \<or> is_nnf b2)"

fun nnf :: "pbexp \<Rightarrow> pbexp" where
"nnf (VAR x) = (VAR x)" |
"nnf (NOT (VAR x)) = (NOT (VAR x))" |
"nnf (NOT (OR b1 b2)) = AND (nnf (NOT b1)) (nnf (NOT b2))" |
"nnf (NOT (AND b1 b2)) = OR (nnf (NOT b1)) (nnf (NOT b2))" |
"nnf (NOT (NOT b)) = nnf b" |
"nnf (AND b1 b2) = AND (nnf b1) (nnf b2)" |
"nnf (OR b1 b2) = OR (nnf b1) (nnf b2)"

lemma ppbval_nnf [simp]: "pbval (nnf b) s = pbval b s"
  apply(induction b arbitrary: s rule: nnf.induct)
        apply(simp_all)
  done

lemma is_nnf_nnf: "is_nnf (nnf b)"
  apply(induction b rule: nnf.induct)
        apply(simp_all)
  done

fun is_dnf :: "pbexp \<Rightarrow> bool"  where
"is_dnf (AND (OR _ _) _) = False" |
"is_dnf (AND _ (OR _ _)) = False" |
"is_dnf (AND b1 b2) = (is_dnf b1 \<and> is_dnf b2)" |
"is_dnf (OR b1 b2) = (is_dnf b1 \<or> is_dnf b2)" |
"is_dnf b = is_nnf b"

(* Apply distributivity of AND over OR *)
fun dnf_dist :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
"dnf_dist c (OR b1 b2) = OR (dnf_dist c b1) (dnf_dist c b2)" |
"dnf_dist (OR b1 b2) c = OR (dnf_dist b1 c) (dnf_dist b2 c)" |
"dnf_dist b1 b2 = AND b1 b2"

fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
"dnf_of_nnf (VAR x) = (VAR x)" |
"dnf_of_nnf (NOT x) = (NOT x)" |
"dnf_of_nnf (AND b1 b2) = dnf_dist (dnf_of_nnf b1) (dnf_of_nnf b2)" |
"dnf_of_nnf (OR b1 b2) = OR (dnf_of_nnf b1) (dnf_of_nnf b2)"

lemma pbval_dnf_dist: "pbval (dnf_dist b1 b2) s = pbval (AND b1 b2) s"
  apply(induction b1 b2 rule: dnf_dist.induct)
              apply(auto)
  done

lemma is_dnf_dnf_dist: "is_dnf b1 \<and> is_dnf b2 \<Longrightarrow> is_dnf (dnf_dist b1 b2)"
  apply(induction b1 b2 rule: dnf_dist.induct)
              apply(auto)
  done

lemma pbval_dnf_of_nnf [simp]:  "(pbval (dnf_of_nnf b) s = pbval b s)"
  apply(induction b rule:dnf_of_nnf.induct)
     apply(simp_all add: pbval_dnf_dist)
  done

lemma is_dnf_dnf_of_nnf: "(is_nnf b ==> is_dnf (dnf_of_nnf b))"
  apply(induction b rule:dnf_of_nnf.induct)
     apply(auto simp add: is_dnf_dnf_dist)
  done

(* Exercise 3.11. This exercise is about a register machine and compiler for
aexp. The machine instructions are

datatype instr = LDI int reg | LD vname reg | ADD reg reg

where type reg is a synonym for nat. Instruction LDI i r loads i into register
r, LD x r loads the value of x into register r, and ADD r 1 r 2 adds register
r 2 to register r 1 .
Define the execution of an instruction given a state and a register state
(= function from registers to integers); the result is the new register state:

fun exec1 :: instr \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int ) \<Rightarrow> reg \<Rightarrow> int

Define the execution exec of a list of instructions as for the stack machine.
The compiler takes an arithmetic expression a and a register r and pro-
duces a list of instructions whose execution places the value of a into r. The
registers > r should be used in a stack-like fashion for intermediate results,
the ones < r should be left alone. Define the compiler and prove it correct:
t. *)

type_synonym reg = nat

datatype instr = LDI int reg | LD vname reg | ADD reg reg

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
"exec1 (LDI i r) _ rs = rs(r := i)" |
"exec1 (LD v r) s rs = rs(r := s v)" |
"exec1 (ADD r1 r2) _ rs = rs(r1 := rs r1 + rs r2)"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
"exec [] _ rs = rs" |
"exec (i#is) s rs = exec is s (exec1 i s rs)"

lemma reg_exec_append: "exec (is1@is2) s rs = exec is2 s (exec is1 s rs)"
  apply(induction is1 arbitrary: rs)
  apply(simp_all)
done

fun comp :: "aexp \<Rightarrow> reg \<Rightarrow> instr list" where
"comp (N n) r = [LDI n r]" |
"comp (V v) r = [LD v r]" |
"comp (Plus a1 a2) r = comp a1 r @ comp a2 (r+1) @ [ADD r (r+1)]"

lemma reg_exec_order: "r2 > r1 \<Longrightarrow> exec (comp a r2) s rs r1 = rs r1"
  apply(induction a arbitrary: r1 r2 rs)
    apply(auto simp add: reg_exec_append)
  done

theorem "exec (comp a r) s rs r = aval a s"
  apply(induction a arbitrary: r rs)
    apply(auto simp add: reg_exec_append reg_exec_order)
  done

(* Exercise 3.12. This is a variation on the previous exercise. Let the instruc-
tion set be

datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg

All instructions refer implicitly to register 0 as the source (MV0) or target
(all others). Define a compiler pretty much as explained above except that
the compiled code leaves the value of the expression in register 0. Prove that
exec (comp a r ) s rs 0 = aval a s. *)

datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg

fun exec01 :: "instr0 \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
"exec01 (LDI0 i) _ rs = rs(0 := i)" |
"exec01 (LD0 v) s rs = rs(0 := s v)" |
"exec01 (MV0 r) s rs = rs(r := rs 0)" |
"exec01 (ADD0 r) _ rs = rs(0 := rs 0 + rs r)"

fun exec0 :: "instr0 list \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
"exec0 [] _ rs = rs" |
"exec0 (i#is) s rs = exec0 is s (exec01 i s rs)"

lemma reg0_exec_append: "exec0 (is1@is2) s rs = exec0 is2 s (exec0 is1 s rs)"
  apply(induction is1 arbitrary: rs)
  apply(simp_all)
done

fun comp0 :: "aexp \<Rightarrow> reg \<Rightarrow> instr0 list" where
"comp0 (N n) _ = [LDI0 n]" |
"comp0 (V v) _ = [LD0 v]" |
"comp0 (Plus a1 a2) r = comp0 a1 r @ [MV0 (r+1)] @ comp0 a2 (r+1) @ [ADD0 (r+1)]"

lemma reg0_exec_order: "(r1 \<noteq> 0 \<and> r2 \<ge> r1) \<Longrightarrow> exec0 (comp0 a r2) s rs r1 = rs r1"
  apply(induction a arbitrary: r1 r2 rs)
    apply(auto simp add: reg0_exec_append)
  done

theorem "exec0 (comp0 a r) s rs 0 = aval a s"
  apply(induction a arbitrary: r rs)
    apply(auto simp add: reg0_exec_append reg0_exec_order)
  done

end


(*
  Title: Galois Connections
  Author: Georg Struth
  Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Galois Connections\<close>

theory Galois_Connections
  imports Order_Lattice_Props

begin

subsection \<open>Definitions and Basic Properties\<close>

text \<open>The approach follows the Compendium of Continuous Lattices~\cite{GierzHKLMS80}, without attempting completeness.
First, left and right adjoints of a Galois connection are defined.\<close>

definition adj :: "('a::ord \<Rightarrow> 'b::ord) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool" (infixl "\<stileturn>" 70) where
  "(f \<stileturn> g) = (\<forall>x y. (f x \<le> y) = (x \<le> g y))"

definition "ladj (g::'a::Inf \<Rightarrow> 'b::ord) = (\<lambda>x. \<Sqinter>{y. x \<le> g y})"

definition "radj (f::'a::Sup \<Rightarrow> 'b::ord)  = (\<lambda>y. \<Squnion>{x. f x \<le> y})"

lemma ladj_radj_dual:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::ord_with_dual"
  shows "ladj f x = \<partial> (radj (\<partial>\<^sub>F f) (\<partial> x))"
proof-
  have "ladj f x = \<partial> (\<Squnion>(\<partial> ` {y. \<partial> (f y) \<le> \<partial> x}))"
    unfolding ladj_def by (metis (no_types, lifting) Collect_cong Inf_dual_var dual_dual_ord dual_iff)
  also have "... =  \<partial> (\<Squnion>{\<partial> y|y. \<partial> (f y) \<le> \<partial> x})"
    by (simp add: setcompr_eq_image)
  ultimately show ?thesis
    unfolding ladj_def radj_def map_dual_def comp_def
    by (smt Collect_cong invol_dual_var)
qed

lemma radj_ladj_dual:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::ord_with_dual"
  shows "radj f x = \<partial> (ladj (\<partial>\<^sub>F f) (\<partial> x))"
  by (metis fun_dual5 invol_dual_var ladj_radj_dual map_dual_def)

lemma ladj_prop:
  fixes g :: "'b::Inf \<Rightarrow> 'a::ord_with_dual"
  shows "ladj g = Inf \<circ> (-`) g \<circ> \<up>"
  unfolding ladj_def vimage_def upset_prop fun_eq_iff comp_def by simp

lemma radj_prop:
  fixes f :: "'b::Sup \<Rightarrow> 'a::ord"
  shows "radj f = Sup \<circ> (-`) f \<circ> \<down>"
  unfolding radj_def vimage_def downset_prop fun_eq_iff comp_def by simp

text \<open>The first set of properties holds without any sort assumptions.\<close>

lemma adj_iso1: "f \<stileturn> g \<Longrightarrow> mono f"
  unfolding adj_def mono_def by (meson dual_order.refl dual_order.trans)

lemma adj_iso2: "f \<stileturn> g \<Longrightarrow> mono g"
  unfolding adj_def mono_def by (meson dual_order.refl dual_order.trans)

lemma adj_comp: "f \<stileturn> g \<Longrightarrow> adj h k \<Longrightarrow> (f \<circ> h) \<stileturn> (k \<circ> g)"
  by (simp add: adj_def)

lemma adj_dual:
  fixes f :: "'a::ord_with_dual \<Rightarrow> 'b::ord_with_dual"
  shows "f \<stileturn> g = (\<partial>\<^sub>F g) \<stileturn> (\<partial>\<^sub>F f)"
  unfolding adj_def map_dual_def comp_def by (metis (mono_tags, hide_lams) dual_dual_ord invol_dual_var)

subsection \<open>Properties for (Pre)Orders\<close>

text \<open>The next set of properties holds in preorders or orders.\<close>

lemma adj_cancel1:
  fixes f :: "'a::preorder \<Rightarrow> 'b::ord"
  shows "f \<stileturn> g \<Longrightarrow> f \<circ> g \<le> id"
  by (simp add: adj_def le_funI)

lemma adj_cancel2:
  fixes f :: "'a::ord \<Rightarrow> 'b::preorder"
  shows "f \<stileturn> g \<Longrightarrow> id \<le> g \<circ> f"
  by (simp add: adj_def eq_iff le_funI)

lemma adj_prop:
  fixes f :: "'a::preorder \<Rightarrow>'a"
  shows "f \<stileturn> g \<Longrightarrow> f \<circ> g \<le> g \<circ> f"
  using adj_cancel1 adj_cancel2 order_trans by blast

lemma adj_cancel_eq1:
  fixes f :: "'a::preorder \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> f \<circ> g \<circ> f = f"
  unfolding adj_def comp_def fun_eq_iff by (meson eq_iff order_refl order_trans)

lemma adj_cancel_eq2:
  fixes f :: "'a::order \<Rightarrow> 'b::preorder"
  shows "f \<stileturn> g \<Longrightarrow> g \<circ> f \<circ> g = g"
  unfolding adj_def comp_def fun_eq_iff by (meson eq_iff order_refl order_trans)

lemma adj_idem1:
  fixes f :: "'a::preorder \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> (f \<circ> g) \<circ> (f \<circ> g) = f \<circ> g"
  by (simp add: adj_cancel_eq1 rewriteL_comp_comp)

lemma adj_idem2:
  fixes f :: "'a::order \<Rightarrow> 'b::preorder"
  shows "f \<stileturn> g \<Longrightarrow> (g \<circ> f) \<circ> (g \<circ> f) = g \<circ> f"
  by (simp add: adj_cancel_eq2 rewriteL_comp_comp)

lemma adj_iso3:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> mono (f \<circ> g)"
   by (simp add: adj_iso1 adj_iso2 monoD monoI)

lemma adj_iso4:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> mono (g \<circ> f)"
  by (simp add: adj_iso1 adj_iso2 monoD monoI)

lemma adj_canc1:
  fixes f :: "'a::order \<Rightarrow> 'b::ord"
  shows "f \<stileturn> g \<Longrightarrow> ((f \<circ> g) x = (f \<circ> g) y \<longrightarrow> g x = g y)"
  unfolding adj_def comp_def by (metis eq_iff)

lemma adj_canc2:
  fixes f :: "'a::ord \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> ((g \<circ> f) x = (g \<circ> f) y \<longrightarrow> f x = f y)"
  unfolding adj_def comp_def by (metis eq_iff)

lemma adj_sur_inv:
  fixes f :: "'a::preorder \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> ((surj f) = (f \<circ> g = id))"
  unfolding adj_def surj_def comp_def by (metis eq_id_iff eq_iff order_refl order_trans)

lemma adj_surj_inj:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> ((surj f) = (inj g))"
  unfolding adj_def inj_def surj_def by (metis eq_iff order_trans)

lemma adj_inj_inv:
  fixes f :: "'a::preorder \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> ((inj f) = (g \<circ> f = id))"
  by (metis adj_cancel_eq1 eq_id_iff inj_def o_apply)

lemma adj_inj_surj:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> ((inj f) = (surj g))"
  unfolding adj_def inj_def surj_def by (metis eq_iff order_trans)

lemma surj_id_the_inv: "surj f \<Longrightarrow> g \<circ> f = id \<Longrightarrow> g = the_inv f"
  by (metis comp_apply id_apply inj_on_id inj_on_imageI2 surj_fun_eq the_inv_f_f)

lemma inj_id_the_inv: "inj f \<Longrightarrow> f \<circ> g = id \<Longrightarrow> f = the_inv g"
proof -
  assume a1: "inj f"
  assume "f \<circ> g = id"
  hence "\<forall>x. the_inv g x = f x"
    using a1 by (metis (no_types) comp_apply eq_id_iff inj_on_id inj_on_imageI2 the_inv_f_f)
  thus ?thesis
    by presburger
qed

subsection \<open>Properties for Complete Lattices\<close>

text \<open>The next laws state that a function between complete lattices preserves infs
  if and only if it has a lower adjoint.\<close>

lemma radj_Inf_pres:
  fixes g :: "'b::complete_lattice \<Rightarrow> 'a::complete_lattice"
  shows "(\<exists>f. f \<stileturn> g) \<Longrightarrow> Inf_pres g"
  apply (rule antisym, simp_all add: le_fun_def adj_def, safe)
  apply (meson INF_greatest Inf_lower dual_order.refl dual_order.trans)
  by (meson Inf_greatest dual_order.refl le_INF_iff)

lemma ladj_Sup_pres:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  shows "(\<exists>g. f \<stileturn> g) \<Longrightarrow> Sup_pres f"
  using Sup_pres_map_dual_var adj_dual radj_Inf_pres by blast

lemma radj_adj:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "f \<stileturn> g \<Longrightarrow> g = (radj f)"
  unfolding adj_def radj_def by (metis (mono_tags, lifting) cSup_eq_maximum eq_iff mem_Collect_eq)

lemma ladj_adj:
  fixes g :: "'b::complete_lattice_with_dual \<Rightarrow> 'a::complete_lattice_with_dual"
  shows "f \<stileturn> g \<Longrightarrow> f = (ladj g)"
  unfolding adj_def ladj_def by (metis (no_types, lifting) cInf_eq_minimum eq_iff mem_Collect_eq)

lemma Inf_pres_radj_aux:
  fixes g :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "Inf_pres g \<Longrightarrow> (ladj g) \<stileturn> g"
proof-
  assume a: "Inf_pres g"
  {fix x y
   assume b: "ladj g x \<le> y"
  hence "g (ladj g x) \<le> g y"
    by (simp add: Inf_subdistl_iso a monoD)
  hence "\<Sqinter>{g y |y. x \<le> g y} \<le> g y"
    by (metis a comp_eq_dest_lhs setcompr_eq_image ladj_def)
  hence "x \<le> g y"
    using dual_order.trans le_Inf_iff by blast
  hence "ladj g x \<le> y \<longrightarrow> x \<le> g y"
    by simp}
  thus ?thesis
    unfolding adj_def ladj_def by (meson CollectI Inf_lower)
qed

lemma Sup_pres_ladj_aux:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  shows "Sup_pres f \<Longrightarrow> f \<stileturn> (radj f)"
  by (metis (no_types, hide_lams) Inf_pres_radj_aux Sup_pres_map_dual_var adj_dual fun_dual5 map_dual_def radj_adj)

lemma Inf_pres_radj:
  fixes g :: "'b::complete_lattice \<Rightarrow> 'a::complete_lattice"
  shows "Inf_pres g \<Longrightarrow> (\<exists>f. f \<stileturn> g)"
  using Inf_pres_radj_aux by fastforce

lemma Sup_pres_ladj:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  shows "Sup_pres f \<Longrightarrow> (\<exists>g. f \<stileturn> g)"
  using Sup_pres_ladj_aux by fastforce

lemma Inf_pres_upper_adj_eq:
  fixes g :: "'b::complete_lattice \<Rightarrow> 'a::complete_lattice"
  shows "(Inf_pres g) = (\<exists>f. f \<stileturn> g)"
  using radj_Inf_pres Inf_pres_radj by blast

lemma Sup_pres_ladj_eq:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  shows  "(Sup_pres f) = (\<exists>g. f \<stileturn> g)"
  using Sup_pres_ladj ladj_Sup_pres by blast

lemma Sup_downset_adj: "(Sup::'a::complete_lattice set \<Rightarrow> 'a) \<stileturn> \<down>"
  unfolding adj_def downset_prop Sup_le_iff by force

lemma Sup_downset_adj_var: "(Sup (X::'a::complete_lattice set) \<le> y) = (X \<subseteq> \<down>y)"
  using Sup_downset_adj adj_def by auto

text \<open>Once again many statements arise by duality, which Isabelle usually picks up.\<close>

end


theory WholeChapter imports Main begin

section "Chapter 5"

subsection "Exercise 5.1"

lemma
  assumes T : "\<forall> x y. T x y \<or> T y x"
    and A: "\<forall> x y. A x y \<and> A y x \<longrightarrow> x = y"
    and TA: "\<forall> x y. T x y \<longrightarrow> A x y"
    and axy:"A b c"
  shows "T b c"
proof cases
  (* NB: the positive case has to come first, negative case comes second *)
  assume "A b c \<and> A c b"
  hence "b = c" using A by blast
  thus "T b c"
    using T by blast
next
  assume "\<not>(A b c \<and> A c b)"
  hence "\<not>A c b"
    by (simp add: axy)
  moreover have "\<forall> x y. T y x \<or> A x y" using T TA by blast
  ultimately show "T b c" by metis
qed

subsection "Exercise 5.2"

lemma "(\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs)
     \<or> (\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
proof cases
  assume "even (length xs)"
  then obtain halfLength where hl:"2 * halfLength = length xs"
    by (metis evenE)
  then obtain ys\<^sub>p where y:"ys\<^sub>p = take halfLength xs" by simp
  then obtain zs\<^sub>p where z:"zs\<^sub>p = drop halfLength xs" by simp
  have "ys\<^sub>p @ zs\<^sub>p = xs"
    by (simp add: y z)
  moreover have "length ys\<^sub>p = length zs\<^sub>p" using hl y z by fastforce
  ultimately show ?thesis by fastforce
next
  assume "\<not>even (length xs)"
  hence "odd (length xs)" by simp
  then obtain halfLength where hl:"2 * halfLength + 1 = length xs"
    by (metis oddE)
  then obtain ys\<^sub>p where y:"ys\<^sub>p = take (halfLength + 1) xs" by simp
  then obtain zs\<^sub>p where z:"zs\<^sub>p = drop (halfLength + 1) xs" by simp
  have "ys\<^sub>p @ zs\<^sub>p = xs"
    by (simp add: y z)
  moreover have "length ys\<^sub>p = length zs\<^sub>p + 1" using hl y z by fastforce
  ultimately show ?thesis by fastforce
qed

subsection "unnamed 'simple' Exercise"

inductive ev :: "nat \<Rightarrow> bool" where
  ev0: "ev 0" |
  evSS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

lemma "\<not>ev (Suc(Suc(Suc 0)))"
proof
  assume "ev (Suc (Suc (Suc 0)))"
  hence "ev (Suc 0)"
    using ev.cases by blast
  thus False by cases
qed

  (* I can't reproduce the proof on page 68.   *)
lemma "ev (Suc m) \<Longrightarrow> \<not>ev m"
proof(induction "Suc m" arbitrary: m rule:ev.induct)
  (* case ev0 does not exist *)
  case (evSS n)
  then show ?case
  proof - (* (rule (* classical *) ccontr) *)
    assume "ev (Suc n)"
      (*     thus False sorry
  qed
qed *)
    oops

lemma "ev (Suc m) \<Longrightarrow> \<not>ev m"
proof(induction "Suc m" arbitrary: m rule:ev.induct)
  case (evSS n)
  then show ?case
    using ev.cases by auto
qed

subsection "Exercise 5.3"

  (* rule inversion *)
lemma
  assumes a:"ev(Suc(Suc n))"
  shows "ev n"
proof -
  from a show "ev n"
  proof cases
    case evSS
    then show ?thesis by simp
  qed
qed

  (* Can I do the same proof with induction? ... No.  *)
  (* lemma
  assumes a:"ev(Suc(Suc n))"
  shows "ev n"
proof(induction rule: ev.induct)
  (* Failed to apply initial proof method  *)
 *)

subsection "Exercise 5.4"

lemma "\<not> ev (Suc (Suc (Suc 0)))"
proof
  assume "ev (Suc (Suc (Suc 0)))"
  thus False
  proof cases
    assume "ev (Suc 0)"
    thus False
    proof cases
    qed
  qed
qed

subsection "Exercise 5.5"

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
  refl: "star r x x" |
  step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
  refl: "iter r 0 x x" |
  step: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

lemma "iter r n x y \<Longrightarrow> star r x y"
proof(induction rule: iter.induct)
  case (refl x)
  then show ?case using star.refl by fast
next
  case (step x y n z)
  then show ?case by (meson star.step)
qed

subsection "Exercise 5.6"

fun elems :: "'a list \<Rightarrow> 'a set" where
  "elems [] = {}" |
  "elems (x # xs) = insert x (elems xs)"

lemma "x \<in> elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ (x # zs) \<and> x \<notin> elems ys"
proof(induction xs)
  case Nil
  then show ?case by simp
next
  fix a xs
  let "?case" = "\<exists>ys zs. a # xs = ys @ x # zs \<and> x \<notin> elems ys"
  assume IH : "x \<in> elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"
    and prems : "x \<in> elems (a # xs)"
  then show ?case
  proof cases
    assume xa:"x = a"
    moreover obtain yp :: "'a list" where yp:"yp = []" by simp
    moreover obtain zp :: "'a list" where zp:"zp = xs" by simp
    ultimately have "a # xs = yp @ x # zp \<and> x \<notin> elems yp" by simp
    then show ?thesis by blast
  next
    assume "x \<noteq> a"
    moreover then obtain ys zs where "xs = ys @ (x # zs) \<and> x \<notin> elems ys"
      using IH prems by auto
    moreover obtain ays where "ays = a # ys" by simp
    ultimately have "a # xs = ays @ x # zs \<and> x \<notin> elems ays" by auto
    thus ?thesis by blast
  qed
qed

subsection "Exercise 5.7"

  (* copied from exercise 4.5 *)

datatype alpha = a | b

inductive gram_S :: "alpha list \<Rightarrow> bool" where
  empty: "gram_S []" |
  aSb: "gram_S w \<Longrightarrow> gram_S (a # w @ [b])" |
  SS: "gram_S w\<^sub>0 \<Longrightarrow> gram_S w\<^sub>1 \<Longrightarrow> gram_S (w\<^sub>0 @ w\<^sub>1)"

  (* end of copy-pasta *)

  (* Is the list a balanced list of parens? *)
  (* n (the first arg) is number of open parens (number of unmatched a's) *)
fun balanced :: "nat \<Rightarrow> alpha list \<Rightarrow> bool" where
  "balanced 0 [] = True" |
  "balanced _ [] = False" |
  "balanced n (a # rest) = balanced (Suc n) rest" |
  "balanced 0 (b # rest) = False" |
  "balanced (Suc n) (b # rest) = balanced n rest"

value "balanced 0 [a,a,b,b]"
value "balanced 0 [a,b,a,b]"

value "balanced 0 [a,b,b,b]"
value "balanced 0 [a,a,a,b,b]"
value "balanced 0 [a,a,b,b,b]"
value "balanced 0 [a,a,b]"

lemma insert_ab_middle_of_S:  "gram_S (xs @ ys) \<Longrightarrow> gram_S (xs @ [a, b] @ ys)"
proof(induction "(xs @ ys)" arbitrary: xs ys rule: gram_S.induct)
  case empty
  then show ?case
    using aSb gram_S.empty by force
next
  fix w xs ys
  let "?case" = "gram_S (xs @ [a, b] @ ys)"
  assume hyps:
    "gram_S w"
    "\<And>fs gs. w = fs @ gs \<Longrightarrow> gram_S (fs @ [a, b] @ gs)"
    "a # w @ [b] = xs @ ys"
  then show ?case
  proof(cases "length xs > 0")
    case x_nontrivial:True
    then show ?thesis
    proof(cases "length ys > 0")
      case y_nontrivial:True
      obtain fs gs where fs:"fs = drop 1 xs" and gs:"gs = butlast ys" by simp
      hence "gram_S (fs @ [a, b] @ gs)"
        by (metis One_nat_def butlast_append butlast_snoc drop_0 drop_Suc hyps(2) hyps(3) length_greater_0_conv list.sel(3) tl_append2 x_nontrivial y_nontrivial)
      hence gram_all:"gram_S (a # fs @ [a, b] @ gs @ [b])"
        by (metis append.assoc gram_S.simps)
      moreover have "a # fs = xs"
        using fs x_nontrivial
        by (metis Cons_nth_drop_Suc One_nat_def append_eq_Cons_conv drop_0 hyps(3)
            length_greater_0_conv nth_Cons_0)
      moreover have "gs @ [b] = ys"
        using gs y_nontrivial
        by (metis hyps(3) last.simps last_appendR length_greater_0_conv snoc_eq_iff_butlast)
      ultimately show ?thesis by auto
    next
      case False
      hence "length ys = 0" by simp
      then show ?thesis
        by (metis False SS aSb append_Nil append_Nil2 empty hyps(1) hyps(3) length_greater_0_conv)
    qed
  next
    case False
    hence "length xs = 0" by simp
    then show ?thesis
      by (metis False SS aSb append_self_conv2 empty hyps(1) hyps(3) length_greater_0_conv)
  qed
next
  fix w\<^sub>0 w\<^sub>1 xs ys
  let "?case" = "gram_S (xs @ [a, b] @ ys)"
  assume hyps:
    "gram_S w\<^sub>0"
    "\<And>fs gs. w\<^sub>0 = fs @ gs \<Longrightarrow> gram_S (fs @ [a, b] @ gs)"
    "gram_S w\<^sub>1"
    "\<And>fs gs. w\<^sub>1 = fs @ gs \<Longrightarrow> gram_S (fs @ [a, b] @ gs)"
    "w\<^sub>0 @ w\<^sub>1 = xs @ ys"
    (* We have no proof that w\<^sub>0=xs, so while we can easily prove
      gram_S (w\<^sub>0 @ [a,b] @ w\<^sub>1)
      It does us no good, without said proof. *)
  moreover have sab:"gram_S [a,b]"
    using aSb empty by fastforce
  ultimately show ?case
  proof(cases "length w\<^sub>0 = length xs")
    case True
    then show ?thesis
      by (metis SS append_eq_append_conv hyps(1) hyps(3) hyps(5) sab)
  next
    case neq:False
    then show ?thesis
    proof(cases "length w\<^sub>0 < length xs")
      case True
        (* Then if we inserted [a,b] after xs, we'd be inserting it into the middle of w\<^sub>1. Prove
        that's ok. *)
      then obtain len_w1_prefix where lwp:"len_w1_prefix = length xs - length w\<^sub>0" by simp
      obtain lh rh where lhrh:"lh = w\<^sub>0 @ (take len_w1_prefix w\<^sub>1) \<and> rh = (drop len_w1_prefix w\<^sub>1)" by simp
      hence "gram_S (lh @ [a,b] @ rh)"
        using SS hyps(1) hyps(4) by auto
      moreover have "lh = xs \<and> rh = ys"
        by (metis True append_eq_conv_conj append_self_conv2 drop_all drop_append hyps(5) less_or_eq_imp_le lhrh lwp take_all take_append)
      ultimately show ?thesis by simp
    next
      case False
      hence "length w\<^sub>0 > length xs"
        using neq by auto
          (* Then if we inserted [a,b] after xs, we'd be inserting it into the middle of w\<^sub>0. Prove
        that's ok. *)
      then obtain len_xs where "len_xs = length xs" by simp
      moreover obtain lh rh where "lh = (take len_xs w\<^sub>0) \<and> rh = (drop len_xs w\<^sub>0) @ w\<^sub>1" by simp
      moreover hence glh:"gram_S (lh @ [a,b] @ rh)"
        by (metis append.assoc append_take_drop_id gram_S.simps hyps(2) hyps(3))
      ultimately have "lh = xs \<and> rh = ys"
        by (metis False append_eq_append_conv_if hyps(5) le_neq_implies_less)
      thus ?thesis using glh by simp
    qed
  qed
qed

  (* The `a` in `replicate n a` is the first constructor of datatype alpha *)
lemma balanced_implies_S:"balanced n string \<Longrightarrow> gram_S (replicate n a @ string)"
proof(induction n string rule: balanced.induct)
  case 1
  then show ?case by (simp add: empty)
next
  case (2 v)
  then show ?case by (simp add: empty)
next
  case (3 n rest)
  then show ?case
    by (metis Cons_eq_appendI balanced.simps(3) replicate_Suc replicate_app_Cons_same)
next
  case (4 rest)
  then show ?case
    using balanced.simps(4) by blast
next
  case (5 n rest)
  hence "balanced n rest"
    by simp
  hence 0:"gram_S (replicate n a @ rest)"
    by (simp add: "5.IH")
  hence "gram_S (replicate n a @ [a, b] @ rest)"
    using insert_ab_middle_of_S by simp
  hence "gram_S (replicate (Suc n) a @ b # rest)"
    by (simp add: replicate_app_Cons_same)
  thus ?case
    by simp
qed

lemma balanced_append_b:"balanced n string \<Longrightarrow> balanced (Suc n) (string @ [b])"
proof(induction "(Suc n)" "(string @ [b])" arbitrary: n string rule: balanced.induct)
  case (2 v)
  then show ?case by simp
next
  case (3 rest)
  then show ?case
    by (metis Cons_eq_append_conv alpha.distinct(1) balanced.simps(3) list.inject)
next
  case pop_b:(5 n rest)
  moreover hence bal_sn:"balanced (Suc n) (b # string)"
    using balanced.simps(5) by simp
  ultimately show ?case
  proof(cases n)
    case 0
    moreover have "balanced (Suc n) (b # string)"
      by (metis bal_sn)
    ultimately show ?thesis
      using pop_b balanced.simps(4) by (metis butlast.simps(2) butlast_snoc)
  next
    case (Suc pred_n)
    then show ?thesis
      using pop_b bal_sn by (metis Cons_eq_append_conv balanced.simps(5))
  qed
qed

lemma balanced_append_string:
  "balanced 0 (drop len_prefix string) \<Longrightarrow> balanced n (take len_prefix string)
    \<Longrightarrow> balanced n string"
proof(induction string arbitrary: n len_prefix)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  then show ?case
  proof(induction n)
    case 0
    then show ?case
      by (metis balanced.elims(2) balanced.simps(3) balanced.simps(4) drop_Cons' list.inject
          list.simps(3) take_Cons')
  next
    case (Suc n)
    then show ?case
    proof(cases x)
      case a
      then show ?thesis
        by (metis Cons.IH Suc.prems(2) Suc.prems(3) balanced.simps(2) balanced.simps(3) drop_Cons'
            take_Cons')
    next
      case b
      then show ?thesis
        by (metis Cons.IH Suc.prems(2) Suc.prems(3) balanced.elims(2) balanced.simps(5) drop_Cons'
            list.simps(3) take_Cons')
    qed
  qed
qed

lemma S_implies_balanced:"gram_S (replicate n a @ string) \<Longrightarrow> balanced n string"
proof(induction "(replicate n a @ string)" arbitrary: n string rule: gram_S.induct)
  case empty
  then show ?case
    by simp
next
  case (aSb w)
  show ?case
  proof(cases n)
    case 0
    then show ?thesis
      using aSb.hyps(2) aSb.hyps(3) balanced_append_b by auto
  next
    case (Suc n_minus_1)
    moreover have 0:"string = butlast string @ [b]"
      by (metis Suc_neq_Zero aSb.hyps(3) alpha.distinct(1) calculation last_ConsR last_appendL last_appendR last_replicate snoc_eq_iff_butlast)
    ultimately have "w = replicate n_minus_1 a @ (butlast string)"
      by (metis aSb.hyps(3) butlast_append list.sel(3) replicate_Suc replicate_append_same snoc_eq_iff_butlast tl_append2)
    hence "balanced n_minus_1 (butlast string)"
      using aSb.hyps(2) by blast
    hence "balanced n string"
      using 0 Suc balanced_append_b by fastforce
    thus ?thesis by simp
  qed
next
  case (SS w\<^sub>0 w\<^sub>1)
  then show ?case
  proof(cases "length w\<^sub>0 = n")
    case True
    then show ?thesis
      by (metis SS.hyps(2) SS.hyps(4) SS.hyps(5) append.right_neutral append_eq_append_conv
          append_self_conv2 balanced.simps(2) gr0_conv_Suc length_greater_0_conv length_replicate)
  next
    case len_ne:False
    then show ?thesis
    proof(cases "length w\<^sub>0 < n")
      case len_w_lt:True
      hence "w\<^sub>0 = take (length w\<^sub>0) (replicate n a @ string)"
        using SS.hyps(5) append_eq_conv_conj by blast
      hence "w\<^sub>0 = take (length w\<^sub>0) (replicate n a)"
        using len_w_lt by fastforce
      hence "w\<^sub>0 = replicate (length w\<^sub>0) a"
        by (metis length_replicate take_replicate)
      hence "w\<^sub>0 = replicate (length w\<^sub>0) a @ []"
        by simp
      hence bal:"balanced (length w\<^sub>0) []"
        using SS.hyps(2) by blast
          (* Now work on w\<^sub>1 *)
      hence "w\<^sub>1 = drop (length w\<^sub>0) (replicate n a @ string)"
        using SS.hyps(5) append_eq_conv_conj by blast
      hence "w\<^sub>1 = replicate (n - length w\<^sub>0) a @ string"
        using len_w_lt by simp
      hence "balanced (n - length w\<^sub>0) string"
        by (simp add: SS.hyps(4))
      thus ?thesis
        by (metis Nitpick.size_list_simp(2) SS.hyps(4) SS.hyps(5) bal balanced.simps(2)
            self_append_conv2)
    next
      case False
      hence len_w_gt:"length w\<^sub>0 > n"
        using len_ne by auto
      hence "w\<^sub>0 = take (length w\<^sub>0) (replicate n a @ string)"
        using SS.hyps(5) append_eq_conv_conj by blast
      hence "w\<^sub>0 = replicate n a @ take (length w\<^sub>0 - n) string"
        by (metis len_w_gt length_replicate less_imp_le_nat take_all take_append)
      hence bal_w0:"balanced n (take (length w\<^sub>0 - n) string)"
        using SS.hyps(2) by blast
          (* Now work on w\<^sub>1 *)
      hence "w\<^sub>1 = drop (length w\<^sub>0) (replicate n a @ string)"
        using SS.hyps(5) append_eq_conv_conj by blast
      hence "w\<^sub>1 = drop (length w\<^sub>0 - n) string"
        using len_w_gt by simp
      hence "balanced 0 (drop (length w\<^sub>0 - n) string)"
        by (simp add: SS.hyps(4))
      then show ?thesis
        using bal_w0 balanced_append_string by blast
    qed
  qed
qed

theorem "balanced n w = gram_S (replicate n a @ w)"
  using S_implies_balanced balanced_implies_S by blast

end


(*  Based on:   HOL/Hoare/Examples.thy
*)
theory Labeled_Hoare_Examples
imports
  Labeled_Hoare
  "HOL-Hoare.Arith2"
begin

subsubsection \<open>Multiplication by successive addition\<close>

lemma multiply_by_add: "VARS m s a b
  {a=A \<and> b=B}
  m := 0; s := 0;
  WHILE m\<noteq>a
  INV {s=m*b \<and> a=A \<and> b=B}
  DO s := s+b; m := m+(1::nat) OD
  {s = A*B}"
by vcg_simp

lemma "VARS M N P :: int
 {m=M \<and> n=N}
 IF M < 0 THEN M := -M; N := -N ELSE SKIP FI;
 P := 0;
 WHILE 0 < M
 INV {0 \<le> M \<and> (\<exists>p. p = (if m<0 then -m else m) \<and> p*N = m*n \<and> P = (p-M)*N)}
 DO P := P+N; M := M - 1 OD
 {P = m*n}"
proof casified_vcg_simp
  case while
  { case postcondition
    then show ?case by auto
  next
    case invariant
    { case basic
      then show ?case by (auto simp: int_distrib)
    }
  }
qed

subsubsection \<open>Euclid's algorithm for GCD\<close>

lemma Euclid_GCD: "VARS a b
 {0<A \<and> 0<B}
 a := A; b := B;
 WHILE  a \<noteq> b
 INV {0<a \<and> 0<b \<and> gcd A B = gcd a b}
 DO IF a<b THEN b := b-a ELSE a := a-b FI OD
 {a = gcd A B}"
proof casified_vcg_simp
  case while
  { case postcondition
    then show ?case by (auto elim: gcd_nnn)
  next
    case invariant
    { case cond
      { case vc
        then show ?case
          by (simp_all add: linorder_not_less gcd_diff_l gcd_diff_r less_imp_le)
      }
    }
  }
qed

subsubsection \<open>Dijkstra's extension of Euclid's algorithm for simultaneous GCD and SCM\<close>

text\<open>
  From E.W. Disjkstra. Selected Writings on Computing, p 98 (EWD474),
  where it is given without the invariant. Instead of defining scm
  explicitly we have used the theorem scm x y = x*y/gcd x y and avoided
  division by mupltiplying with gcd x y.
\<close>

lemmas distribs =
  diff_mult_distrib diff_mult_distrib2 add_mult_distrib add_mult_distrib2

lemma gcd_scm: "VARS a b x y
 {0<A \<and> 0<B \<and> a=A \<and> b=B \<and> x=B \<and> y=A}
 WHILE  a \<noteq> b
 INV {0<a \<and> 0<b \<and> gcd A B = gcd a b \<and> 2*A*B = a*x + b*y}
 DO IF a<b THEN (b := b-a; x := x+y) ELSE (a := a-b; y := y+x) FI OD
 {a = gcd A B \<and> 2*A*B = a*(x+y)}"
proof casified_vcg
  case while {
    case precondition then show ?case by simp
  next
    case invariant
    case cond
    case vc
    then show ?case
      by (simp add: distribs gcd_diff_r linorder_not_less gcd_diff_l)
  next
    case postcondition then show ?case
      by (simp add: distribs gcd_nnn)
  }
qed

subsubsection \<open>Power by iterated squaring and multiplication\<close>

lemma power_by_mult: "VARS a b c
 {a=A \<and> b=B}
 c := (1::nat);
 WHILE b \<noteq> 0
 INV {A^B = c * a^b}
 DO  WHILE b mod 2 = 0
     INV {A^B = c * a^b}
     DO  a := a*a; b := b div 2 OD;
     c := c*a; b := b - 1
 OD
 {c = A^B}"
proof casified_vcg_simp
  case while
  case invariant
  case while
  case postcondition
  then show ?case by (cases b) simp_all
qed

subsubsection \<open>Factorial\<close>

lemma factorial: "VARS a b
 {a=A}
 b := 1;
 WHILE a \<noteq> 0
 INV {fac A = b * fac a}
 DO b := b*a; a := a - 1 OD
 {b = fac A}"
  apply vcg_simp
  apply(clarsimp split: nat_diff_split)
  done

lemma "VARS i f
 {True}
 i := (1::nat); f := 1;
 WHILE i \<le> n INV {f = fac(i - 1) \<and> 1 \<le> i \<and> i \<le> n+1}
 DO f := f*i; i := i+1 OD
 {f = fac n}"
proof casified_vcg_simp
  case while
  { case invariant
    { case basic
      then show ?case by (induct i) simp_all
    }
  next
    case postcondition
    then have "i = Suc n" by simp
    then show ?case by simp
  }
qed

subsubsection \<open>Quicksort\<close>

text \<open>
  The `partition' procedure for quicksort.
  `A' is the array to be sorted (modelled as a list).
  Elements of A must be of class order to infer at the end
  that the elements between u and l are equal to pivot.

  Ambiguity warnings of parser are due to := being used
  both for assignment and list update.
\<close>

lemma Partition:
  fixes pivot
  defines "leq \<equiv> \<lambda>A i. \<forall>k. k<i \<longrightarrow> A!k \<le> pivot"
  defines "geq \<equiv> \<lambda>A i. \<forall>k. i<k \<and> k<length A \<longrightarrow> pivot \<le> A!k"
  shows "
   VARS A u l
   {0 < length(A::('a::order)list)}
   l := 0; u := length A - Suc 0;
   WHILE l \<le> u
    INV {leq A l \<and> geq A u \<and> u<length A \<and> l\<le>length A}
    DO WHILE l < length A \<and> A!l \<le> pivot
        INV {leq A l \<and> geq A u \<and> u<length A \<and> l\<le>length A}
        DO l := l+1 OD;
       WHILE 0 < u \<and> pivot \<le> A!u
        INV {leq A l \<and> geq A u  \<and> u<length A \<and> l\<le>length A}
        DO u := u - 1 OD;
       IF l \<le> u THEN A := A[l := A!u, u := A!l] ELSE SKIP FI
    OD
   {leq A u \<and> (\<forall>k. u<k \<and> k<l \<longrightarrow> A!k = pivot) \<and> geq A l}"
  unfolding leq_def geq_def
proof casified_vcg_simp
  case basic
  then show ?case by auto
next
  case while
  { case postcondition
    then show ?case by (force simp: nth_list_update)
  next
    case invariant
    { case while
      { case invariant
        { case basic
          then show ?case by (blast elim!: less_SucE intro: Suc_leI)
        }
      }
    next
      case whilea
      { case invariant
        { case basic
          have lem: "\<And>m n. m - Suc 0 < n \<Longrightarrow> m < Suc n" by linarith
          from basic show ?case by (blast elim!: less_SucE intro: less_imp_diff_less dest: lem)
        }
      }
    }
  }
qed

end


theory Sum
imports Main
begin

primrec sum :: "nat list => nat" where
"sum [] = 0"|
"sum (x#l) = x + sum l"

primrec sum_till :: "nat \<Rightarrow> nat" where
 "sum_till 0 = 0"|
 "sum_till (Suc k) = sum_till (k) + Suc(k)"

lemma sum_2_list [simp]: "sum (l1 @ l2) = sum l1 + sum l2"
  apply(induct l1)
  apply(auto)
  done

theorem sum_rev_list: "sum (rev l) = sum l"
  apply (induct l)
  apply (auto simp: sum_2_list)
  done
text \<open>
  The sum of natural numbers \<open>0 + \<cdots> + n\<close> equals \<open>n \<times> (n + 1)/2\<close>. Avoiding
  formal reasoning about division we prove this equation multiplied by \<open>2\<close>.
\<close>

theorem sum_formula: "2*sum_till n = n*(n+1)"
  apply (induct n)
  apply (auto)
  done

end


(*
  Title:    Random_Serial_Dictatorship.thy
  Author:   Manuel Eberl, TU München

  Definition and basic properties of Random Serial Dictatorship
*)

section \<open>Random Serial Dictatorship\<close>

theory Random_Serial_Dictatorship
imports
  Complex_Main
  Social_Decision_Schemes
  Random_Permutations
  Random_Dictatorship
begin

text \<open>
  Random Serial Dictatorship is an anonymous, neutral, strongly strategy-proof,
  and ex-post efficient Social Decision Scheme that extends Random Dictatorship
  to the domain of weak preferences.

  We define RSD using a fold over a random permutation. Effectively, we choose a random
  order of the agents (in the form of a list) and then traverse that list from left to right,
  where each agent in turn removes all the alternatives that are not top-ranked among the
  remaining ones.
\<close>
definition random_serial_dictatorship ::
    "'agent set \<Rightarrow> 'alt set \<Rightarrow> ('agent, 'alt) pref_profile \<Rightarrow> 'alt lottery" where
  "random_serial_dictatorship agents alts R =
     fold_bind_random_permutation (\<lambda>i alts. Max_wrt_among (R i) alts) pmf_of_set alts agents"

text \<open>
  The following two facts correspond give an alternative recursive definition to
  the above definition, which uses random permutations and list folding.
\<close>
lemma random_serial_dictatorship_empty [simp]:
  "random_serial_dictatorship {} alts R = pmf_of_set alts"
  by (simp add: random_serial_dictatorship_def)

lemma random_serial_dictatorship_nonempty:
  "finite agents \<Longrightarrow> agents \<noteq> {} \<Longrightarrow>
    random_serial_dictatorship agents alts R =
      do {
        i \<leftarrow> pmf_of_set agents;
        random_serial_dictatorship (agents - {i}) (Max_wrt_among (R i) alts) R
      }"
  by (simp add: random_serial_dictatorship_def)

text \<open>
  We define the RSD winners w.r.t. a given set of alternatives and a fixed permutation
  (i.e. list) of agents. In contrast to the above definition, the RSD winners are
  determined by traversing the list of agents from right to left.
    This may seem strange, but it makes induction much easier, since induction over @{term foldr}
  does not require generalisation over the set of alternatives and is therefore much
  easier than over @{term foldl}.
\<close>
definition rsd_winners where
  "rsd_winners R alts agents = foldr (\<lambda>i alts. Max_wrt_among (R i) alts) agents alts"

lemma rsd_winners_empty [simp]: "rsd_winners R alts [] = alts"
  by (simp add: rsd_winners_def)

lemma rsd_winners_Cons [simp]:
  "rsd_winners R alts (i # agents) = Max_wrt_among (R i) (rsd_winners R alts agents)"
  by (simp add: rsd_winners_def)

lemma rsd_winners_map [simp]:
  "rsd_winners R alts (map f agents) = rsd_winners (R \<circ> f) alts agents"
  by (simp add: rsd_winners_def foldr_map o_def)

text \<open>
  There is now another alternative definition of RSD in terms of the
  RSD winners. This will mostly be used for induction.
\<close>
lemma random_serial_dictatorship_altdef:
  assumes "finite agents"
  shows   "random_serial_dictatorship agents alts R =
             do {
               agents' \<leftarrow> pmf_of_set (permutations_of_set agents);
               pmf_of_set (rsd_winners R alts agents')
             }"
   by (simp add: random_serial_dictatorship_def
         fold_bind_random_permutation_foldr assms rsd_winners_def)

text \<open>
  The following lemma shows that folding from left to right yields the same
  distribution. This is probably the most commonly used definition in the literature,
  along with the recursive one.
\<close>
lemma random_serial_dictatorship_foldl:
  assumes "finite agents"
  shows   "random_serial_dictatorship agents alts R =
             do {
               agents' \<leftarrow> pmf_of_set (permutations_of_set agents);
               pmf_of_set (foldl (\<lambda>alts i. Max_wrt_among (R i) alts) alts agents')
             }"
   by (simp add: random_serial_dictatorship_def fold_bind_random_permutation_foldl assms)

subsection \<open>Auxiliary facts about RSD\<close>

subsubsection \<open>Pareto-equivalence classes\<close>

text \<open>
  First of all, we introduce the auxiliary notion of a Pareto-equivalence class.
  A non-empty set of alternatives is a Pareto equivalence class if all agents are
  indifferent between all alternatives in it, and if some alternative @{term "x::'alt"}
  is contained in the set, any other alternative @{term "y::'alt"} is contained in it
  if and only if, to all agents, @{term y} is at least as good as @{term x}.
    The importance of this notion lies in the fact that the set of RSD winners is always
  a Pareto-equivalence class, which we will later use to show ex-post efficiency and
  strategy-proofness.
\<close>

definition RSD_pareto_eqclass where
  "RSD_pareto_eqclass agents alts R A \<longleftrightarrow>
     A \<noteq> {} \<and> A \<subseteq> alts \<and> (\<forall>x\<in>A. \<forall>y\<in>alts. y \<in> A \<longleftrightarrow> (\<forall>i\<in>agents. R i x y))"

lemma RSD_pareto_eqclassI:
  assumes "A \<noteq> {}" "A \<subseteq> alts" "\<And>x y. x \<in> A \<Longrightarrow> y \<in> alts \<Longrightarrow> y \<in> A \<longleftrightarrow> (\<forall>i\<in>agents. R i x y)"
  shows   "RSD_pareto_eqclass agents alts R A"
  using assms unfolding RSD_pareto_eqclass_def by simp_all

lemma RSD_pareto_eqclassD:
  assumes "RSD_pareto_eqclass agents alts R A"
  shows   "A \<noteq> {}" "A \<subseteq> alts" "\<And>x y. x \<in> A \<Longrightarrow> y \<in> alts \<Longrightarrow> y \<in> A \<longleftrightarrow> (\<forall>i\<in>agents. R i x y)"
  using assms unfolding RSD_pareto_eqclass_def by simp_all

lemma RSD_pareto_eqclass_indiff_set:
  assumes "RSD_pareto_eqclass agents alts R A" "i \<in> agents" "x \<in> A" "y \<in> A"
  shows   "R i x y"
  using assms unfolding RSD_pareto_eqclass_def by blast

lemma RSD_pareto_eqclass_empty [simp, intro!]:
  "alts \<noteq> {} \<Longrightarrow> RSD_pareto_eqclass {} alts R alts"
  using assms by (auto intro!: RSD_pareto_eqclassI)

lemma (in pref_profile_wf) RSD_pareto_eqclass_insert:
  assumes "RSD_pareto_eqclass agents' alts R A" "finite alts"
          "i \<in> agents" "agents' \<subseteq> agents"
  shows   "RSD_pareto_eqclass (insert i agents') alts R (Max_wrt_among (R i) A)"
proof -
  from assms interpret total_preorder_on alts "R i" by simp
  show ?thesis
  proof (intro RSD_pareto_eqclassI Max_wrt_among_nonempty Max_wrt_among_subset, goal_cases)
    case (3 x y)
    with RSD_pareto_eqclassD[OF assms(1)]
      show ?case unfolding Max_wrt_among_total_preorder
      by (blast intro: trans)
  qed (insert RSD_pareto_eqclassD[OF assms(1)] assms(2),
       simp_all add: Int_absorb1 Int_absorb2 finite_subset)[2]
qed

subsubsection \<open>Facts about RSD winners\<close>

context pref_profile_wf
begin

text \<open>
  Any RSD winner is a valid alternative.
\<close>
lemma rsd_winners_subset:
  assumes "set agents' \<subseteq> agents"
  shows   "rsd_winners R alts' agents' \<subseteq> alts'"
proof -
  {
    fix i assume "i \<in> agents"
    then interpret total_preorder_on alts "R i" by simp
    have "Max_wrt_among (R i) A \<subseteq> A" for A
      using Max_wrt_among_subset by blast
  } note A = this

  from \<open>set agents' \<subseteq> agents\<close> show "rsd_winners R alts' agents' \<subseteq> alts'"
    using A by (induction agents') auto
qed

text \<open>
  There is always at least one RSD winner.
\<close>
lemma rsd_winners_nonempty:
  assumes finite: "finite alts"  and "alts' \<noteq> {}"  "set agents' \<subseteq> agents" "alts' \<subseteq> alts"
  shows   "rsd_winners R alts' agents' \<noteq> {}"
proof -
  {
    fix i assume "i \<in> agents"
    then interpret total_preorder_on alts "R i" by simp
    have "Max_wrt_among (R i) A \<noteq> {}" if "A \<subseteq> alts" "A \<noteq> {}" for A
      using that assms by (intro Max_wrt_among_nonempty) (auto simp: Int_absorb)
  } note B = this

  with \<open>set agents' \<subseteq> agents\<close> \<open>alts' \<subseteq> alts\<close> \<open>alts' \<noteq> {}\<close>
    show "rsd_winners R alts' agents' \<noteq> {}"
  proof (induction agents')
    case (Cons i agents')
    with B[of i "rsd_winners R alts' agents'"] rsd_winners_subset[of agents' alts'] finite wf
      show ?case by auto
  qed simp
qed

text \<open>
  Obviously, the set of RSD winners is always finite.
\<close>
lemma rsd_winners_finite:
  assumes "set agents' \<subseteq> agents" "finite alts" "alts' \<subseteq> alts"
  shows   "finite (rsd_winners R alts' agents')"
  by (rule finite_subset[OF subset_trans[OF rsd_winners_subset]]) fact+

lemmas rsd_winners_wf =
  rsd_winners_subset rsd_winners_nonempty rsd_winners_finite

text \<open>
  The set of RSD winners is a Pareto-equivalence class.
\<close>
lemma RSD_pareto_eqclass_rsd_winners_aux:
  assumes finite: "finite alts" and "alts \<noteq> {}" and "set agents' \<subseteq> agents"
  shows   "RSD_pareto_eqclass (set agents') alts R (rsd_winners R alts agents')"
  using \<open>set agents' \<subseteq> agents\<close>
proof (induction agents')
  case (Cons i agents')
  from Cons.prems show ?case
    by (simp only: set_simps rsd_winners_Cons,
        intro RSD_pareto_eqclass_insert[OF Cons.IH finite]) simp_all
qed (insert assms, simp_all)

lemma RSD_pareto_eqclass_rsd_winners:
  assumes finite: "finite alts" and "alts \<noteq> {}" and "set agents' = agents"
  shows   "RSD_pareto_eqclass agents alts R (rsd_winners R alts agents')"
  using RSD_pareto_eqclass_rsd_winners_aux[of agents'] assms by simp

text \<open>
  For the proof of strategy-proofness, we need to define indifference sets
  and lift preference relations to sets in a specific way.
\<close>
context
begin

text \<open>
  An indifference set for a given preference relation is a non-empty set of alternatives
  such that the agent is indifferent over all of them.
\<close>
private definition indiff_set where
  "indiff_set S A \<longleftrightarrow> A \<noteq> {} \<and> (\<forall>x\<in>A. \<forall>y\<in>A. S x y)"

private lemma indiff_set_mono: "indiff_set S A \<Longrightarrow> B \<subseteq> A \<Longrightarrow> B \<noteq> {} \<Longrightarrow> indiff_set S B"
  unfolding indiff_set_def by blast

text \<open>
  Given an arbitrary set of alternatives @{term A} and an indifference set @{term B},
  we say that @{term B} is set-preferred over @{term A} w.r.t. the preference
  relation @{term R} if all (or, equivalently, any) of the alternatives in @{term B}
  are preferred over all alternatives in @{term A}.
\<close>
private definition RSD_set_rel where
  "RSD_set_rel S A B \<longleftrightarrow> indiff_set S B \<and> (\<forall>x\<in>A. \<forall>y\<in>B. S x y)"

text \<open>
  The most-preferred alternatives (w.r.t. @{term R}) among any non-empty set of alternatives
  form an indifference set w.r.t. @{term R}.
\<close>
private lemma indiff_set_Max_wrt_among:
  assumes "finite carrier" "A \<subseteq> carrier" "A \<noteq> {}" "total_preorder_on carrier S"
  shows   "indiff_set S (Max_wrt_among S A)"
  unfolding indiff_set_def
proof
  from assms(4) interpret total_preorder_on carrier S .
  from assms(1-3)
    show "Max_wrt_among S A \<noteq> {}" by (intro Max_wrt_among_nonempty) auto
  from assms(1-3) show "\<forall>x\<in>Max_wrt_among S A. \<forall>y\<in>Max_wrt_among S A. S x y"
    by (auto simp: indiff_set_def Max_wrt_among_total_preorder)
qed

text \<open>
  We now consider the set of RSD winners in the setting of a preference profile @{term R}
  and a manipulated profile @{term "R(i := Ri')"}.
    This theorem shows that the set of RSD winners in the outcome is either the same
  in both cases or the outcome for the truthful profile is an indifference set that is
  set-preferred over the outcome for the manipulated profile.
\<close>
lemma rsd_winners_manipulation_aux:
  assumes wf: "total_preorder_on alts Ri'"
      and i: "i \<in> agents" and "set agents' \<subseteq> agents" "finite agents"
      and finite: "finite alts" and "alts \<noteq> {}"
  defines [simp]: "w' \<equiv> rsd_winners (R(i := Ri')) alts" and [simp]: "w \<equiv> rsd_winners R alts"
  shows   "w' agents' = w agents' \<or> RSD_set_rel (R i) (w' agents') (w agents')"
using \<open>set agents' \<subseteq> agents\<close>
proof (induction agents')
  case (Cons j agents')
  from wf i interpret Ri: total_preorder_on alts "R i" by simp
  from wf Cons.prems interpret Rj: total_preorder_on alts "R j" by simp
  from wf interpret Ri': total_preorder_on alts "Ri'" .
  from wf assms Cons.prems
    have indiff_set: "indiff_set (R i) (Max_wrt_among (R i) (rsd_winners R alts agents'))"
    by (intro indiff_set_Max_wrt_among[OF finite] rsd_winners_wf) simp_all

  show ?case
  proof (cases "j = i")
    assume j [simp]: "j = i"
    from indiff_set Cons have "RSD_set_rel (R i) (w' (j # agents')) (w (j # agents'))"
      unfolding RSD_set_rel_def
      by (auto simp: Ri.Max_wrt_among_total_preorder Ri'.Max_wrt_among_total_preorder)
    thus ?case ..
  next
    assume j [simp]: "j \<noteq> i"
    from Cons have "w' agents' = w agents' \<or> RSD_set_rel (R i) (w' agents') (w agents')" by simp
    thus ?case
    proof
      assume rel: "RSD_set_rel (R i) (w' agents') (w agents')"
      hence indiff_set: "indiff_set (R i) (w agents')" by (simp add: RSD_set_rel_def)
      moreover from Cons.prems finite \<open>alts \<noteq> {}\<close>
        have "w agents' \<subseteq> alts" "w agents' \<noteq> {}" unfolding w_def
        by (intro rsd_winners_wf; simp)+
      with finite have "Max_wrt_among (R j) (w agents') \<noteq> {}"
        by (intro Rj.Max_wrt_among_nonempty) auto
      ultimately have "indiff_set (R i) (w (j # agents'))"
        by (intro indiff_set_mono[OF indiff_set] Rj.Max_wrt_among_subset)
           (simp_all add: Rj.Max_wrt_among_subset)
      moreover from rel have "\<forall>x\<in>w' (j # agents'). \<forall>y\<in>w (j # agents'). R i x y"
        by (auto simp: RSD_set_rel_def Rj.Max_wrt_among_total_preorder)
      ultimately have "RSD_set_rel (R i) (w' (j # agents')) (w (j # agents'))"
        unfolding RSD_set_rel_def ..
      thus ?case ..
    qed simp_all
  qed
qed simp_all

text \<open>
  The following variant of the previous theorem is slightly easier to use.
  We eliminate the case where the two outcomes are the same by observing that
  the original outcome is then also set-preferred to the manipulated one.
    In essence, this means that no matter what manipulation is done, the
  original outcome is always set-preferred to the manipulated one.
\<close>
lemma rsd_winners_manipulation:
  assumes wf: "total_preorder_on alts Ri'"
      and i: "i \<in> agents" and "set agents' = agents" "finite agents"
      and finite: "finite alts" and "alts \<noteq> {}"
  defines [simp]: "w' \<equiv> rsd_winners (R(i := Ri')) alts" and [simp]: "w \<equiv> rsd_winners R alts"
  shows   "\<forall>x\<in>w' agents'. \<forall>y\<in>w agents'. x \<preceq>[R i] y"
proof -
  have "w' agents' = w agents' \<or> RSD_set_rel (R i) (w' agents') (w agents')"
    using rsd_winners_manipulation_aux[OF assms(1-2) _ assms(4-6)] assms(3) by simp
  thus ?thesis
  proof
    assume eq: "w' agents' = w agents'"
    from assms have "RSD_pareto_eqclass (set agents') alts R (w agents')" unfolding w_def
      by (intro RSD_pareto_eqclass_rsd_winners_aux) simp_all
    from RSD_pareto_eqclass_indiff_set[OF this, of i] i eq assms(3) show ?thesis by auto
  qed (auto simp: RSD_set_rel_def)
qed

end

text \<open>
  The lottery that RSD yields is well-defined.
\<close>
lemma random_serial_dictatorship_support:
  assumes "finite agents" "finite alts" "agents' \<subseteq> agents" "alts' \<noteq> {}" "alts' \<subseteq> alts"
  shows   "set_pmf (random_serial_dictatorship agents' alts' R) \<subseteq> alts'"
proof -
  from assms have [simp]: "finite agents'" by (auto intro: finite_subset)
  have A: "set_pmf (pmf_of_set (rsd_winners R alts' agents'')) \<subseteq> alts'"
    if "agents'' \<in> permutations_of_set agents'" for agents''
    using that assms rsd_winners_wf[where alts' = alts' and agents' = agents'']
    by (auto simp: permutations_of_set_def)
  from assms show ?thesis
    by (auto dest!: A simp add: random_serial_dictatorship_altdef)
qed

text \<open>
  Permutation of alternatives commutes with RSD winners.
\<close>
lemma rsd_winners_permute_profile:
  assumes perm: "\<sigma> permutes alts" and "set agents' \<subseteq> agents"
  shows   "rsd_winners (permute_profile \<sigma> R) alts agents' = \<sigma> ` rsd_winners R alts agents'"
  using \<open>set agents' \<subseteq> agents\<close>
proof (induction agents')
  case Nil
  from perm show ?case by (simp add: permutes_image)
next
  case (Cons i agents')
  from wf Cons interpret total_preorder_on alts "R i" by simp
  from perm Cons show ?case
    by (simp add: permute_profile_map_relation Max_wrt_among_map_relation_bij permutes_bij)
qed

lemma random_serial_dictatorship_singleton:
  assumes "finite agents" "finite alts" "agents' \<subseteq> agents" "x \<in> alts"
  shows   "random_serial_dictatorship agents' {x} R = return_pmf x" (is "?d = _")
proof -
  from assms have "set_pmf ?d \<subseteq> {x}"
    by (intro random_serial_dictatorship_support) simp_all
  thus ?thesis by (simp add: set_pmf_subset_singleton)
qed

end

subsection \<open>Proofs of properties\<close>

text \<open>
  With all the facts that we have proven about the RSD winners, the hard work is
  mostly done. We can now simply fix some arbitrary order of the agents, apply the
  theorems about the RSD winners, and show the properties we want to show without
  doing much reasoning about probabilities.
\<close>

context election
begin

abbreviation "RSD \<equiv> random_serial_dictatorship agents alts"

subsubsection \<open>Well-definedness\<close>

sublocale RSD: social_decision_scheme agents alts RSD
  using pref_profile_wf.random_serial_dictatorship_support[of agents alts]
  by unfold_locales (simp_all add: lotteries_on_def)

subsubsection \<open>RD extension\<close>

lemma RSD_extends_RD:
  assumes wf: "is_pref_profile R" and unique: "has_unique_favorites R"
  shows   "RSD R = RD R"
proof -
  from wf interpret pref_profile_wf agents alts R .
  from unique interpret pref_profile_unique_favorites by unfold_locales
  have "RSD R = pmf_of_set agents \<bind>
                  (\<lambda>i. random_serial_dictatorship (agents - {i}) (favorites R i) R)"
    by (simp add: random_serial_dictatorship_nonempty favorites_altdef Max_wrt_def)
  also from assms have "\<dots> = pmf_of_set agents \<bind> (\<lambda>i. return_pmf (favorite R i))"
    by (intro bind_pmf_cong refl, subst random_serial_dictatorship_singleton [symmetric])
       (auto simp: unique_favorites favorite_in_alts)
  also from assms have "\<dots> = RD R"
    by (simp add: random_dictatorship_unique_favorites map_pmf_def)
  finally show ?thesis .
qed

subsubsection \<open>Anonymity\<close>

text \<open>
  Anonymity is a direct consequence of the fact that we randomise over all
  permutations in a uniform way.
\<close>

sublocale RSD: anonymous_sds agents alts RSD
proof
  fix \<pi> R assume perm: "\<pi> permutes agents" and wf: "is_pref_profile R"
  let ?f = "\<lambda>agents'. pmf_of_set (rsd_winners R alts agents')"
  from perm wf have "RSD (R \<circ> \<pi>) = map_pmf (map \<pi>) (pmf_of_set (permutations_of_set agents)) \<bind> ?f"
    by (simp add: random_serial_dictatorship_altdef bind_map_pmf)
  also from perm have "\<dots> = RSD R"
    by (simp add: map_pmf_of_set_inj permutes_inj_on inj_on_mapI
                  permutations_of_set_image_permutes random_serial_dictatorship_altdef)
  finally show "RSD (R \<circ> \<pi>) = RSD R" .
qed

subsubsection \<open>Neutrality\<close>

text \<open>
  Neutrality follows from the fact that the RSD winners of a permuted profile
  are simply the image of the original RSD winners under the permutation.
\<close>

sublocale RSD: neutral_sds agents alts RSD
proof
  fix \<sigma> R assume perm: "\<sigma> permutes alts" and wf: "is_pref_profile R"
  from wf interpret pref_profile_wf agents alts R .
  from perm show "RSD (permute_profile \<sigma> R) = map_pmf \<sigma> (RSD R)"
    by (auto intro!: bind_pmf_cong dest!: permutations_of_setD(1)
             simp: random_serial_dictatorship_altdef rsd_winners_permute_profile
                   map_bind_pmf map_pmf_of_set_inj permutes_inj_on rsd_winners_wf)
qed

subsubsection \<open>Ex-post efficiency\<close>

text \<open>
  Ex-post efficiency follows from the fact that the set of RSD winners
  is a Pareto-equivalence class.
\<close>

sublocale RSD: ex_post_efficient_sds agents alts RSD
proof
  fix R assume wf: "is_pref_profile R"
  then interpret pref_profile_wf agents alts R .
  {
    fix x assume x: "x \<in> set_pmf (RSD R)" "x \<in> pareto_losers R"
    from x(2) obtain y where [simp]: "y \<in> alts" and pareto: "y \<succ>[Pareto(R)] x"
      by (cases rule: pareto_losersE)
    from x have [simp]: "x \<in> alts" using pareto_loser_in_alts by simp

    from x(1) obtain agents' where agents': "set agents' = agents" and
        "x \<in> set_pmf (pmf_of_set (rsd_winners R alts agents'))"
      by (auto simp: random_serial_dictatorship_altdef dest: permutations_of_setD)
    with wf have x': "x \<in> rsd_winners R alts agents'"
      using rsd_winners_wf[where alts' = alts and agents' = agents']
      by (subst (asm) set_pmf_of_set) (auto simp: permutations_of_setD)

    from wf agents'
      have "RSD_pareto_eqclass agents alts R (rsd_winners R alts agents')"
      by (intro RSD_pareto_eqclass_rsd_winners) simp_all
    hence winner_iff: "y \<in> rsd_winners R alts agents' \<longleftrightarrow> (\<forall>i\<in>agents. x \<preceq>[R i] y)"
      if "x \<in> rsd_winners R alts agents'" "y \<in> alts" for x y
      using that unfolding RSD_pareto_eqclass_def by blast
    from x' pareto winner_iff[of x y] winner_iff[of y x] have False
      by (force simp: strongly_preferred_def Pareto_iff)
  }
  thus "set_pmf (RSD R) \<inter> pareto_losers R = {}" by blast
qed

subsubsection \<open>Strong strategy-proofness\<close>

text \<open>
  Strong strategy-proofness is slightly more difficult to show. We have already shown
  that the set of RSD winners for the truthful profile is always set-preferred (by the
  manipulating agent) to the RSD winners for the manipulated profile.
    This can now be used to show strategy-proofness: We recall that the set of RSD
  winners is always an indifference class. Therefore, given any fixed alternative @{term "x::'alt"}
  and considering a fixed order of the agents, either all of the RSD winners in the original
  profile are at least as good as @{term "x::'alt"} or none of them are, and, since the original
  RSD winners are set-preferred to the manipulated ones, none of the RSD winners in the
  manipulated case are at least as good than @{term "x::'alt"} either in that case.
    This means that for a fixed order of agents, either the probability that the original
  outcome is at least as good as @{term "x::'alt"} is 1 or the probability that the manipulated
  outcome is at least as good as @{term "x::'alt"} is 0.
    Therefore, the original lottery is clearly SD-preferred to the manipulated one.
\<close>

sublocale RSD: strongly_strategyproof_sds agents alts RSD
proof (unfold_locales, rule)
  fix R i Ri' x
  assume wf: "is_pref_profile R" and i [simp]: "i \<in> agents" and x: "x \<in> alts" and
         wf': "total_preorder_on alts Ri'"
  interpret R: pref_profile_wf agents alts R by fact
  def R' \<equiv> "R (i := Ri')"
  from wf wf' have "is_pref_profile R'" by (simp add: R'_def R.wf_update)
  then interpret R': pref_profile_wf agents alts R' .
  note wf = wf wf'
  let ?A = "preferred_alts (R i) x"
  from wf interpret Ri: total_preorder_on alts "R i" by simp

  {
    fix agents' assume agents': "agents' \<in> permutations_of_set agents"
    from agents' have [simp]: "set agents' = agents"
      by (simp add: permutations_of_set_def)

    let ?W = "rsd_winners R alts agents'" and ?W' = "rsd_winners R' alts agents'"
    have indiff_set: "RSD_pareto_eqclass agents alts R ?W"
      by (rule R.RSD_pareto_eqclass_rsd_winners; simp add: wf)+
    from R.rsd_winners_wf R'.rsd_winners_wf
      have winners: "?W \<subseteq> alts" "?W \<noteq> {}" "finite ?W" "?W' \<subseteq> alts" "?W' \<noteq> {}" "finite ?W'"
      by simp_all

    from \<open>?W \<noteq> {}\<close> obtain y where y: "y \<in> ?W" by blast
    with winners have [simp]: "y \<in> alts" by blast
    from wf' i have mono: "\<forall>x\<in>?W'. \<forall>y\<in>?W. R i x y" unfolding R'_def
      by (intro R.rsd_winners_manipulation) simp_all

    have "lottery_prob (pmf_of_set ?W) ?A \<ge> lottery_prob (pmf_of_set ?W') ?A"
    proof (cases "y \<succeq>[R i] x")
      case True
      with y RSD_pareto_eqclass_indiff_set[OF indiff_set(1), of i]  winners
        have "?W \<subseteq> preferred_alts (R i) x"
        by (auto intro: Ri.trans simp: preferred_alts_def)
      with winners show ?thesis
        by (subst (2) measure_pmf_of_set) (simp_all add: Int_absorb2)
    next
      case False
      with y mono have "?W' \<inter> preferred_alts (R i) x = {}"
        by (auto intro: Ri.trans simp: preferred_alts_def)
      with winners show ?thesis
        by (subst (1) measure_pmf_of_set)
           (simp_all add: Int_absorb2 one_ereal_def measure_nonneg)
    qed
    hence "emeasure (measure_pmf (pmf_of_set ?W)) ?A \<ge> emeasure (measure_pmf (pmf_of_set ?W')) ?A"
      by (simp add: measure_pmf.emeasure_eq_measure)
  }
  hence "emeasure (measure_pmf (RSD R)) ?A \<ge> emeasure (measure_pmf (RSD R')) ?A"
    by (auto simp: random_serial_dictatorship_altdef AE_measure_pmf_iff
             intro!: nn_integral_mono_AE)
  thus "lottery_prob (RSD R) ?A \<ge> lottery_prob (RSD R') ?A"
    by (simp add: measure_pmf.emeasure_eq_measure)
qed

end

end


(*  Title:      Pure/Examples/First_Order_Logic.thy
    Author:     Makarius
*)

section \<open>A simple formulation of First-Order Logic\<close>

text \<open>
  The subsequent theory development illustrates single-sorted intuitionistic
  first-order logic with equality, formulated within the Pure framework.
\<close>

theory First_Order_Logic
  imports Pure
begin

subsection \<open>Abstract syntax\<close>

typedecl i
typedecl o

judgment Trueprop :: "o \<Rightarrow> prop"  ("_" 5)

subsection \<open>Propositional logic\<close>

axiomatization false :: o  ("\<bottom>")
  where falseE [elim]: "\<bottom> \<Longrightarrow> A"

axiomatization imp :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<longrightarrow>" 25)
  where impI [intro]: "(A \<Longrightarrow> B) \<Longrightarrow> A \<longrightarrow> B"
    and mp [dest]: "A \<longrightarrow> B \<Longrightarrow> A \<Longrightarrow> B"

axiomatization conj :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<and>" 35)
  where conjI [intro]: "A \<Longrightarrow> B \<Longrightarrow> A \<and> B"
    and conjD1: "A \<and> B \<Longrightarrow> A"
    and conjD2: "A \<and> B \<Longrightarrow> B"

theorem conjE [elim]:
  assumes "A \<and> B"
  obtains A and B
proof
  from \<open>A \<and> B\<close> show A
    by (rule conjD1)
  from \<open>A \<and> B\<close> show B
    by (rule conjD2)
qed

axiomatization disj :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<or>" 30)
  where disjE [elim]: "A \<or> B \<Longrightarrow> (A \<Longrightarrow> C) \<Longrightarrow> (B \<Longrightarrow> C) \<Longrightarrow> C"
    and disjI1 [intro]: "A \<Longrightarrow> A \<or> B"
    and disjI2 [intro]: "B \<Longrightarrow> A \<or> B"

definition true :: o  ("\<top>")
  where "\<top> \<equiv> \<bottom> \<longrightarrow> \<bottom>"

theorem trueI [intro]: \<top>
  unfolding true_def ..

definition not :: "o \<Rightarrow> o"  ("\<not> _" [40] 40)
  where "\<not> A \<equiv> A \<longrightarrow> \<bottom>"

theorem notI [intro]: "(A \<Longrightarrow> \<bottom>) \<Longrightarrow> \<not> A"
  unfolding not_def ..

theorem notE [elim]: "\<not> A \<Longrightarrow> A \<Longrightarrow> B"
  unfolding not_def
proof -
  assume "A \<longrightarrow> \<bottom>" and A
  then have \<bottom> ..
  then show B ..
qed

definition iff :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<longleftrightarrow>" 25)
  where "A \<longleftrightarrow> B \<equiv> (A \<longrightarrow> B) \<and> (B \<longrightarrow> A)"

theorem iffI [intro]:
  assumes "A \<Longrightarrow> B"
    and "B \<Longrightarrow> A"
  shows "A \<longleftrightarrow> B"
  unfolding iff_def
proof
  from \<open>A \<Longrightarrow> B\<close> show "A \<longrightarrow> B" ..
  from \<open>B \<Longrightarrow> A\<close> show "B \<longrightarrow> A" ..
qed

theorem iff1 [elim]:
  assumes "A \<longleftrightarrow> B" and A
  shows B
proof -
  from \<open>A \<longleftrightarrow> B\<close> have "(A \<longrightarrow> B) \<and> (B \<longrightarrow> A)"
    unfolding iff_def .
  then have "A \<longrightarrow> B" ..
  from this and \<open>A\<close> show B ..
qed

theorem iff2 [elim]:
  assumes "A \<longleftrightarrow> B" and B
  shows A
proof -
  from \<open>A \<longleftrightarrow> B\<close> have "(A \<longrightarrow> B) \<and> (B \<longrightarrow> A)"
    unfolding iff_def .
  then have "B \<longrightarrow> A" ..
  from this and \<open>B\<close> show A ..
qed

subsection \<open>Equality\<close>

axiomatization equal :: "i \<Rightarrow> i \<Rightarrow> o"  (infixl "=" 50)
  where refl [intro]: "x = x"
    and subst: "x = y \<Longrightarrow> P x \<Longrightarrow> P y"

theorem trans [trans]: "x = y \<Longrightarrow> y = z \<Longrightarrow> x = z"
  by (rule subst)

theorem sym [sym]: "x = y \<Longrightarrow> y = x"
proof -
  assume "x = y"
  from this and refl show "y = x"
    by (rule subst)
qed

subsection \<open>Quantifiers\<close>

axiomatization All :: "(i \<Rightarrow> o) \<Rightarrow> o"  (binder "\<forall>" 10)
  where allI [intro]: "(\<And>x. P x) \<Longrightarrow> \<forall>x. P x"
    and allD [dest]: "\<forall>x. P x \<Longrightarrow> P a"

axiomatization Ex :: "(i \<Rightarrow> o) \<Rightarrow> o"  (binder "\<exists>" 10)
  where exI [intro]: "P a \<Longrightarrow> \<exists>x. P x"
    and exE [elim]: "\<exists>x. P x \<Longrightarrow> (\<And>x. P x \<Longrightarrow> C) \<Longrightarrow> C"

lemma "(\<exists>x. P (f x)) \<longrightarrow> (\<exists>y. P y)"
proof
  assume "\<exists>x. P (f x)"
  then obtain x where "P (f x)" ..
  then show "\<exists>y. P y" ..
qed

lemma "(\<exists>x. \<forall>y. R x y) \<longrightarrow> (\<forall>y. \<exists>x. R x y)"
proof
  assume "\<exists>x. \<forall>y. R x y"
  then obtain x where "\<forall>y. R x y" ..
  show "\<forall>y. \<exists>x. R x y"
  proof
    fix y
    from \<open>\<forall>y. R x y\<close> have "R x y" ..
    then show "\<exists>x. R x y" ..
  qed
qed

end


theory Trees2_4
imports Main
begin

datatype bdd = Leaf bool | Branch bdd bdd

(* eval accepts:
     - a function that can tell if a given variable
       number is true or false
     - a starting variable number. variables are numbered
       starting from 0 at root and increases gradually as
       we come down (ordered bdd).
     - a binary decision tree
   responds with the final truth value *)
primrec eval :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> bdd \<Rightarrow> bool"
where
  "eval f n (Leaf b) = b"
| "eval f n (Branch l r) = (if f n then eval f (Suc n) r else eval f (Suc n) l)"

primrec bdd_unop :: "(bool \<Rightarrow> bool) \<Rightarrow> bdd \<Rightarrow> bdd"
where
  "bdd_unop f (Leaf a) = Leaf (f a)"
| "bdd_unop f (Branch l r) = Branch (bdd_unop f l) (bdd_unop f r)"

primrec bdd_binop :: "(bool \<Rightarrow> bool \<Rightarrow> bool) \<Rightarrow> bdd \<Rightarrow> bdd \<Rightarrow> bdd"
where
  "bdd_binop f (Leaf a) b = bdd_unop (f a) b"
| "bdd_binop f (Branch l r) b = (case b of
    Leaf a \<Rightarrow> Branch (bdd_binop f l b) (bdd_binop f r b)
  | Branch l' r' \<Rightarrow> Branch (bdd_binop f l l') (bdd_binop f r r'))"

theorem [simp]: "eval e n (bdd_unop f b) = f (eval e n b)"
  apply (induct b arbitrary:n)
  apply simp+
done

theorem [simp]:"eval e n (bdd_binop f b1 b2) = f (eval e n b1) (eval e n b2)"
  apply (induct b1 arbitrary:n b2)
  apply simp
  apply simp
  apply (case_tac b2)
  apply auto
done

(*
fun bdd_and :: "bdd \<Rightarrow> bdd \<Rightarrow> bdd"
where
  "bdd_and b1 b2 = bdd_binop (\<lambda> x y. x \<and> y) b1 b2"
*)

definition bdd_and: "bdd_and \<equiv> bdd_binop op \<and>"
definition bdd_or: "bdd_or \<equiv> bdd_binop op \<or>"
definition bdd_not: "bdd_not \<equiv> bdd_unop Not"
definition bdd_xor: "bdd_xor b1 b2 \<equiv> bdd_or (bdd_and (bdd_not b1) b2) (bdd_and b1 (bdd_not b2))"

theorem [simp]: "eval e n (bdd_and b1 b2) = (eval e n b1 \<and> eval e n b2)"
  by (auto simp add:bdd_and)

theorem [simp]: "eval e n (bdd_or b1 b2) = (eval e n b1 \<or> eval e n b2)"
  by (auto simp add:bdd_or)

theorem [simp]: "eval e n (bdd_not b) = Not (eval e n b)"
  by (auto simp add:bdd_not)

theorem [simp]:"eval e n (bdd_xor b1 b2) = (let x = (eval e n b1) in let y = (eval e n b2) in (\<not>x \<and> y) \<or> (x \<and> \<not>y) )"
  by (auto simp add:bdd_xor bdd_and bdd_or bdd_not)

primrec bdd_var :: "nat \<Rightarrow> bdd"
where
  "bdd_var 0 = Branch (Leaf False) (Leaf True)"
| "bdd_var (Suc n) = Branch (bdd_var n) (bdd_var n)"

value "bdd_var 0"
value "bdd_var 1"
value "bdd_var 2"

theorem "\<forall> i . e i \<longrightarrow> eval e 0 (bdd_var i)"
(*Unsure about this one *)
oops

(* Solution copied from text *)
theorem [simp]: "\<forall> j. eval e j (bdd_var i) = e (i + j)"
  apply (induct i)
  apply auto
done

datatype form = T | Var nat | And form form | Xor form form

definition xor : "xor x y \<equiv> (\<not>x \<and> y) \<or> (x \<and> \<not>y)"

primrec evalf :: "(nat \<Rightarrow> bool) \<Rightarrow> form \<Rightarrow> bool"
where
  "evalf f T = True"
| "evalf f (Var n) = f n"
| "evalf f (And f1 f2) = (evalf f f1 \<and> evalf f f2)"
| "evalf f (Xor f1 f2) = xor (evalf f f1) (evalf f f2)"

fun mk_bdd :: "form \<Rightarrow> bdd"
where
  "mk_bdd T = Leaf True"
| "mk_bdd (Var n) = bdd_var n"
| "mk_bdd (And f1 f2) = bdd_and (mk_bdd f1) (mk_bdd f2)"
| "mk_bdd (Xor f1 f2) = bdd_xor (mk_bdd f1) (mk_bdd f2)"

value "mk_bdd T"
value "mk_bdd (Var 1)"

theorem "eval e 0 (mk_bdd f) = evalf e f"
  apply (induct f)
  apply (auto simp add:xor)
done

end


theory Ex5_1
  imports Main
begin

primrec insort :: "nat \<Rightarrow> nat list \<Rightarrow> nat list " where
  "insort val [] = [val]"|
  "insort val (x#xs) = (if val \<le> x then val#x#xs else x # insort val xs)"

primrec le :: "nat \<Rightarrow> nat list \<Rightarrow> bool" where
  "le _ [] =  True"|
  "le val (x#xs) = ((val \<le> x)  \<and>   le val xs)"

primrec sorted :: "nat list \<Rightarrow> bool" where
"sorted [] = True"|
"sorted (x#xs) = (le  x xs \<and> sorted xs)"

primrec sort :: "nat list \<Rightarrow> nat list" where
  "sort [] = [] "|
  "sort (x#xs) = insort x (sort xs)"

lemma lem1 [simp]: "x \<le> y \<Longrightarrow> le y xs \<longrightarrow> le x xs"
proof (induction xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case by (cases "y \<le> a"; simp)
qed

lemma helper:"le x xs \<Longrightarrow> insort x xs = x # xs" by (induction xs ; simp)

lemma helper2: "le a xs \<Longrightarrow> a \<le> x \<Longrightarrow> le a (insort x xs)"
proof (induction xs)
  case Nil
  then show ?case by simp
next
  case (Cons aa xs)
  then show ?case by (cases "a \<le> aa" ; simp)
qed

lemma helper3:"\<not> le a xs \<Longrightarrow> le  a (insort x xs) = False" by (induction xs; simp)

lemma helper4:"sorted (insort x xs) = sorted xs"
proof (induction xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  assume hyp:"sorted (Ex5_1.insort x xs) = sorted xs"
  then show ?case
  proof (cases "x \<le> a")
    case True
    then show ?thesis by (cases "le a xs"; simp)
  next
    case False
    assume c1:"\<not> x \<le> a"
    hence tmp:"x > a" by simp
    then show ?thesis
    proof (cases "le x xs")
      case True
      assume c2:"le x xs"
      have tmp2:"a \<le> x" using tmp by simp
      have "sorted (Ex5_1.insort x (a # xs)) = sorted (a # Ex5_1.insort x  xs)" using c1 by simp
      also have "\<dots> = sorted (a # x # xs)" using helper c2 by simp
      also have "\<dots> = (le a (x#xs)  \<and> sorted (x # xs))" by simp
      also have "\<dots> = ((a \<le> x \<and> le a xs) \<and> sorted (x #xs))" by simp
      also have "\<dots> = (le a xs \<and> sorted (x#xs))" using c1 by simp
      also have "\<dots> = sorted xs" using c2 tmp2 by simp
      finally have a:"sorted (Ex5_1.insort x (a # xs)) = sorted xs" by assumption

      have  "Ex5_1.sorted (a # xs) = (le a xs \<and> sorted xs)" by simp
      also have "\<dots> = sorted xs" using tmp2 c2 by simp

      finally show ?thesis using a by simp
    next
      case False
      assume c2:"\<not> le x xs"
      show ?thesis
      proof  (cases "le a xs")
        case True
        then show ?thesis using c1 hyp helper2 by simp
      next
        case False
        assume c3:"\<not>le a xs"
        have f1:"sorted (a # xs)  =  (le a xs \<and> sorted xs)" by simp
        also have "\<dots> = (False \<and> sorted xs)" using c3 by simp
        also have "\<dots> = False" by simp
        finally have res1:"sorted (a # xs) = False" by assumption

        have "sorted (insort x (a # xs)) = sorted (a # insort x xs)" using c1 by simp
        also have "\<dots> =False" using c3 helper3 by simp
        finally show ?thesis using res1 by simp
      qed
    qed
  qed
qed

theorem "sorted (sort xs)"
proof (induction xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  assume "sorted (sort xs)"
  have "sorted (sort (a#xs)) = sorted (insort a (sort xs))" by simp
  then show ?case using helper4 Cons.IH by simp
qed

primrec count :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
  "count [] _ = 0"|
  "count (x#xs) val = (if val = x then 1 else 0) + count xs val"

lemma helper5: "count (insort x xs) y= count (x# xs) y" by (induction xs ; auto)

theorem "count (sort xs) x = count xs x" by (induction xs ; auto simp add : helper5)

datatype bintree = leaf | node nat (l:"bintree") (r:"bintree")

primrec tge :: "nat \<Rightarrow> bintree \<Rightarrow> bool" where
"tge _ leaf = True"|
"tge val (node val2 lft rgt) = (val \<ge> val2 \<and> tge val lft \<and> tge val rgt)"

primrec tle :: "nat \<Rightarrow> bintree \<Rightarrow> bool" where
"tle _ leaf = True"|
"tle val (node val2 lft rgt) = (val \<le> val2 \<and> tle val lft \<and> tle val rgt)"

primrec tsorted :: "bintree \<Rightarrow> bool" where
"tsorted leaf = True"|
"tsorted (node val lft rgt) =  (tsorted lft \<and> tsorted rgt \<and> tge val lft \<and>  tle val rgt)"

primrec ins :: "nat \<Rightarrow> bintree \<Rightarrow> bintree" where
"ins val leaf = node val leaf leaf"|
"ins val (node val2 lft rgt) = (if val < val2 then node val2 (ins val lft ) rgt else node val2 lft (ins val rgt))"

primrec tree_of :: "nat list \<Rightarrow> bintree" where
"tree_of [] = leaf"|
"tree_of (x#xs) = ins x (tree_of xs)"

lemma helper6:"x < y \<Longrightarrow> tge y t \<Longrightarrow> tge y (ins x t)" by (induction t ; simp)

lemma helper7:"x \<ge> y \<Longrightarrow> tle y t \<Longrightarrow> tle y (ins x t)" by (induction t; simp)

lemma helper8:"\<not>tge x t \<Longrightarrow>  \<not>tge x (ins y t)" by (induction t ; auto)

lemma helper9:"\<not>tle x t \<Longrightarrow> \<not>tle x (ins y t)" by (induction t; auto)

lemma helper10: "tsorted (ins x t) = tsorted t"
proof (induction t)
  case leaf
  then show ?case by simp
next
  case (node x1 t1 t2)
  assume hyp1:"tsorted (ins x t1) = tsorted t1"
     and hyp2:"tsorted (ins x t2) = tsorted t2"
  show ?case
  proof (cases "x < x1")
    case True
    assume c1:"x < x1"
    have tmp:"tsorted (ins x (node x1 t1 t2)) = tsorted  (node x1 (ins x t1) t2)" by (simp add : True)
    show ?thesis
    proof (cases "tge x1 t1")
      case True
      then show ?thesis using hyp1 helper6[of x x1 t1] c1 by (cases "tle x1 t1" ; simp)
    next
      case False
      then show ?thesis using helper8[of x1 t1 x] c1 by (cases "tle x1 t2" ; simp)
    qed
  next
    case False
    assume "\<not> x < x1"
    hence c1:"x1 \<le> x" by simp
    then show ?thesis using helper7[of x1 x t2] helper9[of x1 t2 x] hyp2 by (cases "tge x1 t1" ; cases "tle x1 t2" ; auto)
  qed
qed

theorem [simp] : "tsorted (tree_of xs)"
proof (induction xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case using helper10 by simp
qed

primrec tcount :: "bintree \<Rightarrow> nat  \<Rightarrow> nat" where
"tcount leaf _  = 0"|
"tcount (node val2 lft rgt) val = (if val = val2 then 1 else 0) + tcount lft val + tcount rgt val"

lemma helper11: "tcount (ins x t) y = (if y = x then 1 else 0) + tcount t y" by (induction t ; auto)

theorem "tcount (tree_of xs) x = count xs x" using helper11 by (induction xs ; simp)

primrec list_of :: "bintree \<Rightarrow> nat list" where
"list_of leaf = []"|
"list_of (node val lft rgt) = list_of lft @ val # list_of rgt"

primrec ge :: "nat \<Rightarrow> nat list \<Rightarrow> bool" where
"ge _ [] = True"|
"ge val (x#xs) = (val \<ge> x  \<and> ge val xs)"

lemma lem3:"ge x (xs @ ys) = (ge x xs \<and> ge x ys)" by (induction xs ; simp)

lemma helper12 : "sorted (a @ x # b) = (sorted a \<and> sorted b \<and> ge x a \<and> le x b)"
proof (induction a)
  case Nil
  then show ?case by (cases "le x b" ; simp)
next
  case (Cons a1 a2)
  assume hyp:"sorted (a2 @ x # b) = (sorted a2 \<and> sorted b \<and> ge x a2 \<and> le x b)"

  from hyp show ?case by (cases "sorted (a1 # a2) "; cases "sorted b" ; cases " ge x (a1 # a2)" ; cases "le x b" ; auto simp add : lem2)
qed

lemma lem4:"x < y \<Longrightarrow> ge y (list_of (ins x t)) = ge y (list_of t)" by (induction t ; simp add : lem3)

lemma lem5:"y \<le> x \<Longrightarrow> le y (list_of (ins x t)) = le y (list_of t)" by (induction t;  simp add : lem2)

lemma lem6:"sorted (list_of (ins x t)) = sorted (list_of t)"
proof (induction t)
  case leaf
  then show ?case by simp
next
  case (node x1 t1 t2)
  assume hyp1:"sorted (list_of (ins x t1)) = sorted (list_of t1)"
     and hyp2:"sorted (list_of (ins x t2)) = sorted (list_of t2)"
  show ?case
  proof (cases "x < x1")
    case True
    then show ?thesis by (simp add : hyp1 lem4[of x x1 t1] helper12)
  next
    case False
    then show ?thesis by (simp add : hyp2 lem5 helper12)
  qed
qed

theorem "sorted (list_of (tree_of xs))" using lem6 by (induction xs ; simp)

lemma lem7:"count (xs @ ys) x = count xs x + count ys x" by (induction xs ; simp)

lemma lem8:"count (list_of (ins x t)) = count (x # list_of t)"  by (induction t ; auto simp add : lem7)

theorem "count (list_of (tree_of xs)) n = count xs n" by (induction xs ; simp add : lem8)


theory P13 imports Main begin

fun list_union :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"list_union Nil xs = xs" |
"list_union (y # ys) xs =
(if (y \<in> (set xs))
  then (list_union ys xs)
  else (y # list_union ys xs))"

lemma [simp]: "a \<notin> set xs \<Longrightarrow> a \<notin> set ys \<Longrightarrow> a \<notin> set (list_union xs ys)"
  by simp

lemma [rule_format]:
"distinct xs \<longrightarrow>  distinct ys \<longrightarrow> (distinct (list_union xs ys))"
proof (induct xs)
case Nil
  then show ?case by simp
next
  case (Cons a xs)
  have 1:"distinct (a # xs) \<Longrightarrow> a \<notin> (set xs)" by simp
  have 2: "distinct (a # xs) \<Longrightarrow> distinct xs" by simp
  then show ?case
  proof (cases "a \<in> set ys")
  case True
    then show ?thesis
      using Cons.hyps by auto
  next
    case False
    hence "list_union (a # xs) ys = a # list_union xs ys" by simp
    then show ?thesis using Cons.hyps False 1 by auto
  qed
qed

lemma "((\<forall> x \<in> A. P x) \<and> (\<forall> x \<in> B. P x)) \<longrightarrow> (\<forall> x \<in> (A \<union> B). P x)"
  by auto

lemma "\<forall> x \<in> A. Q (f x) \<Longrightarrow> \<forall> y \<in> f ` A. Q y"
  by auto

end


(*  Title:      CoW/Arithmetical_Hints.thy
    Author:     Štěpán Holub, Charles University
    Author:     Martin Raška, Charles University
    Author:     Štěpán Starosta, CTU in Prague

Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
*)

theory Arithmetical_Hints
  imports Main
begin

section "Arithmetical hints"

text\<open>In this section we give some specific auxiliary lemmas on natural numbers.\<close>

lemma zero_diff_eq: "i \<le> j \<Longrightarrow> (0::nat) = j - i  \<Longrightarrow> j = i"
  by simp

lemma zero_less_diff': "i < j \<Longrightarrow> j - i \<noteq> (0::nat)"
   by simp

lemma nat_prod_le: "m \<noteq> (0 :: nat) \<Longrightarrow> m*n \<le> k \<Longrightarrow> n \<le> k"
  using le_trans[of n "m*n" k] by auto

lemma get_div: "(p :: nat) < a \<Longrightarrow> m = (m * a + p) div a"
  by simp

lemma get_mod: "(p :: nat) < a \<Longrightarrow> p = (m * a + p) mod a"
  by simp

lemma plus_one_between:  "(a :: nat) < b \<Longrightarrow> \<not> b < a + 1"
  by auto

lemma quotient_smaller: "k \<noteq> (0 :: nat) \<Longrightarrow>  b \<le> k * b"
  by simp

lemma mult_cancel_le: "b \<noteq> 0 \<Longrightarrow> a*b \<le> c*b \<Longrightarrow> a \<le> (c::nat)"
  by simp

lemma add_lessD2: "k + m < (n::nat) \<Longrightarrow> m < n"
unfolding add.commute[of k] using add_lessD1.

lemma mod_offset:  assumes "M \<noteq> (0 :: nat)"
  obtains k where "n mod M = (l + k) mod M"
proof-
  have "(l + (M - l mod M)) mod M = 0"
    using mod_add_left_eq[of l M "(M - l mod M)", unfolded le_add_diff_inverse[OF mod_le_divisor[OF assms[unfolded neq0_conv]], of l] mod_self, symmetric].
  from mod_add_left_eq[of "(l + (M - l mod M))" M n, symmetric, unfolded this add.commute[of 0] add.comm_neutral]
  have "((l + (M - l mod M)) + n) mod M = n mod M".
  from that[OF this[unfolded add.assoc, symmetric]]
  show thesis.
qed

lemma assumes "q \<noteq> (0::nat)" shows "p \<le> p + q - gcd p q"
  using gcd_le2_nat[OF \<open>q \<noteq> 0\<close>, of p]
  by linarith

lemma less_mult_one: assumes "(m-1)*k < k" obtains "m = 0" | "m = (1::nat)"
  using assms by fastforce

lemma per_lemma_len_le: assumes le: "p + q - gcd p q \<le> (n :: nat)" and "q \<noteq> 0" shows "p \<le> n"
  using le unfolding add_diff_assoc[OF gcd_le2_nat[OF \<open>q \<noteq> 0\<close>], symmetric] by (rule add_leD1)

lemma predE: assumes "k \<noteq> 0" obtains pred where "k = Suc pred"
  using assms not0_implies_Suc by auto

lemma Suc_less_iff_Suc_le: "Suc n < k \<longleftrightarrow> Suc n \<le> k - 1"
   by auto

lemma nat_induct_pair: "P 0 0 \<Longrightarrow> (\<And> m n. P m n \<Longrightarrow> P m (Suc n)) \<Longrightarrow> (\<And> m n. P m n \<Longrightarrow> P (Suc m) n) \<Longrightarrow> P m n"
  by (induction m arbitrary: n) (metis nat_induct, simp)

lemma One_less_Two_le_iff: "1 < k \<longleftrightarrow> 2 \<le> (k :: nat)"
  by fastforce

lemma at_least2_Suc: assumes "2 \<le> k"
  obtains k' where "k = Suc(Suc k')"
  using Suc3_eq_add_3  less_eqE[OF assms] by auto

lemma at_least3_Suc: assumes "3 \<le> k"
  obtains k' where "k = Suc(Suc(Suc k'))"
  using Suc3_eq_add_3  less_eqE[OF assms] by auto

lemma two_three_add_le_mult: assumes "2 \<le> (l::nat)" and  "3 \<le> k" shows "l + k + 1 \<le> l*k"
proof-
  obtain l' where l: "l = Suc (Suc l')"
     using  \<open>2 \<le> l\<close> at_least2_Suc[OF \<open>2 \<le> l\<close>] by blast
  obtain k' where k: "k = Suc (Suc (Suc k'))"
    using  \<open>3 \<le> k\<close> at_least3_Suc[OF \<open>3 \<le> k\<close>] by blast
  show "l + k + 1 \<le> l*k"
    unfolding l k
  by (induct l' k' rule: nat_induct_pair, simp, simp add: add.commute[of "Suc (Suc l')"] mult.commute[of "Suc (Suc l')"], simp_all)
qed

lemmas not0_SucE = not0_implies_Suc[THEN exE]

lemma le1_SucE: assumes "1 \<le> n"
  obtains k where "n = Suc k" using Suc_le_D[OF assms[unfolded One_nat_def]] by blast

lemma Suc_minus:  "k \<noteq> 0 \<Longrightarrow> Suc (k - 1) = k"
   by simp

lemma Suc_minus': "1 \<le> k \<Longrightarrow> Suc(k - 1) = k"
  by simp

lemmas Suc_minus'' = Suc_diff_1

lemma Suc_minus2: "2 \<le> k \<Longrightarrow> Suc (Suc(k - 2)) = k"
  by auto

lemma almost_equal_equal: assumes "(a:: nat) \<noteq> 0" and "b \<noteq> 0" and eq: "k*(a+b) + a = m*(a+b) + b"
  shows "k = m" and "a = b"
proof-
  show "k = m"
  proof (rule linorder_cases[of k m])
    assume "k < m"
    from add_le_mono1[OF mult_le_mono1[OF Suc_leI[OF this]]]
    have "(Suc k)*(a + b) + b \<le> m*(a+b) + b".
    hence False
      using  \<open>b \<noteq> 0\<close> unfolding mult_Suc eq[symmetric] by force
    thus ?thesis by blast
  next
    assume "m < k"
    from add_le_mono1[OF mult_le_mono1[OF Suc_leI[OF this]]]
    have "(Suc m)*(a + b) + a \<le> k*(a+b) + a".
    hence False
      using  \<open>a \<noteq> 0\<close> unfolding mult_Suc eq by force
    thus ?thesis by blast
  qed (simp)
  thus "a = b"
    using eq by auto
qed

end