theory HSV_tasks_2019_solutions_task11 imports Main begin

section \<open>Representation of circuits.\<close>

text \<open>A wire is represented as an integer.\<close>

type_synonym wire = int

datatype gate =
  NOT "wire" "wire"
| AND "wire" "wire" "wire"
| OR "wire" "wire" "wire"
| TRUE "wire"
| FALSE "wire"

text \<open>A circuit is represented as a list gates together with a list of output wires.\<close>

type_synonym circuit = "gate list \<times> wire list"

text \<open>Here are some examples of circuits.\<close>

definition "circuit1 == ([NOT 1 2], [2])"
definition "circuit2 == ([NOT 1 3, NOT 2 4, AND 3 4 5, NOT 5 6], [6])"
definition "circuit3 == ([NOT 1 3, NOT 2 4, NOT 1 7, AND 3 4 5, NOT 5 6], [6])"
definition "circuit4 == ([NOT 1 3, NOT 2 4, NOT 1 7, NOT 7 8, AND 3 4 5, NOT 5 6], [6])"

text \<open>Return the input wire(s) of a gate.\<close>

fun inputs_of where
  "inputs_of (NOT wi _) = {wi}"
| "inputs_of (AND wi1 wi2 _) = {wi1, wi2}"
| "inputs_of (OR wi1 wi2 _) = {wi1, wi2}"
| "inputs_of (TRUE _) = {}"
| "inputs_of (FALSE _) = {}"

text \<open>Return the output wire of a gate.\<close>

fun output_of where
  "output_of (NOT _ wo) = wo"
| "output_of (AND _ _ wo) = wo"
| "output_of (OR _ _ wo) = wo"
| "output_of (TRUE wo) = wo"
| "output_of (FALSE wo) = wo"

section \<open>Evaluating circuits.\<close>

text \<open>A valuation associates every wire with a truth-value.\<close>

type_synonym valuation = "wire \<Rightarrow> bool"

text \<open>A few examples of valuations.\<close>

definition "\<rho>0 == \<lambda>_. True"
definition "\<rho>1 == \<rho>0(1 := True, 2 := False, 3 := True)"
definition "\<rho>2 == \<rho>0(1 := True, 2 := True, 3 := True)"

text \<open>Calculate the output of a single gate, given a valuation.\<close>

fun sim_gate :: "valuation \<Rightarrow> gate \<Rightarrow> bool" where
  "sim_gate \<rho> (NOT wi wo) = (\<not> \<rho> wi)"
| "sim_gate \<rho> (AND wi1 wi2 wo) = (\<rho> wi1 \<and> \<rho> wi2)"
| "sim_gate \<rho> (OR wi1 wi2 wo) = (\<rho> wi1 \<or> \<rho> wi2)"
| "sim_gate \<rho> (TRUE wo) = True"
| "sim_gate \<rho> (FALSE wo) = False"

text \<open>Simulates a list of gates, given an initial valuation. Produces a new valuation.\<close>

fun sim_gates :: "valuation \<Rightarrow> gate list \<Rightarrow> valuation" where
  "sim_gates \<rho> [] = \<rho>"
| "sim_gates \<rho> (g # gs) = sim_gates (\<rho> (output_of g := sim_gate \<rho> g)) gs"

text \<open>Simulates a circuit, given an initial valuation. Produces a list of
      truth-values, one truth-value per output.\<close>

fun sim :: "valuation \<Rightarrow> circuit \<Rightarrow> bool list" where
  "sim \<rho> (gs, wos) = map (sim_gates \<rho> gs) wos"

text \<open>Testing the simulator.\<close>

value "sim \<rho>1 circuit1"
value "sim \<rho>2 circuit1"
value "sim \<rho>1 circuit2"
value "sim \<rho>2 circuit2"
value "sim \<rho>1 circuit3"
value "sim \<rho>2 circuit3"

section \<open>Optimising circuits by removing dead gates.\<close>

text \<open>Return the set of wires that lead to an output.\<close>

fun live_wires where
  "live_wires ([], wos) = set wos"
| "live_wires (g # gs, wos) = (let ws = live_wires (gs, wos) in
     (if output_of g \<in> ws then inputs_of g else {}) \<union> ws)"

value "live_wires ([NOT 1 3, NOT 2 4, NOT 1 7, AND 3 4 5, NOT 5 6], [6])"
value "live_wires ([NOT 1 3, NOT 2 4, NOT 1 7, NOT 7 8, AND 3 4 5, NOT 5 6], [6])"
value "live_wires ([NOT 1 3, NOT 2 4, NOT 1 7, NOT 7 8, AND 3 4 5, NOT 5 6], [6, 8])"
value "live_wires ([NOT 1 3, NOT 2 4, NOT 7 8, AND 3 4 5, NOT 5 6], [6])"

text \<open>This is a helper function for the next function .\<close>

fun remove_dead_inner where
  "remove_dead_inner [] wos = []"
| "remove_dead_inner (g # gs) wos =
   (let gs' = remove_dead_inner gs wos in
   (if output_of g \<in> live_wires (gs', wos) then [g] else []) @ gs')"

text \<open>This function strips out gates that are not needed.\<close>

fun remove_dead where
  "remove_dead (gs, wos) = (remove_dead_inner gs wos, wos)"

value "remove_dead circuit2"
value "remove_dead circuit3"
value "remove_dead circuit4"

section \<open>Proving that removing dead gates does not change a circuit's behaviour.\<close>

text \<open>This lemma is obviously false -- it wrongly claims that remove_dead
      has no effect on a circuit.\<close>

lemma "remove_dead c = c" oops

text \<open>We shall say that two functions are 'congruent on X' if they coincide on all inputs in X.\<close>

fun cong_on where
  "cong_on X f g = (\<forall>x \<in> X. f x = g x)"

text \<open>Congruency is transitive.\<close>

lemma cong_on_trans:
  assumes "cong_on X g h"
  assumes "cong_on X f g"
  shows "cong_on X f h"
  using assms by simp

text \<open>This is a rather technical lemma. It says that if two valuations \<rho> and \<rho>' are
      congruent on all wires that are live in circuit (g # gs, wos), then the
      respective valuations obtained after simulating g remain congruent on all wires
      that are live in circuit (gs, wos). \<close>

lemma cong_on_live_wires:
  assumes "cong_on (live_wires (g # gs, wos)) \<rho> \<rho>'"
  shows "cong_on (live_wires (gs, wos)) (\<rho>(output_of g := sim_gate \<rho> g)) (\<rho>'(output_of g := sim_gate \<rho>' g))"
  using assms
  apply (cases "output_of g \<in> live_wires (gs, wos)", auto)
  apply (cases g, auto)+
  done

text \<open>If valuations \<rho> and \<rho>' are congruent on all wires that are live in circuit (gs, wos), then
      the respective valuations obtained after simulating gs are congruent on all wires in wos.\<close>

lemma cong_sim_gates:
  assumes "cong_on (live_wires (gs, wos)) \<rho> \<rho>'"
  shows "cong_on (set wos) (sim_gates \<rho> gs) (sim_gates \<rho>' gs)"
  using assms
proof (induct gs arbitrary: \<rho> \<rho>')
  case Nil
  thus ?case by auto
next
  case (Cons g gs)
  show ?case
    apply (clarsimp simp del: cong_on.simps)
    apply (rule Cons.hyps[OF cong_on_live_wires[OF Cons.prems]])
    done
qed

text \<open>This is a slightly unwrapped version of the main theorem below.\<close>

lemma sim_remove_dead:
  "cong_on (set wos) (sim_gates \<rho> (remove_dead_inner gs wos)) (sim_gates \<rho> gs)"
proof (induct gs arbitrary: \<rho>)
  case Nil
  thus ?case by simp
next
  case (Cons g gs \<rho>)
  show ?case
  proof (cases "output_of g \<in> live_wires (remove_dead (gs, wos))")
    case True
    thus ?thesis using Cons.hyps by auto
  next
    case False
    thus ?thesis
      apply (simp del: cong_on.simps)
      apply (rule cong_on_trans)
       apply (rule Cons.hyps[of "\<rho>(output_of g := sim_gate \<rho> g)"])
      apply (rule cong_sim_gates)
      apply clarsimp
      done
  qed
qed

text \<open>We define a convenient shorthand for expressing that two circuits have the same behaviour.\<close>

fun sim_equiv (infix "\<sim>" 50) where
  "c1 \<sim> c2 = (\<forall>\<rho>. sim \<rho> c1 = sim \<rho> c2)"

text \<open>Main theorem: removing the dead gates from a circuit does not change its behaviour.\<close>

theorem "remove_dead c \<sim> c"
  using sim_remove_dead by (cases c, auto)

end


theory T90
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=10,timeout=86400]
oops
end


subsection \<open>Simulation of a Register Machine\<close>

theory RegisterMachineSimulation
  imports RegisterMachineProperties "Digit_Expansions.Binary_Operations"
begin

definition B :: "nat \<Rightarrow> nat" where
  "(B c) = 2^(Suc c)"

definition "RLe c p b q l = (\<Sum>t = 0..q. b^t * R c p l t)"
definition "SKe c p b q k = (\<Sum>t = 0..q. b^t * S c p k t)"
definition "ZLe c p b q l = (\<Sum>t = 0..q. b^t * Z c p l t)"

fun sum_radd :: "program \<Rightarrow> register \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> nat"
  where "sum_radd p l f = (\<Sum>k = 0..length p-1. if isadd (p!k) \<and> l = modifies (p!k) then f k else 0)"

abbreviation sum_radd_abbrev ("\<Sum>R+ _ _ _" [999, 999, 999] 1000)
  where "(\<Sum>R+ p l f) \<equiv> (sum_radd p l f)"

fun sum_rsub :: "program \<Rightarrow> register \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> nat"
  where "sum_rsub p l f = (\<Sum>k = 0..length p-1. if issub (p!k) \<and> l = modifies (p!k) then f k else 0)"

abbreviation sum_rsub_abbrev ("\<Sum>R- _ _ _ " [999, 999, 999] 1000)
  where "(\<Sum>R- p l f) \<equiv> (sum_rsub p l f)"

(* Note: different naming convention for sums compared to original paper *)
fun sum_sadd :: "program \<Rightarrow> state \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> nat"
  where "sum_sadd p d f = (\<Sum>k = 0..length p-1. if isadd (p!k) \<and> d = goes_to (p!k) then f k else 0)"

abbreviation sum_sadd_abbrev ("\<Sum>S+ _ _ _ " [999, 999, 999] 1000)
  where "(\<Sum>S+ p d f) \<equiv> (sum_sadd p d f)"

(* careful: f needs be passed the program so that z l t can be properly called with l = modifies (p!k) *)
fun sum_ssub_nzero :: "program \<Rightarrow> state \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> nat"
  where "sum_ssub_nzero p d f = (\<Sum>k = 0..length p-1. if issub (p!k) \<and> d = goes_to (p!k) then f k else 0)"

abbreviation sum_ssub_nzero_abbrev ("\<Sum>S- _ _ _ " [999, 999, 999] 1000)
  where "(\<Sum>S- p d f) \<equiv> (sum_ssub_nzero p d f)"

fun sum_ssub_zero :: "program \<Rightarrow> state \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> nat"
  where "sum_ssub_zero p d f = (\<Sum>k = 0..length p-1. if issub (p!k) \<and> d = goes_to_alt (p!k) then f k else 0)"

abbreviation sum_ssub_zero_abbrev ("\<Sum>S0 _ _ _ " [999, 999, 999] 1000)
  where "(\<Sum>S0 p d f) \<equiv> (sum_ssub_zero p d f)"

declare sum_radd.simps[simp del]
declare sum_rsub.simps[simp del]
declare sum_sadd.simps[simp del]
declare sum_ssub_nzero.simps[simp del]
declare sum_ssub_zero.simps[simp del]

text \<open>Special sum cong lemmas\<close>

lemma sum_sadd_cong:
  assumes "\<forall>k. k \<le> length p-1 \<and> isadd (p!k) \<and> l = goes_to (p!k) \<longrightarrow> f k = g k"
  shows "\<Sum>S+ p l f = \<Sum>S+ p l g"
  unfolding sum_sadd.simps
  by (rule sum.cong, simp) (rule if_cong, simp_all add: assms)

lemma sum_ssub_nzero_cong:
  assumes "\<forall>k. k \<le> length p - 1 \<and> issub (p!k) \<and> l = goes_to (p!k) \<longrightarrow> f k = g k"
  shows "\<Sum>S- p l f = \<Sum>S- p l g"
  unfolding sum_ssub_nzero.simps
  by (rule sum.cong, simp) (rule if_cong, simp_all add: assms)

lemma sum_ssub_zero_cong:
  assumes "\<forall>k. k \<le> length p - 1 \<and> issub (p!k) \<and> l = goes_to_alt (p!k) \<longrightarrow> f k = g k"
  shows "\<Sum>S0 p l f = \<Sum>S0 p l g"
  unfolding sum_ssub_zero.simps
  by (rule sum.cong, simp) (rule if_cong, simp_all add: assms)

lemma sum_radd_cong:
  assumes "\<forall>k. k \<le> length p - 1 \<and> isadd (p!k) \<and> l = modifies (p!k) \<longrightarrow> f k = g k"
  shows "\<Sum>R+ p l f = \<Sum>R+ p l g"
  unfolding sum_radd.simps
  by (rule sum.cong, simp) (rule if_cong, simp_all add: assms)

lemma sum_rsub_cong:
  assumes "\<forall>k. k \<le> length p - 1 \<and> issub (p!k) \<and> l = modifies (p!k) \<longrightarrow> f k = g k"
  shows "\<Sum>R- p l f = \<Sum>R- p l g"
  unfolding sum_rsub.simps
  by (rule sum.cong, simp) (rule if_cong, simp_all add: assms)

text \<open>Properties and simple lemmas\<close>
lemma RLe_equivalent: "RL c p b q l = RLe c p b q l"
  by (induction q arbitrary: c) (auto simp add: RLe_def R_def RL.simps(1) RL_simp)

lemma SKe_equivalent: "SK c p b q k = SKe c p b q k"
  by (induction q arbitrary: c) (auto simp add: SKe_def S_def SK.simps(1) S2_def SK_simp)

lemma ZLe_equivalent: "ZL c p b q l = ZLe c p b q l"
  by (induction q arbitrary: c) (auto simp add: ZLe_def ZL.simps(1) R_def Z2_def Z_def ZL_simp)

lemma sum_radd_distrib: "a * (\<Sum>R+ p l f) = (\<Sum>R+ p l (\<lambda>k. a * f k))"
  by (auto simp add: sum_radd.simps sum_distrib_left; smt mult_is_0 sum.cong)

lemma sum_rsub_distrib: "a * (\<Sum>R- p l f) = (\<Sum>R- p l (\<lambda>k. a * f k))"
  by (auto simp add: sum_rsub.simps sum_distrib_left; smt mult_is_0 sum.cong)

lemma sum_sadd_distrib: "a * (\<Sum>S+ p d f) = (\<Sum>S+ p d (\<lambda>k. a * f k))" for a
  by (auto simp add: sum_sadd.simps sum_distrib_left; smt mult_is_0 sum.cong)

lemma sum_ssub_nzero_distrib: "a * (\<Sum>S- p d f) = (\<Sum>S- p d (\<lambda>k. a * f k))" for a
  by (auto simp add: sum_ssub_nzero.simps sum_distrib_left; smt mult_is_0 sum.cong)

lemma sum_ssub_zero_distrib: "a * (\<Sum>S0 p d f) = (\<Sum>S0 p d (\<lambda>k. a * f k))" for a
  by (auto simp add: sum_ssub_zero.simps sum_distrib_left; smt mult_is_0 sum.cong)

lemma sum_distrib:
  fixes SX :: "program \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> nat"
    and p :: program

assumes SX_simps: "\<And>h. SX p x h = (\<Sum>k = 0..length p-1. if g x k then h k else 0)"

shows "SX p x h1 + SX p x h2 = SX p x (\<lambda>k. h1 k + h2 k)"
  by (subst SX_simps)+ (auto simp: sum.distrib[symmetric] intro: sum.cong)

lemma sum_commutative:
  fixes SX :: "program \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> nat"
    and p :: program

assumes SX_simps: "\<And>h. SX p x h = (\<Sum>k = 0..length p-1. if g x k then h k else 0)"

  shows "(\<Sum>t=0..q::nat. SX p x (\<lambda>k. f k t))
       = (SX p x (\<lambda>k. \<Sum>t=0..q. f k t))"
proof (induction q)
  case 0
  then show ?case by (auto)
next
  case (Suc q)
  have SX_add: "SX p x h1 + SX p x h2 = SX p x (\<lambda>k. h1 k + h2 k)" for h1 h2
    by (subst sum_distrib[where ?h1.0 = "h1"]) (auto simp: SX_simps) +

  have h1: "(\<Sum>t\<le>(Suc q). SX p x (\<lambda>k. f k t)) = SX p x (\<lambda>k. f k (Suc q)) + sum (\<lambda>t. SX p x (\<lambda>k. f k t)) {0..q}"
    by (auto simp add: sum.atLeast0_atMost_Suc add.commute atMost_atLeast0)
  also have h2: "... = SX p x (\<lambda>k. f k (Suc q)) + SX p x (\<lambda>k. sum (f k){0..q})"
    using Suc.IH Suc.prems by auto
  also have h3: "... = SX p x (\<lambda>k. sum (f k) {0..(Suc q)})"
    by (subst SX_add) (auto simp: atLeast0_atMost_Suc)
  finally show ?case using Suc.IH by (simp add: atMost_atLeast0)
qed

lemma sum_radd_commutative: "(\<Sum>t=0..(q::nat). \<Sum>R+ p l (\<lambda>k. f k t)) = (\<Sum>R+ p l (\<lambda>k. \<Sum>t=0..q. f k t))"
  by (rule sum_commutative sum_radd.simps) +
lemma sum_rsub_commutative: "(\<Sum>t=0..(q::nat). \<Sum>R- p l (\<lambda>k. f k t)) = (\<Sum>R- p l (\<lambda>k. \<Sum>t=0..q. f k t))"
  by (rule sum_commutative sum_rsub.simps) +
lemma sum_sadd_commutative: "(\<Sum>t=0..(q::nat). \<Sum>S+ p l (\<lambda>k. f k t)) = (\<Sum>S+ p l (\<lambda>k. \<Sum>t=0..q. f k t))"
  by (rule sum_commutative sum_sadd.simps) +
lemma sum_ssub_nzero_commutative: "(\<Sum>t=0..(q::nat). \<Sum>S- p l (\<lambda>k. f k t)) = (\<Sum>S- p l (\<lambda>k. \<Sum>t=0..q. f k t))"
  by (rule sum_commutative sum_ssub_nzero.simps) +
lemma sum_ssub_zero_commutative: "(\<Sum>t=0..(q::nat). \<Sum>S0 p l (\<lambda>k. f k t)) = (\<Sum>S0 p l (\<lambda>k. \<Sum>t=0..q. f k t))"
  by (rule sum_commutative sum_ssub_zero.simps) +

lemma sum_int: "c \<le> a + b \<Longrightarrow> int(a + b - c) = int(a) + int(b) - int(c)"
  by (simp add: SMT.int_plus)

lemma ZLe_bounded: "b > 2 \<Longrightarrow> ZLe c p b q l < b ^ (Suc q)"
  using Z_bounded ZLe_def
proof (induction q)
  case 0
  then show ?case by (simp add: Z_bounded ZLe_def Z_def)
next
  case (Suc q)
  have "ZLe c p b (Suc q) l = b ^ (Suc q) * Z c p l (Suc q) + ZLe c p b q l"
    by (auto simp: ZLe_def)
  also have "ZLe c p b q l < b ^ (Suc q)" using Suc.IH
    by (auto simp: ZLe_def Z_def Suc.prems(1))
  also have "b ^ (Suc q) * Z c p l (Suc q) \<le> b ^ (Suc q)" using Suc.prems(1)
    by (auto simp: Z_def)
  finally have "ZLe c p b (Suc q) l < 2 * b ^ (Suc q)"
    by auto
  also have "... < b ^ Suc (Suc q)"
    using Suc.prems(1) by auto
  finally show ?case by simp
qed

lemma SKe_bounded: "b > 2 \<Longrightarrow> SKe c p b q k < b ^ (Suc q)"
  proof (induction q)
  case 0
  then show ?case by (auto simp add: SKe_def S_bounded S_def)
next
  case (Suc q)
  have "SKe c p b (Suc q) k = b ^ (Suc q) * S c p k (Suc q) + SKe c p b q k"
    by (auto simp: SKe_def)
  also have "SKe c p b q k < b ^ (Suc q)" using Suc.IH
    by (auto simp: Suc.prems(1))
  also have "b ^ (Suc q) * S c p k (Suc q) \<le> b ^ (Suc q)" using Suc.prems(1)
    by (auto simp: S_def)
  finally have "SKe c p b (Suc q) k < 2 * b ^ (Suc q)"
    by auto
  also have "... < b ^ Suc (Suc q)"
    using Suc.prems(1) by auto
  finally show ?case by simp
qed

lemma mult_to_bitAND:
  assumes cells_bounded: "cells_bounded ic p c"
and "c > 1"
and "b = B c"

shows "(\<Sum>t=0..q. b^t * (Z ic p l t * S ic p k t))
       = ZLe ic p b q l && SKe ic p b q k"
proof (induction q arbitrary: ic p c l k)
  case 0
  then show ?case using S_bounded Z_bounded
    by (auto simp add: SKe_def ZLe_def bitAND_single_bit_mult_equiv)
next
  case (Suc q)

  have b4: "b > 2" using assms(2-3) apply (auto simp add: B_def)
    by (metis One_nat_def Suc_less_eq2 lessI numeral_2_eq_2 power_gt1)

  have ske: "SKe ic p b q k < b ^ (Suc q)" using SKe_bounded b4 by auto
  have zle: "ZLe ic p b q l < b ^ (Suc q)" using ZLe_bounded b4 by auto

  have ih: "(\<Sum>t = 0..q. b ^ t * (Z ic p l t * S ic p k t)) = ZLe ic p b q l && SKe ic p b q k"
    using Suc.IH by auto

  have "(\<Sum>t = 0..Suc q. b ^ t * (Z ic p l t * S ic p k t))
        = b ^(Suc q) * (Z ic p l (Suc q) * S ic p k (Suc q)) + (\<Sum>t = 0..q. b ^ t * (Z ic p l t * S ic p k t))"
    by (auto simp: sum.atLeast0_atMost_Suc add.commute)

  also have "... = b ^ (Suc q) * (Z ic p l (Suc q) * S ic p k (Suc q)) + (ZLe ic p b q l && SKe ic p b q k)"
    by (auto simp add: ih)

  also have "... = b ^ (Suc q) * (Z ic p l (Suc q) && S ic p k (Suc q)) + (ZLe ic p b q l && SKe ic p b q k)"
    using bitAND_single_bit_mult_equiv S_bounded Z_bounded by (auto)

  also have "... = (b ^(Suc q) * Z ic p l (Suc q) + ZLe ic p b q l) && (b ^ (Suc q) * S ic p k (Suc q) + SKe ic p b q k)"
    using bitAND_linear ske zle
    by (auto) (smt B_def assms(3) bitAND_linear mult.commute power_Suc power_mult)

  also have "... = (ZLe ic p b (Suc q) l && SKe ic p b (Suc q) k)"
    by (auto simp: ZLe_def SKe_def add.commute)

  finally show ?case by simp
qed

lemma sum_bt:
  fixes b q :: nat
  assumes "b > 2"
  shows "(\<Sum>t = 0..q. b^t) < b ^ (Suc q)"
    using assms
proof (induction q, auto)
  fix qb :: nat
  assume "sum ((^) b) {0..qb} < b * b ^ qb"
then have f1: "sum ((^) b) {0..qb} < b ^ Suc qb"
  by fastforce
have "b ^ Suc qb * 2 < b ^ Suc (Suc qb)"
  using assms by force
then have "2 * b ^ Suc qb < b ^ Suc (Suc qb)"
  by simp
then have "b ^ Suc qb + sum ((^) b) {0..qb} < b ^ Suc (Suc qb)"
  using f1 by linarith
then show "sum ((^) b) {0..qb} + b * b ^ qb < b * (b * b ^ qb)"
  by simp
qed

lemma mult_to_bitAND_state:
  assumes cells_bounded: "cells_bounded ic p c"
and c: "c > 1"
and b: "b = B c"

shows "(\<Sum>t=0..q. b^t * ((1 - Z ic p l t) * S ic p k t))
       = ((\<Sum>t = 0..q. b^t) - ZLe ic p b q l) && SKe ic p b q k"
proof (induction q arbitrary: ic p c l k)
  case 0
  show ?case using Z_def S_def ZLe_def SKe_def by auto
next
  case (Suc q)

  have b4: "b > 2" using assms(2-3) apply (auto simp add: B_def)
    by (metis One_nat_def Suc_less_eq2 lessI numeral_2_eq_2 power_gt1)

  have ske: "SKe ic p b q k < b ^ (Suc q)" using SKe_bounded b4 by auto
  have zle: "ZLe ic p b q l < b ^ (Suc q)" using ZLe_bounded b4 by auto
  define cst where "cst \<equiv> Suc q"
  define e where "e \<equiv> \<Sum>t = 0..Suc q. b^t"

  have "(\<Sum>t = 0..q. b^t) < b ^ (Suc q)"
    using sum_bt b4 by auto
  hence zle2: "(\<Sum>t = 0..q. b^t) - ZLe ic p b q l < b ^ (Suc q)"
    using less_imp_diff_less by blast

  have "(\<Sum>t = 0..x. b^t) - ZLe ic p b x l = (\<Sum>t=0..x. b^t - b^t * Z ic p l t)" for x
    unfolding ZLe_def
    using Z_bounded sum_subtractf_nat[where ?f = "(^) b" and ?g = "\<lambda>t. b ^ t * Z ic p l t"]
    by auto
  hence aux_sum: "(\<Sum>t = 0..x. b^t) - ZLe ic p b x l = (\<Sum>t=0..x. b^t * (1 - Z ic p l t))" for x
    using diff_Suc_1 diff_mult_distrib2 by auto

  have aux1: "b ^(Suc q) * (1 - Z ic p l (Suc q)) + (\<Sum>t=0..q. b^t * (1 - Z ic p l t))
                    = (\<Sum>t = 0..cst. b ^ t * (1 - Z ic p l t))"
    by (auto simp: sum.atLeast0_atMost_Suc cst_def)
  also have aux2: "... = (\<Sum>t = 0..cst. b ^ t) - ZLe ic p b cst l"
    unfolding e_def ZLe_def using aux_sum[of "cst"]
    by (auto simp: ZLe_def)
  finally have aux_add_sub:
      "(b ^(Suc q) * (1 - Z ic p l (Suc q)) + ((\<Sum>t = 0..q. b^t) - ZLe ic p b q l))
        = (e - ZLe ic p b (Suc q) l)"
    by (auto simp: cst_def e_def aux_sum)

  hence ih: "(\<Sum>t = 0..q. b ^ t * ((1 - Z ic p l t) * S ic p k t))
            = (\<Sum>t = 0..q. b^t) - ZLe ic p b q l && SKe ic p b q k"
    using Suc[of "ic" "p" "l" "k"] by auto

  have "(\<Sum>t = 0..Suc q. b ^ t * ((1 - Z ic p l t) * S ic p k t))
      = (\<Sum>t = 0..    q. b ^ t * ((1 - Z ic p l t) * S ic p k t))
      + b^(Suc q) * ((1 - Z ic p l (Suc q)) * S ic p k (Suc q))"
    by (auto cong: sum.cong)

  also have "... = ((\<Sum>t = 0..q. b^t) - ZLe ic p b q l && SKe ic p b q k)
      + b^(Suc q) * ((1 - Z ic p l (Suc q)) * S ic p k (Suc q))"
    using ih by auto

  also have "... = ((\<Sum>t = 0..q. b^t) - ZLe ic p b q l && SKe ic p b q k)
      +  b^(Suc q) * ((1 - Z ic p l (Suc q)) && S ic p k (Suc q))"
    using bitAND_single_bit_mult_equiv by (simp add: S_def)

  also have "... = (b ^(Suc q) * (1 - Z ic p l (Suc q)) + ((\<Sum>t = 0..q. b^t) - ZLe ic p b q l))
                   && (b ^ (Suc q) * S ic p k (Suc q) + SKe ic p b q k)"
    using bitAND_linear ske zle2 B_def b
    by (smt add_ac(2) mult_ac(2) bitAND_linear power.simps(2) power_mult power_mult_distrib)
  also have "... = (e - ZLe ic p b (Suc q) l && SKe ic p b (Suc q) k)"
    using SKe_def aux_add_sub by (auto simp: add.commute)

  finally show ?case by (auto simp: e_def)
qed

end


theory T125
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_list_PairUnpair
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun unpair :: "(('t, 't) pair) list => 't list" where
  "unpair (nil2) = nil2"
| "unpair (cons2 (pair2 z y2) xys) =
     cons2 z (cons2 y2 (unpair xys))"

fun pairs :: "'t list => (('t, 't) pair) list" where
  "pairs (nil2) = nil2"
| "pairs (cons2 y (nil2)) = nil2"
| "pairs (cons2 y (cons2 y2 xs)) = cons2 (pair2 y y2) (pairs xs)"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 y l) = 1 + (length l)"

theorem property0 :
  "((let eta :: int = length xs
     in ((let md :: int = eta mod 2
          in (if
                (((if (eta = 0) then 0 else (if eta <= 0 then 0 - 1 else 1)) =
                    (if 2 <= 0 then 0 - (0 - 1) else 0 - 1)) &
                   (md ~= 0))
                then
                md - 2
                else
                md)) =
           0)) ==>
      ((unpair (pairs xs)) = xs))"
  oops

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_54
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun t22 :: "Nat => Nat => Nat" where
  "t22 (Z) y = y"
| "t22 (S z) y = S (t22 z y)"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) y = Z"
| "t2 (S z) (Z) = S z"
| "t2 (S z) (S x2) = t2 z x2"

theorem property0 : "((t2 (t22 m n) n) = m)"
  oops

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_17
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun x :: "Nat => Nat => bool" where
  "x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y2) = x x2 y2"

fun t2 :: "Nat => Nat => bool" where
  "t2 (Z) z = True"
| "t2 (S z2) (Z) = False"
| "t2 (S z2) (S x2) = t2 z2 x2"

theorem property0 :
  "((t2 n Z) = (x n Z))"
  oops

end


(*                                                    *)
(* Formalisation of the chapter on Logical Relations  *)
(* and a Case Study in Equivalence Checking           *)
(* by Karl Crary from the book on Advanced Topics in  *)
(* Types and Programming Languages, MIT Press 2005    *)

(* The formalisation was done by Julien Narboux and   *)
(* Christian Urban.                                   *)

theory Crary
  imports "HOL-Nominal.Nominal"
begin

atom_decl name

nominal_datatype ty =
    TBase
  | TUnit
  | Arrow "ty" "ty" ("_\<rightarrow>_" [100,100] 100)

nominal_datatype trm =
    Unit
  | Var "name" ("Var _" [100] 100)
  | Lam "\<guillemotleft>name\<guillemotright>trm" ("Lam [_]._" [100,100] 100)
  | App "trm" "trm" ("App _ _" [110,110] 100)
  | Const "nat"

type_synonym Ctxt  = "(name\<times>ty) list"
type_synonym Subst = "(name\<times>trm) list"

lemma perm_ty[simp]:
  fixes T::"ty"
  and   pi::"name prm"
  shows "pi\<bullet>T = T"
  by (induct T rule: ty.induct) (simp_all)

lemma fresh_ty[simp]:
  fixes x::"name"
  and   T::"ty"
  shows "x\<sharp>T"
  by (simp add: fresh_def supp_def)

lemma ty_cases:
  fixes T::ty
  shows "(\<exists> T\<^sub>1 T\<^sub>2. T=T\<^sub>1\<rightarrow>T\<^sub>2) \<or> T=TUnit \<or> T=TBase"
by (induct T rule:ty.induct) (auto)

instantiation ty :: size
begin

nominal_primrec size_ty
where
  "size (TBase) = 1"
| "size (TUnit) = 1"
| "size (T\<^sub>1\<rightarrow>T\<^sub>2) = size T\<^sub>1 + size T\<^sub>2"
by (rule TrueI)+

instance ..

end

lemma ty_size_greater_zero[simp]:
  fixes T::"ty"
  shows "size T > 0"
by (nominal_induct rule: ty.strong_induct) (simp_all)

section \<open>Substitutions\<close>

fun
  lookup :: "Subst \<Rightarrow> name \<Rightarrow> trm"
where
  "lookup [] x        = Var x"
| "lookup ((y,T)#\<theta>) x = (if x=y then T else lookup \<theta> x)"

lemma lookup_eqvt[eqvt]:
  fixes pi::"name prm"
  shows "pi\<bullet>(lookup \<theta> x) = lookup (pi\<bullet>\<theta>) (pi\<bullet>x)"
by (induct \<theta>) (auto simp add: perm_bij)

lemma lookup_fresh:
  fixes z::"name"
  assumes a: "z\<sharp>\<theta>" "z\<sharp>x"
  shows "z\<sharp> lookup \<theta> x"
using a
by (induct rule: lookup.induct)
   (auto simp add: fresh_list_cons)

lemma lookup_fresh':
  assumes a: "z\<sharp>\<theta>"
  shows "lookup \<theta> z = Var z"
using a
by (induct rule: lookup.induct)
   (auto simp add: fresh_list_cons fresh_prod fresh_atm)

nominal_primrec
  psubst :: "Subst \<Rightarrow> trm \<Rightarrow> trm"  ("_<_>" [100,100] 130)
where
  "\<theta><(Var x)> = (lookup \<theta> x)"
| "\<theta><(App t\<^sub>1 t\<^sub>2)> = App \<theta><t\<^sub>1> \<theta><t\<^sub>2>"
| "x\<sharp>\<theta> \<Longrightarrow> \<theta><(Lam [x].t)> = Lam [x].(\<theta><t>)"
| "\<theta><(Const n)> = Const n"
| "\<theta><(Unit)> = Unit"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: abs_fresh)+
apply(fresh_guess)+
done

abbreviation
 subst :: "trm \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> trm" ("_[_::=_]" [100,100,100] 100)
where
  "t[x::=t']  \<equiv> ([(x,t')])<t>"

lemma subst[simp]:
  shows "(Var x)[y::=t'] = (if x=y then t' else (Var x))"
  and   "(App t\<^sub>1 t\<^sub>2)[y::=t'] = App (t\<^sub>1[y::=t']) (t\<^sub>2[y::=t'])"
  and   "x\<sharp>(y,t') \<Longrightarrow> (Lam [x].t)[y::=t'] = Lam [x].(t[y::=t'])"
  and   "Const n[y::=t'] = Const n"
  and   "Unit [y::=t'] = Unit"
  by (simp_all add: fresh_list_cons fresh_list_nil)

lemma subst_eqvt[eqvt]:
  fixes pi::"name prm"
  shows "pi\<bullet>(t[x::=t']) = (pi\<bullet>t)[(pi\<bullet>x)::=(pi\<bullet>t')]"
  by (nominal_induct t avoiding: x t' rule: trm.strong_induct)
     (perm_simp add: fresh_bij)+

lemma subst_rename:
  fixes c::"name"
  assumes a: "c\<sharp>t\<^sub>1"
  shows "t\<^sub>1[a::=t\<^sub>2] = ([(c,a)]\<bullet>t\<^sub>1)[c::=t\<^sub>2]"
using a
apply(nominal_induct t\<^sub>1 avoiding: a c t\<^sub>2 rule: trm.strong_induct)
apply(simp add: trm.inject calc_atm fresh_atm abs_fresh perm_nat_def)+
done

lemma fresh_psubst:
  fixes z::"name"
  assumes a: "z\<sharp>t" "z\<sharp>\<theta>"
  shows "z\<sharp>(\<theta><t>)"
using a
by (nominal_induct t avoiding: z \<theta> t rule: trm.strong_induct)
   (auto simp add: abs_fresh lookup_fresh)

lemma fresh_subst'':
  fixes z::"name"
  assumes "z\<sharp>t\<^sub>2"
  shows "z\<sharp>t\<^sub>1[z::=t\<^sub>2]"
using assms
by (nominal_induct t\<^sub>1 avoiding: t\<^sub>2 z rule: trm.strong_induct)
   (auto simp add: abs_fresh fresh_nat fresh_atm)

lemma fresh_subst':
  fixes z::"name"
  assumes "z\<sharp>[y].t\<^sub>1" "z\<sharp>t\<^sub>2"
  shows "z\<sharp>t\<^sub>1[y::=t\<^sub>2]"
using assms
by (nominal_induct t\<^sub>1 avoiding: y t\<^sub>2 z rule: trm.strong_induct)
   (auto simp add: abs_fresh fresh_nat fresh_atm)

lemma fresh_subst:
  fixes z::"name"
  assumes a: "z\<sharp>t\<^sub>1" "z\<sharp>t\<^sub>2"
  shows "z\<sharp>t\<^sub>1[y::=t\<^sub>2]"
using a
by (auto simp add: fresh_subst' abs_fresh)

lemma fresh_psubst_simp:
  assumes "x\<sharp>t"
  shows "((x,u)#\<theta>)<t> = \<theta><t>"
using assms
proof (nominal_induct t avoiding: x u \<theta> rule: trm.strong_induct)
  case (Lam y t x u)
  have fs: "y\<sharp>\<theta>" "y\<sharp>x" "y\<sharp>u" by fact+
  moreover have "x\<sharp> Lam [y].t" by fact
  ultimately have "x\<sharp>t" by (simp add: abs_fresh fresh_atm)
  moreover have ih:"\<And>n T. n\<sharp>t \<Longrightarrow> ((n,T)#\<theta>)<t> = \<theta><t>" by fact
  ultimately have "((x,u)#\<theta>)<t> = \<theta><t>" by auto
  moreover have "((x,u)#\<theta>)<Lam [y].t> = Lam [y].(((x,u)#\<theta>)<t>)" using fs
    by (simp add: fresh_list_cons fresh_prod)
  moreover have " \<theta><Lam [y].t> = Lam [y]. (\<theta><t>)" using fs by simp
  ultimately show "((x,u)#\<theta>)<Lam [y].t> = \<theta><Lam [y].t>" by auto
qed (auto simp add: fresh_atm abs_fresh)

lemma forget:
  fixes x::"name"
  assumes a: "x\<sharp>t"
  shows "t[x::=t'] = t"
  using a
by (nominal_induct t avoiding: x t' rule: trm.strong_induct)
   (auto simp add: fresh_atm abs_fresh)

lemma subst_fun_eq:
  fixes u::trm
  assumes h:"[x].t\<^sub>1 = [y].t\<^sub>2"
  shows "t\<^sub>1[x::=u] = t\<^sub>2[y::=u]"
proof -
  {
    assume "x=y" and "t\<^sub>1=t\<^sub>2"
    then have ?thesis using h by simp
  }
  moreover
  {
    assume h1:"x \<noteq> y" and h2:"t\<^sub>1=[(x,y)] \<bullet> t\<^sub>2" and h3:"x \<sharp> t\<^sub>2"
    then have "([(x,y)] \<bullet> t\<^sub>2)[x::=u] = t\<^sub>2[y::=u]" by (simp add: subst_rename)
    then have ?thesis using h2 by simp
  }
  ultimately show ?thesis using alpha h by blast
qed

lemma psubst_empty[simp]:
  shows "[]<t> = t"
by (nominal_induct t rule: trm.strong_induct)
   (auto simp add: fresh_list_nil)

lemma psubst_subst_psubst:
  assumes h:"c\<sharp>\<theta>"
  shows "\<theta><t>[c::=s] = ((c,s)#\<theta>)<t>"
  using h
by (nominal_induct t avoiding: \<theta> c s rule: trm.strong_induct)
   (auto simp add: fresh_list_cons fresh_atm forget lookup_fresh lookup_fresh' fresh_psubst)

lemma subst_fresh_simp:
  assumes a: "x\<sharp>\<theta>"
  shows "\<theta><Var x> = Var x"
using a
by (induct \<theta> arbitrary: x) (auto simp add:fresh_list_cons fresh_prod fresh_atm)

lemma psubst_subst_propagate:
  assumes "x\<sharp>\<theta>"
  shows "\<theta><t[x::=u]> = \<theta><t>[x::=\<theta><u>]"
using assms
proof (nominal_induct t avoiding: x u \<theta> rule: trm.strong_induct)
  case (Var n x u \<theta>)
  { assume "x=n"
    moreover have "x\<sharp>\<theta>" by fact
    ultimately have "\<theta><Var n[x::=u]> = \<theta><Var n>[x::=\<theta><u>]" using subst_fresh_simp by auto
  }
  moreover
  { assume h:"x\<noteq>n"
    then have "x\<sharp>Var n" by (auto simp add: fresh_atm)
    moreover have "x\<sharp>\<theta>" by fact
    ultimately have "x\<sharp>\<theta><Var n>" using fresh_psubst by blast
    then have " \<theta><Var n>[x::=\<theta><u>] =  \<theta><Var n>" using forget by auto
    then have "\<theta><Var n[x::=u]> = \<theta><Var n>[x::=\<theta><u>]" using h by auto
  }
  ultimately show ?case by auto
next
  case (Lam n t x u \<theta>)
  have fs:"n\<sharp>x" "n\<sharp>u" "n\<sharp>\<theta>" "x\<sharp>\<theta>" by fact+
  have ih:"\<And> y s \<theta>. y\<sharp>\<theta> \<Longrightarrow> ((\<theta><(t[y::=s])>) = ((\<theta><t>)[y::=(\<theta><s>)]))" by fact
  have "\<theta> <(Lam [n].t)[x::=u]> = \<theta><Lam [n]. (t [x::=u])>" using fs by auto
  then have "\<theta> <(Lam [n].t)[x::=u]> = Lam [n]. \<theta><t [x::=u]>" using fs by auto
  moreover have "\<theta><t[x::=u]> = \<theta><t>[x::=\<theta><u>]" using ih fs by blast
  ultimately have "\<theta> <(Lam [n].t)[x::=u]> = Lam [n].(\<theta><t>[x::=\<theta><u>])" by auto
  moreover have "Lam [n].(\<theta><t>[x::=\<theta><u>]) = (Lam [n].\<theta><t>)[x::=\<theta><u>]" using fs fresh_psubst by auto
  ultimately have "\<theta><(Lam [n].t)[x::=u]> = (Lam [n].\<theta><t>)[x::=\<theta><u>]" using fs by auto
  then show "\<theta><(Lam [n].t)[x::=u]> = \<theta><Lam [n].t>[x::=\<theta><u>]" using fs by auto
qed (auto)

section \<open>Typing\<close>

inductive
  valid :: "Ctxt \<Rightarrow> bool"
where
  v_nil[intro]:  "valid []"
| v_cons[intro]: "\<lbrakk>valid \<Gamma>;a\<sharp>\<Gamma>\<rbrakk> \<Longrightarrow> valid ((a,T)#\<Gamma>)"

equivariance valid

inductive_cases
  valid_cons_elim_auto[elim]:"valid ((x,T)#\<Gamma>)"

abbreviation
  "sub_context" :: "Ctxt \<Rightarrow> Ctxt \<Rightarrow> bool" (" _ \<subseteq> _ " [55,55] 55)
where
  "\<Gamma>\<^sub>1 \<subseteq> \<Gamma>\<^sub>2 \<equiv> \<forall>a T. (a,T)\<in>set \<Gamma>\<^sub>1 \<longrightarrow> (a,T)\<in>set \<Gamma>\<^sub>2"

lemma valid_monotonicity[elim]:
 fixes \<Gamma> \<Gamma>' :: Ctxt
 assumes a: "\<Gamma> \<subseteq> \<Gamma>'"
 and     b: "x\<sharp>\<Gamma>'"
 shows "(x,T\<^sub>1)#\<Gamma> \<subseteq> (x,T\<^sub>1)#\<Gamma>'"
using a b by auto

lemma fresh_context:
  fixes  \<Gamma> :: "Ctxt"
  and    a :: "name"
  assumes "a\<sharp>\<Gamma>"
  shows "\<not>(\<exists>\<tau>::ty. (a,\<tau>)\<in>set \<Gamma>)"
using assms
by (induct \<Gamma>)
   (auto simp add: fresh_prod fresh_list_cons fresh_atm)

lemma type_unicity_in_context:
  assumes a: "valid \<Gamma>"
  and     b: "(x,T\<^sub>1) \<in> set \<Gamma>"
  and     c: "(x,T\<^sub>2) \<in> set \<Gamma>"
  shows "T\<^sub>1=T\<^sub>2"
using a b c
by (induct \<Gamma>)
   (auto dest!: fresh_context)

inductive
  typing :: "Ctxt\<Rightarrow>trm\<Rightarrow>ty\<Rightarrow>bool" (" _ \<turnstile> _ : _ " [60,60,60] 60)
where
  T_Var[intro]:   "\<lbrakk>valid \<Gamma>; (x,T)\<in>set \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Var x : T"
| T_App[intro]:   "\<lbrakk>\<Gamma> \<turnstile> e\<^sub>1 : T\<^sub>1\<rightarrow>T\<^sub>2; \<Gamma> \<turnstile> e\<^sub>2 : T\<^sub>1\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> App e\<^sub>1 e\<^sub>2 : T\<^sub>2"
| T_Lam[intro]:   "\<lbrakk>x\<sharp>\<Gamma>; (x,T\<^sub>1)#\<Gamma> \<turnstile> t : T\<^sub>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [x].t : T\<^sub>1\<rightarrow>T\<^sub>2"
| T_Const[intro]: "valid \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> Const n : TBase"
| T_Unit[intro]:  "valid \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> Unit : TUnit"

equivariance typing

nominal_inductive typing
  by (simp_all add: abs_fresh)

lemma typing_implies_valid:
  assumes a: "\<Gamma> \<turnstile> t : T"
  shows "valid \<Gamma>"
  using a by (induct) (auto)

declare trm.inject [simp add]
declare ty.inject  [simp add]

inductive_cases typing_inv_auto[elim]:
  "\<Gamma> \<turnstile> Lam [x].t : T"
  "\<Gamma> \<turnstile> Var x : T"
  "\<Gamma> \<turnstile> App x y : T"
  "\<Gamma> \<turnstile> Const n : T"
  "\<Gamma> \<turnstile> Unit : TUnit"
  "\<Gamma> \<turnstile> s : TUnit"

declare trm.inject [simp del]
declare ty.inject [simp del]

section \<open>Definitional Equivalence\<close>

inductive
  def_equiv :: "Ctxt\<Rightarrow>trm\<Rightarrow>trm\<Rightarrow>ty\<Rightarrow>bool" ("_ \<turnstile> _ \<equiv> _ : _" [60,60] 60)
where
  Q_Refl[intro]:  "\<Gamma> \<turnstile> t : T \<Longrightarrow> \<Gamma> \<turnstile> t \<equiv> t : T"
| Q_Symm[intro]:  "\<Gamma> \<turnstile> t \<equiv> s : T \<Longrightarrow> \<Gamma> \<turnstile> s \<equiv> t : T"
| Q_Trans[intro]: "\<lbrakk>\<Gamma> \<turnstile> s \<equiv> t : T; \<Gamma> \<turnstile> t \<equiv> u : T\<rbrakk> \<Longrightarrow>  \<Gamma> \<turnstile> s \<equiv> u : T"
| Q_Abs[intro]:   "\<lbrakk>x\<sharp>\<Gamma>; (x,T\<^sub>1)#\<Gamma> \<turnstile> s\<^sub>2 \<equiv> t\<^sub>2 : T\<^sub>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [x]. s\<^sub>2 \<equiv>  Lam [x]. t\<^sub>2 : T\<^sub>1 \<rightarrow> T\<^sub>2"
| Q_App[intro]:   "\<lbrakk>\<Gamma> \<turnstile> s\<^sub>1 \<equiv> t\<^sub>1 : T\<^sub>1 \<rightarrow> T\<^sub>2 ; \<Gamma> \<turnstile> s\<^sub>2 \<equiv> t\<^sub>2 : T\<^sub>1\<rbrakk> \<Longrightarrow>  \<Gamma> \<turnstile> App s\<^sub>1 s\<^sub>2 \<equiv> App t\<^sub>1 t\<^sub>2 : T\<^sub>2"
| Q_Beta[intro]:  "\<lbrakk>x\<sharp>(\<Gamma>,s\<^sub>2,t\<^sub>2); (x,T\<^sub>1)#\<Gamma> \<turnstile> s\<^sub>1 \<equiv> t\<^sub>1 : T\<^sub>2 ; \<Gamma> \<turnstile> s\<^sub>2 \<equiv> t\<^sub>2 : T\<^sub>1\<rbrakk>
                   \<Longrightarrow>  \<Gamma> \<turnstile> App (Lam [x]. s\<^sub>1) s\<^sub>2 \<equiv> t\<^sub>1[x::=t\<^sub>2] : T\<^sub>2"
| Q_Ext[intro]:   "\<lbrakk>x\<sharp>(\<Gamma>,s,t); (x,T\<^sub>1)#\<Gamma> \<turnstile> App s (Var x) \<equiv> App t (Var x) : T\<^sub>2\<rbrakk>
                   \<Longrightarrow> \<Gamma> \<turnstile> s \<equiv> t : T\<^sub>1 \<rightarrow> T\<^sub>2"
| Q_Unit[intro]:  "\<lbrakk>\<Gamma> \<turnstile> s : TUnit; \<Gamma> \<turnstile> t: TUnit\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s \<equiv> t : TUnit"

equivariance def_equiv

nominal_inductive def_equiv
  by (simp_all add: abs_fresh fresh_subst'')

lemma def_equiv_implies_valid:
  assumes a: "\<Gamma> \<turnstile> t \<equiv> s : T"
  shows "valid \<Gamma>"
using a by (induct) (auto elim: typing_implies_valid)

section \<open>Weak Head Reduction\<close>

inductive
  whr_def :: "trm\<Rightarrow>trm\<Rightarrow>bool" ("_ \<leadsto> _" [80,80] 80)
where
  QAR_Beta[intro]: "App (Lam [x]. t\<^sub>1) t\<^sub>2 \<leadsto> t\<^sub>1[x::=t\<^sub>2]"
| QAR_App[intro]:  "t\<^sub>1 \<leadsto> t\<^sub>1' \<Longrightarrow> App t\<^sub>1 t\<^sub>2 \<leadsto> App t\<^sub>1' t\<^sub>2"

declare trm.inject  [simp add]
declare ty.inject  [simp add]

inductive_cases whr_inv_auto[elim]:
  "t \<leadsto> t'"
  "Lam [x].t \<leadsto> t'"
  "App (Lam [x].t12) t2 \<leadsto> t"
  "Var x \<leadsto> t"
  "Const n \<leadsto> t"
  "App p q \<leadsto> t"
  "t \<leadsto> Const n"
  "t \<leadsto> Var x"
  "t \<leadsto> App p q"

declare trm.inject  [simp del]
declare ty.inject  [simp del]

equivariance whr_def

section \<open>Weak Head Normalisation\<close>

abbreviation
 nf :: "trm \<Rightarrow> bool" ("_ \<leadsto>|" [100] 100)
where
  "t\<leadsto>|  \<equiv> \<not>(\<exists> u. t \<leadsto> u)"

inductive
  whn_def :: "trm\<Rightarrow>trm\<Rightarrow>bool" ("_ \<Down> _" [80,80] 80)
where
  QAN_Reduce[intro]: "\<lbrakk>s \<leadsto> t; t \<Down> u\<rbrakk> \<Longrightarrow> s \<Down> u"
| QAN_Normal[intro]: "t\<leadsto>|  \<Longrightarrow> t \<Down> t"

declare trm.inject[simp]

inductive_cases whn_inv_auto[elim]: "t \<Down> t'"

declare trm.inject[simp del]

equivariance whn_def

lemma red_unicity :
  assumes a: "x \<leadsto> a"
  and     b: "x \<leadsto> b"
  shows "a=b"
  using a b
apply (induct arbitrary: b)
apply (erule whr_inv_auto(3))
apply (clarify)
apply (rule subst_fun_eq)
apply (simp)
apply (force)
apply (erule whr_inv_auto(6))
apply (blast)+
done

lemma nf_unicity :
  assumes "x \<Down> a" and "x \<Down> b"
  shows "a=b"
  using assms
proof (induct arbitrary: b)
  case (QAN_Reduce x t a b)
  have h:"x \<leadsto> t" "t \<Down> a" by fact+
  have ih:"\<And>b. t \<Down> b \<Longrightarrow> a = b" by fact
  have "x \<Down> b" by fact
  then obtain t' where "x \<leadsto> t'" and hl:"t' \<Down> b" using h by auto
  then have "t=t'" using h red_unicity by auto
  then show "a=b" using ih hl by auto
qed (auto)

section \<open>Algorithmic Term Equivalence and Algorithmic Path Equivalence\<close>

inductive
  alg_equiv :: "Ctxt\<Rightarrow>trm\<Rightarrow>trm\<Rightarrow>ty\<Rightarrow>bool" ("_ \<turnstile> _ \<Leftrightarrow> _ : _" [60,60,60,60] 60)
and
  alg_path_equiv :: "Ctxt\<Rightarrow>trm\<Rightarrow>trm\<Rightarrow>ty\<Rightarrow>bool" ("_ \<turnstile> _ \<leftrightarrow> _ : _" [60,60,60,60] 60)
where
  QAT_Base[intro]:  "\<lbrakk>s \<Down> p; t \<Down> q; \<Gamma> \<turnstile> p \<leftrightarrow> q : TBase\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s \<Leftrightarrow> t : TBase"
| QAT_Arrow[intro]: "\<lbrakk>x\<sharp>(\<Gamma>,s,t); (x,T\<^sub>1)#\<Gamma> \<turnstile> App s (Var x) \<Leftrightarrow> App t (Var x) : T\<^sub>2\<rbrakk>
                     \<Longrightarrow> \<Gamma> \<turnstile> s \<Leftrightarrow> t : T\<^sub>1 \<rightarrow> T\<^sub>2"
| QAT_One[intro]:   "valid \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> s \<Leftrightarrow> t : TUnit"
| QAP_Var[intro]:   "\<lbrakk>valid \<Gamma>;(x,T) \<in> set \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Var x \<leftrightarrow> Var x : T"
| QAP_App[intro]:   "\<lbrakk>\<Gamma> \<turnstile> p \<leftrightarrow> q : T\<^sub>1 \<rightarrow> T\<^sub>2; \<Gamma> \<turnstile> s \<Leftrightarrow> t : T\<^sub>1\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> App p s \<leftrightarrow> App q t : T\<^sub>2"
| QAP_Const[intro]: "valid \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> Const n \<leftrightarrow> Const n : TBase"

equivariance alg_equiv

nominal_inductive alg_equiv
  avoids QAT_Arrow: x
  by simp_all

declare trm.inject [simp add]
declare ty.inject  [simp add]

inductive_cases alg_equiv_inv_auto[elim]:
  "\<Gamma> \<turnstile> s\<Leftrightarrow>t : TBase"
  "\<Gamma> \<turnstile> s\<Leftrightarrow>t : T\<^sub>1 \<rightarrow> T\<^sub>2"
  "\<Gamma> \<turnstile> s\<leftrightarrow>t : TBase"
  "\<Gamma> \<turnstile> s\<leftrightarrow>t : TUnit"
  "\<Gamma> \<turnstile> s\<leftrightarrow>t : T\<^sub>1 \<rightarrow> T\<^sub>2"

  "\<Gamma> \<turnstile> Var x \<leftrightarrow> t : T"
  "\<Gamma> \<turnstile> Var x \<leftrightarrow> t : T'"
  "\<Gamma> \<turnstile> s \<leftrightarrow> Var x : T"
  "\<Gamma> \<turnstile> s \<leftrightarrow> Var x : T'"
  "\<Gamma> \<turnstile> Const n \<leftrightarrow> t : T"
  "\<Gamma> \<turnstile> s \<leftrightarrow> Const n : T"
  "\<Gamma> \<turnstile> App p s \<leftrightarrow> t : T"
  "\<Gamma> \<turnstile> s \<leftrightarrow> App q t : T"
  "\<Gamma> \<turnstile> Lam[x].s \<leftrightarrow> t : T"
  "\<Gamma> \<turnstile> t \<leftrightarrow> Lam[x].s : T"

declare trm.inject [simp del]
declare ty.inject [simp del]

lemma Q_Arrow_strong_inversion:
  assumes fs: "x\<sharp>\<Gamma>" "x\<sharp>t" "x\<sharp>u"
  and h: "\<Gamma> \<turnstile> t \<Leftrightarrow> u : T\<^sub>1\<rightarrow>T\<^sub>2"
  shows "(x,T\<^sub>1)#\<Gamma> \<turnstile> App t (Var x) \<Leftrightarrow> App u (Var x) : T\<^sub>2"
proof -
  obtain y where fs2: "y\<sharp>(\<Gamma>,t,u)" and "(y,T\<^sub>1)#\<Gamma> \<turnstile> App t (Var y) \<Leftrightarrow> App u (Var y) : T\<^sub>2"
    using h by auto
  then have "([(x,y)]\<bullet>((y,T\<^sub>1)#\<Gamma>)) \<turnstile> [(x,y)]\<bullet> App t (Var y) \<Leftrightarrow> [(x,y)]\<bullet> App u (Var y) : T\<^sub>2"
    using  alg_equiv.eqvt[simplified] by blast
  then show ?thesis using fs fs2 by (perm_simp)
qed

(*
Warning this lemma is false:

lemma algorithmic_type_unicity:
  shows "\<lbrakk> \<Gamma> \<turnstile> s \<Leftrightarrow> t : T ; \<Gamma> \<turnstile> s \<Leftrightarrow> u : T' \<rbrakk> \<Longrightarrow> T = T'"
  and "\<lbrakk> \<Gamma> \<turnstile> s \<leftrightarrow> t : T ; \<Gamma> \<turnstile> s \<leftrightarrow> u : T' \<rbrakk> \<Longrightarrow> T = T'"

Here is the counter example :
\<Gamma> \<turnstile> Const n \<Leftrightarrow> Const n : Tbase and \<Gamma> \<turnstile> Const n \<Leftrightarrow> Const n : TUnit
*)

lemma algorithmic_path_type_unicity:
  shows "\<Gamma> \<turnstile> s \<leftrightarrow> t : T \<Longrightarrow> \<Gamma> \<turnstile> s \<leftrightarrow> u : T' \<Longrightarrow> T = T'"
proof (induct arbitrary:  u T'
       rule: alg_equiv_alg_path_equiv.inducts(2) [of _ _ _ _ _  "%a b c d . True"    ])
  case (QAP_Var \<Gamma> x T u T')
  have "\<Gamma> \<turnstile> Var x \<leftrightarrow> u : T'" by fact
  then have "u=Var x" and "(x,T') \<in> set \<Gamma>" by auto
  moreover have "valid \<Gamma>" "(x,T) \<in> set \<Gamma>" by fact+
  ultimately show "T=T'" using type_unicity_in_context by auto
next
  case (QAP_App \<Gamma> p q T\<^sub>1 T\<^sub>2 s t u T\<^sub>2')
  have ih:"\<And>u T. \<Gamma> \<turnstile> p \<leftrightarrow> u : T \<Longrightarrow> T\<^sub>1\<rightarrow>T\<^sub>2 = T" by fact
  have "\<Gamma> \<turnstile> App p s \<leftrightarrow> u : T\<^sub>2'" by fact
  then obtain r t T\<^sub>1' where "u = App r t"  "\<Gamma> \<turnstile> p \<leftrightarrow> r : T\<^sub>1' \<rightarrow> T\<^sub>2'" by auto
  with ih have "T\<^sub>1\<rightarrow>T\<^sub>2 = T\<^sub>1' \<rightarrow> T\<^sub>2'" by auto
  then show "T\<^sub>2=T\<^sub>2'" using ty.inject by auto
qed (auto)

lemma alg_path_equiv_implies_valid:
  shows  "\<Gamma> \<turnstile> s \<Leftrightarrow> t : T \<Longrightarrow> valid \<Gamma>"
  and    "\<Gamma> \<turnstile> s \<leftrightarrow> t : T \<Longrightarrow> valid \<Gamma>"
by (induct rule : alg_equiv_alg_path_equiv.inducts) auto

lemma algorithmic_symmetry:
  shows "\<Gamma> \<turnstile> s \<Leftrightarrow> t : T \<Longrightarrow> \<Gamma> \<turnstile> t \<Leftrightarrow> s : T"
  and   "\<Gamma> \<turnstile> s \<leftrightarrow> t : T \<Longrightarrow> \<Gamma> \<turnstile> t \<leftrightarrow> s : T"
by (induct rule: alg_equiv_alg_path_equiv.inducts)
   (auto simp add: fresh_prod)

lemma algorithmic_transitivity:
  shows "\<Gamma> \<turnstile> s \<Leftrightarrow> t : T \<Longrightarrow> \<Gamma> \<turnstile> t \<Leftrightarrow> u : T \<Longrightarrow> \<Gamma> \<turnstile> s \<Leftrightarrow> u : T"
  and   "\<Gamma> \<turnstile> s \<leftrightarrow> t : T \<Longrightarrow> \<Gamma> \<turnstile> t \<leftrightarrow> u : T \<Longrightarrow> \<Gamma> \<turnstile> s \<leftrightarrow> u : T"
proof (nominal_induct \<Gamma> s t T and \<Gamma> s t T avoiding: u rule: alg_equiv_alg_path_equiv.strong_inducts)
  case (QAT_Base s p t q \<Gamma> u)
  have "\<Gamma> \<turnstile> t \<Leftrightarrow> u : TBase" by fact
  then obtain r' q' where b1: "t \<Down> q'" and b2: "u \<Down> r'" and b3: "\<Gamma> \<turnstile> q' \<leftrightarrow> r' : TBase" by auto
  have ih: "\<Gamma> \<turnstile> q \<leftrightarrow> r' : TBase \<Longrightarrow> \<Gamma> \<turnstile> p \<leftrightarrow> r' : TBase" by fact
  have "t \<Down> q" by fact
  with b1 have eq: "q=q'" by (simp add: nf_unicity)
  with ih b3 have "\<Gamma> \<turnstile> p \<leftrightarrow> r' : TBase" by simp
  moreover
  have "s \<Down> p" by fact
  ultimately show "\<Gamma> \<turnstile> s \<Leftrightarrow> u : TBase" using b2 by auto
next
  case (QAT_Arrow  x \<Gamma> s t T\<^sub>1 T\<^sub>2 u)
  have ih:"(x,T\<^sub>1)#\<Gamma> \<turnstile> App t (Var x) \<Leftrightarrow> App u (Var x) : T\<^sub>2
                                   \<Longrightarrow> (x,T\<^sub>1)#\<Gamma> \<turnstile> App s (Var x) \<Leftrightarrow> App u (Var x) : T\<^sub>2" by fact
  have fs: "x\<sharp>\<Gamma>" "x\<sharp>s" "x\<sharp>t" "x\<sharp>u" by fact+
  have "\<Gamma> \<turnstile> t \<Leftrightarrow> u : T\<^sub>1\<rightarrow>T\<^sub>2" by fact
  then have "(x,T\<^sub>1)#\<Gamma> \<turnstile> App t (Var x) \<Leftrightarrow> App u (Var x) : T\<^sub>2" using fs
    by (simp add: Q_Arrow_strong_inversion)
  with ih have "(x,T\<^sub>1)#\<Gamma> \<turnstile> App s (Var x) \<Leftrightarrow> App u (Var x) : T\<^sub>2" by simp
  then show "\<Gamma> \<turnstile> s \<Leftrightarrow> u : T\<^sub>1\<rightarrow>T\<^sub>2" using fs by (auto simp add: fresh_prod)
next
  case (QAP_App \<Gamma> p q T\<^sub>1 T\<^sub>2 s t u)
  have "\<Gamma> \<turnstile> App q t \<leftrightarrow> u : T\<^sub>2" by fact
  then obtain r T\<^sub>1' v where ha: "\<Gamma> \<turnstile> q \<leftrightarrow> r : T\<^sub>1'\<rightarrow>T\<^sub>2" and hb: "\<Gamma> \<turnstile> t \<Leftrightarrow> v : T\<^sub>1'" and eq: "u = App r v"
    by auto
  have ih1: "\<Gamma> \<turnstile> q \<leftrightarrow> r : T\<^sub>1\<rightarrow>T\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> p \<leftrightarrow> r : T\<^sub>1\<rightarrow>T\<^sub>2" by fact
  have ih2:"\<Gamma> \<turnstile> t \<Leftrightarrow> v : T\<^sub>1 \<Longrightarrow> \<Gamma> \<turnstile> s \<Leftrightarrow> v : T\<^sub>1" by fact
  have "\<Gamma> \<turnstile> p \<leftrightarrow> q : T\<^sub>1\<rightarrow>T\<^sub>2" by fact
  then have "\<Gamma> \<turnstile> q \<leftrightarrow> p : T\<^sub>1\<rightarrow>T\<^sub>2" by (simp add: algorithmic_symmetry)
  with ha have "T\<^sub>1'\<rightarrow>T\<^sub>2 = T\<^sub>1\<rightarrow>T\<^sub>2" using algorithmic_path_type_unicity by simp
  then have "T\<^sub>1' = T\<^sub>1" by (simp add: ty.inject)
  then have "\<Gamma> \<turnstile> s \<Leftrightarrow> v : T\<^sub>1" "\<Gamma> \<turnstile> p \<leftrightarrow> r : T\<^sub>1\<rightarrow>T\<^sub>2" using ih1 ih2 ha hb by auto
  then show "\<Gamma> \<turnstile> App p s \<leftrightarrow> u : T\<^sub>2" using eq by auto
qed (auto)

lemma algorithmic_weak_head_closure:
  shows "\<Gamma> \<turnstile> s \<Leftrightarrow> t : T \<Longrightarrow> s' \<leadsto> s \<Longrightarrow> t' \<leadsto> t \<Longrightarrow> \<Gamma> \<turnstile> s' \<Leftrightarrow> t' : T"
apply (nominal_induct \<Gamma> s t T avoiding: s' t'
    rule: alg_equiv_alg_path_equiv.strong_inducts(1) [of _ _ _ _ "%a b c d e. True"])
apply(auto intro!: QAT_Arrow)
done

lemma algorithmic_monotonicity:
  shows "\<Gamma> \<turnstile> s \<Leftrightarrow> t : T \<Longrightarrow> \<Gamma> \<subseteq> \<Gamma>' \<Longrightarrow> valid \<Gamma>' \<Longrightarrow> \<Gamma>' \<turnstile> s \<Leftrightarrow> t : T"
  and   "\<Gamma> \<turnstile> s \<leftrightarrow> t : T \<Longrightarrow> \<Gamma> \<subseteq> \<Gamma>' \<Longrightarrow> valid \<Gamma>' \<Longrightarrow> \<Gamma>' \<turnstile> s \<leftrightarrow> t : T"
proof (nominal_induct \<Gamma> s t T and \<Gamma> s t T avoiding: \<Gamma>' rule: alg_equiv_alg_path_equiv.strong_inducts)
 case (QAT_Arrow x \<Gamma> s t T\<^sub>1 T\<^sub>2 \<Gamma>')
  have fs:"x\<sharp>\<Gamma>" "x\<sharp>s" "x\<sharp>t" "x\<sharp>\<Gamma>'" by fact+
  have h2:"\<Gamma> \<subseteq> \<Gamma>'" by fact
  have ih:"\<And>\<Gamma>'. \<lbrakk>(x,T\<^sub>1)#\<Gamma> \<subseteq> \<Gamma>'; valid \<Gamma>'\<rbrakk>  \<Longrightarrow> \<Gamma>' \<turnstile> App s (Var x) \<Leftrightarrow> App t (Var x) : T\<^sub>2" by fact
  have "valid \<Gamma>'" by fact
  then have "valid ((x,T\<^sub>1)#\<Gamma>')" using fs by auto
  moreover
  have sub: "(x,T\<^sub>1)#\<Gamma> \<subseteq> (x,T\<^sub>1)#\<Gamma>'" using h2 by auto
  ultimately have "(x,T\<^sub>1)#\<Gamma>' \<turnstile> App s (Var x) \<Leftrightarrow> App t (Var x) : T\<^sub>2" using ih by simp
  then show "\<Gamma>' \<turnstile> s \<Leftrightarrow> t : T\<^sub>1\<rightarrow>T\<^sub>2" using fs by (auto simp add: fresh_prod)
qed (auto)

lemma path_equiv_implies_nf:
  assumes "\<Gamma> \<turnstile> s \<leftrightarrow> t : T"
  shows "s \<leadsto>|" and "t \<leadsto>|"
using assms
by (induct rule: alg_equiv_alg_path_equiv.inducts(2)) (simp, auto)

section \<open>Logical Equivalence\<close>

function log_equiv :: "(Ctxt \<Rightarrow> trm \<Rightarrow> trm \<Rightarrow> ty \<Rightarrow> bool)" ("_ \<turnstile> _ is _ : _" [60,60,60,60] 60)
where
   "\<Gamma> \<turnstile> s is t : TUnit = True"
 | "\<Gamma> \<turnstile> s is t : TBase = \<Gamma> \<turnstile> s \<Leftrightarrow> t : TBase"
 | "\<Gamma> \<turnstile> s is t : (T\<^sub>1 \<rightarrow> T\<^sub>2) =
    (\<forall>\<Gamma>' s' t'. \<Gamma>\<subseteq>\<Gamma>' \<longrightarrow> valid \<Gamma>' \<longrightarrow> \<Gamma>' \<turnstile> s' is t' : T\<^sub>1 \<longrightarrow>  (\<Gamma>' \<turnstile> (App s s') is (App t t') : T\<^sub>2))"
apply (auto simp add: ty.inject)
apply (subgoal_tac "(\<exists>T\<^sub>1 T\<^sub>2. b=T\<^sub>1 \<rightarrow> T\<^sub>2) \<or> b=TUnit \<or> b=TBase" )
apply (force)
apply (rule ty_cases)
done

termination by lexicographic_order

lemma logical_monotonicity:
 fixes \<Gamma> \<Gamma>' :: Ctxt
 assumes a1: "\<Gamma> \<turnstile> s is t : T"
 and     a2: "\<Gamma> \<subseteq> \<Gamma>'"
 and     a3: "valid \<Gamma>'"
 shows "\<Gamma>' \<turnstile> s is t : T"
using a1 a2 a3
proof (induct arbitrary: \<Gamma>' rule: log_equiv.induct)
  case (2 \<Gamma> s t \<Gamma>')
  then show "\<Gamma>' \<turnstile> s is t : TBase" using algorithmic_monotonicity by auto
next
  case (3 \<Gamma> s t T\<^sub>1 T\<^sub>2 \<Gamma>')
  have "\<Gamma> \<turnstile> s is t : T\<^sub>1\<rightarrow>T\<^sub>2"
  and  "\<Gamma> \<subseteq> \<Gamma>'"
  and  "valid \<Gamma>'" by fact+
  then show "\<Gamma>' \<turnstile> s is t : T\<^sub>1\<rightarrow>T\<^sub>2" by simp
qed (auto)

corollary corollary_main:
  assumes a: "\<Gamma> \<turnstile> s \<leftrightarrow> t : T"
  shows "\<Gamma> \<turnstile> s \<Leftrightarrow> t : T"
using a main_lemma alg_path_equiv_implies_valid by blast

lemma logical_symmetry:
  assumes a: "\<Gamma> \<turnstile> s is t : T"
  shows "\<Gamma> \<turnstile> t is s : T"
using a
by (nominal_induct arbitrary: \<Gamma> s t rule: ty.strong_induct)
   (auto simp add: algorithmic_symmetry)

lemma logical_transitivity:
  assumes "\<Gamma> \<turnstile> s is t : T" "\<Gamma> \<turnstile> t is u : T"
  shows "\<Gamma> \<turnstile> s is u : T"
using assms
proof (nominal_induct arbitrary: \<Gamma> s t u  rule:ty.strong_induct)
  case TBase
  then show "\<Gamma> \<turnstile> s is u : TBase" by (auto elim:  algorithmic_transitivity)
next
  case (Arrow T\<^sub>1 T\<^sub>2 \<Gamma> s t u)
  have h1:"\<Gamma> \<turnstile> s is t : T\<^sub>1 \<rightarrow> T\<^sub>2" by fact
  have h2:"\<Gamma> \<turnstile> t is u : T\<^sub>1 \<rightarrow> T\<^sub>2" by fact
  have ih1:"\<And>\<Gamma> s t u. \<lbrakk>\<Gamma> \<turnstile> s is t : T\<^sub>1; \<Gamma> \<turnstile> t is u : T\<^sub>1\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s is u : T\<^sub>1" by fact
  have ih2:"\<And>\<Gamma> s t u. \<lbrakk>\<Gamma> \<turnstile> s is t : T\<^sub>2; \<Gamma> \<turnstile> t is u : T\<^sub>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s is u : T\<^sub>2" by fact
  {
    fix \<Gamma>' s' u'
    assume hsub:"\<Gamma> \<subseteq> \<Gamma>'" and hl:"\<Gamma>' \<turnstile> s' is u' : T\<^sub>1" and hk: "valid \<Gamma>'"
    then have "\<Gamma>' \<turnstile> u' is s' : T\<^sub>1" using logical_symmetry by blast
    then have "\<Gamma>' \<turnstile> u' is u' : T\<^sub>1" using ih1 hl by blast
    then have "\<Gamma>' \<turnstile> App t u' is App u u' : T\<^sub>2" using h2 hsub hk by auto
    moreover have "\<Gamma>' \<turnstile>  App s s' is App t u' : T\<^sub>2" using h1 hsub hl hk by auto
    ultimately have "\<Gamma>' \<turnstile>  App s s' is App u u' : T\<^sub>2" using ih2 by blast
  }
  then show "\<Gamma> \<turnstile> s is u : T\<^sub>1 \<rightarrow> T\<^sub>2" by auto
qed (auto)

lemma logical_weak_head_closure:
  assumes a: "\<Gamma> \<turnstile> s is t : T"
  and     b: "s' \<leadsto> s"
  and     c: "t' \<leadsto> t"
  shows "\<Gamma> \<turnstile> s' is t' : T"
using a b c algorithmic_weak_head_closure
by (nominal_induct arbitrary: \<Gamma> s t s' t' rule: ty.strong_induct)
   (auto, blast)

lemma logical_weak_head_closure':
  assumes "\<Gamma> \<turnstile> s is t : T" and "s' \<leadsto> s"
  shows "\<Gamma> \<turnstile> s' is t : T"
using assms
proof (nominal_induct arbitrary: \<Gamma> s t s' rule: ty.strong_induct)
  case (TBase  \<Gamma> s t s')
  then show ?case by force
next
  case (TUnit \<Gamma> s t s')
  then show ?case by auto
next
  case (Arrow T\<^sub>1 T\<^sub>2 \<Gamma> s t s')
  have h1:"s' \<leadsto> s" by fact
  have ih:"\<And>\<Gamma> s t s'. \<lbrakk>\<Gamma> \<turnstile> s is t : T\<^sub>2; s' \<leadsto> s\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s' is t : T\<^sub>2" by fact
  have h2:"\<Gamma> \<turnstile> s is t : T\<^sub>1\<rightarrow>T\<^sub>2" by fact
  then
  have hb:"\<forall>\<Gamma>' s' t'. \<Gamma>\<subseteq>\<Gamma>' \<longrightarrow> valid \<Gamma>' \<longrightarrow> \<Gamma>' \<turnstile> s' is t' : T\<^sub>1 \<longrightarrow> (\<Gamma>' \<turnstile> (App s s') is (App t t') : T\<^sub>2)"
    by auto
  {
    fix \<Gamma>' s\<^sub>2 t\<^sub>2
    assume "\<Gamma> \<subseteq> \<Gamma>'" and "\<Gamma>' \<turnstile> s\<^sub>2 is t\<^sub>2 : T\<^sub>1" and "valid \<Gamma>'"
    then have "\<Gamma>' \<turnstile> (App s s\<^sub>2) is (App t t\<^sub>2) : T\<^sub>2" using hb by auto
    moreover have "(App s' s\<^sub>2)  \<leadsto> (App s s\<^sub>2)" using h1 by auto
    ultimately have "\<Gamma>' \<turnstile> App s' s\<^sub>2 is App t t\<^sub>2 : T\<^sub>2" using ih by auto
  }
  then show "\<Gamma> \<turnstile> s' is t : T\<^sub>1\<rightarrow>T\<^sub>2" by auto
qed

abbreviation
 log_equiv_for_psubsts :: "Ctxt \<Rightarrow> Subst \<Rightarrow> Subst \<Rightarrow> Ctxt \<Rightarrow> bool"  ("_ \<turnstile> _ is _ over _" [60,60] 60)
where
  "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma> \<equiv> \<forall>x T. (x,T) \<in> set \<Gamma> \<longrightarrow> \<Gamma>' \<turnstile> \<theta><Var x> is  \<theta>'<Var x> : T"

lemma logical_pseudo_reflexivity:
  assumes "\<Gamma>' \<turnstile> t is s over \<Gamma>"
  shows "\<Gamma>' \<turnstile> s is s over \<Gamma>"
proof -
  from assms have "\<Gamma>' \<turnstile> s is t over \<Gamma>" using logical_symmetry by blast
  with assms show "\<Gamma>' \<turnstile> s is s over \<Gamma>" using logical_transitivity by blast
qed

lemma logical_subst_monotonicity :
  fixes \<Gamma> \<Gamma>' \<Gamma>'' :: Ctxt
  assumes a: "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
  and     b: "\<Gamma>' \<subseteq> \<Gamma>''"
  and     c: "valid \<Gamma>''"
  shows "\<Gamma>'' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
using a b c logical_monotonicity by blast

lemma equiv_subst_ext :
  assumes h1: "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
  and     h2: "\<Gamma>' \<turnstile> s is t : T"
  and     fs: "x\<sharp>\<Gamma>"
  shows "\<Gamma>' \<turnstile> (x,s)#\<theta> is (x,t)#\<theta>' over (x,T)#\<Gamma>"
using assms
proof -
  {
    fix y U
    assume "(y,U) \<in> set ((x,T)#\<Gamma>)"
    moreover
    {
      assume "(y,U) \<in> set [(x,T)]"
      with h2 have "\<Gamma>' \<turnstile> ((x,s)#\<theta>)<Var y> is ((x,t)#\<theta>')<Var y> : U" by auto
    }
    moreover
    {
      assume hl:"(y,U) \<in> set \<Gamma>"
      then have "\<not> y\<sharp>\<Gamma>" by (induct \<Gamma>) (auto simp add: fresh_list_cons fresh_atm fresh_prod)
      then have hf:"x\<sharp> Var y" using fs by (auto simp add: fresh_atm)
      then have "((x,s)#\<theta>)<Var y> = \<theta><Var y>" "((x,t)#\<theta>')<Var y> = \<theta>'<Var y>"
        using fresh_psubst_simp by blast+
      moreover have  "\<Gamma>' \<turnstile> \<theta><Var y> is \<theta>'<Var y> : U" using h1 hl by auto
      ultimately have "\<Gamma>' \<turnstile> ((x,s)#\<theta>)<Var y> is ((x,t)#\<theta>')<Var y> : U" by auto
    }
    ultimately have "\<Gamma>' \<turnstile> ((x,s)#\<theta>)<Var y> is ((x,t)#\<theta>')<Var y> : U" by auto
  }
  then show "\<Gamma>' \<turnstile> (x,s)#\<theta> is (x,t)#\<theta>' over (x,T)#\<Gamma>" by auto
qed

theorem fundamental_theorem_1:
  assumes a1: "\<Gamma> \<turnstile> t : T"
  and     a2: "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
  and     a3: "valid \<Gamma>'"
  shows "\<Gamma>' \<turnstile> \<theta><t> is \<theta>'<t> : T"
using a1 a2 a3
proof (nominal_induct \<Gamma> t T avoiding: \<theta> \<theta>' arbitrary: \<Gamma>' rule: typing.strong_induct)
  case (T_Lam x \<Gamma> T\<^sub>1 t\<^sub>2 T\<^sub>2 \<theta> \<theta>' \<Gamma>')
  have vc: "x\<sharp>\<theta>" "x\<sharp>\<theta>'" "x\<sharp>\<Gamma>" by fact+
  have asm1: "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>" by fact
  have ih:"\<And>\<theta> \<theta>' \<Gamma>'. \<lbrakk>\<Gamma>' \<turnstile> \<theta> is \<theta>' over (x,T\<^sub>1)#\<Gamma>; valid \<Gamma>'\<rbrakk> \<Longrightarrow> \<Gamma>' \<turnstile> \<theta><t\<^sub>2> is \<theta>'<t\<^sub>2> : T\<^sub>2" by fact
  show "\<Gamma>' \<turnstile> \<theta><Lam [x].t\<^sub>2> is \<theta>'<Lam [x].t\<^sub>2> : T\<^sub>1\<rightarrow>T\<^sub>2" using vc
  proof (simp, intro strip)
    fix \<Gamma>'' s' t'
    assume sub: "\<Gamma>' \<subseteq> \<Gamma>''"
    and    asm2: "\<Gamma>''\<turnstile> s' is t' : T\<^sub>1"
    and    val: "valid \<Gamma>''"
    from asm1 val sub have "\<Gamma>'' \<turnstile> \<theta> is \<theta>' over \<Gamma>" using logical_subst_monotonicity by blast
    with asm2 vc have "\<Gamma>'' \<turnstile> (x,s')#\<theta> is (x,t')#\<theta>' over (x,T\<^sub>1)#\<Gamma>" using equiv_subst_ext by blast
    with ih val have "\<Gamma>'' \<turnstile> ((x,s')#\<theta>)<t\<^sub>2> is ((x,t')#\<theta>')<t\<^sub>2> : T\<^sub>2" by auto
    with vc have "\<Gamma>''\<turnstile>\<theta><t\<^sub>2>[x::=s'] is \<theta>'<t\<^sub>2>[x::=t'] : T\<^sub>2" by (simp add: psubst_subst_psubst)
    moreover
    have "App (Lam [x].\<theta><t\<^sub>2>) s' \<leadsto> \<theta><t\<^sub>2>[x::=s']" by auto
    moreover
    have "App (Lam [x].\<theta>'<t\<^sub>2>) t' \<leadsto> \<theta>'<t\<^sub>2>[x::=t']" by auto
    ultimately show "\<Gamma>''\<turnstile> App (Lam [x].\<theta><t\<^sub>2>) s' is App (Lam [x].\<theta>'<t\<^sub>2>) t' : T\<^sub>2"
      using logical_weak_head_closure by auto
  qed
qed (auto)

theorem fundamental_theorem_2:
  assumes h1: "\<Gamma> \<turnstile> s \<equiv> t : T"
  and     h2: "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
  and     h3: "valid \<Gamma>'"
  shows "\<Gamma>' \<turnstile> \<theta><s> is \<theta>'<t> : T"
using h1 h2 h3
proof (nominal_induct \<Gamma> s t T avoiding: \<Gamma>' \<theta> \<theta>' rule: def_equiv.strong_induct)
  case (Q_Refl \<Gamma> t T \<Gamma>' \<theta> \<theta>')
  have "\<Gamma> \<turnstile> t : T"
  and  "valid \<Gamma>'" by fact+
  moreover
  have "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>" by fact
  ultimately show "\<Gamma>' \<turnstile> \<theta><t> is \<theta>'<t> : T" using fundamental_theorem_1 by blast
next
  case (Q_Symm \<Gamma> t s T \<Gamma>' \<theta> \<theta>')
  have "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
  and "valid \<Gamma>'" by fact+
  moreover
  have ih: "\<And> \<Gamma>' \<theta> \<theta>'. \<lbrakk>\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>; valid \<Gamma>'\<rbrakk> \<Longrightarrow> \<Gamma>' \<turnstile> \<theta><t> is \<theta>'<s> : T" by fact
  ultimately show "\<Gamma>' \<turnstile> \<theta><s> is \<theta>'<t> : T" using logical_symmetry by blast
next
  case (Q_Trans \<Gamma> s t T u \<Gamma>' \<theta> \<theta>')
  have ih1: "\<And> \<Gamma>' \<theta> \<theta>'. \<lbrakk>\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>; valid \<Gamma>'\<rbrakk> \<Longrightarrow> \<Gamma>' \<turnstile> \<theta><s> is \<theta>'<t> : T" by fact
  have ih2: "\<And> \<Gamma>' \<theta> \<theta>'. \<lbrakk>\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>; valid \<Gamma>'\<rbrakk> \<Longrightarrow> \<Gamma>' \<turnstile> \<theta><t> is \<theta>'<u> : T" by fact
  have h: "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
  and  v: "valid \<Gamma>'" by fact+
  then have "\<Gamma>' \<turnstile> \<theta>' is \<theta>' over \<Gamma>" using logical_pseudo_reflexivity by auto
  then have "\<Gamma>' \<turnstile> \<theta>'<t> is \<theta>'<u> : T" using ih2 v by auto
  moreover have "\<Gamma>' \<turnstile> \<theta><s> is \<theta>'<t> : T" using ih1 h v by auto
  ultimately show "\<Gamma>' \<turnstile> \<theta><s> is \<theta>'<u> : T" using logical_transitivity by blast
next
  case (Q_Abs x \<Gamma> T\<^sub>1 s\<^sub>2 t\<^sub>2 T\<^sub>2 \<Gamma>' \<theta> \<theta>')
  have fs:"x\<sharp>\<Gamma>" by fact
  have fs2: "x\<sharp>\<theta>" "x\<sharp>\<theta>'" by fact+
  have h2: "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
  and  h3: "valid \<Gamma>'" by fact+
  have ih:"\<And>\<Gamma>' \<theta> \<theta>'. \<lbrakk>\<Gamma>' \<turnstile> \<theta> is \<theta>' over (x,T\<^sub>1)#\<Gamma>; valid \<Gamma>'\<rbrakk> \<Longrightarrow> \<Gamma>' \<turnstile> \<theta><s\<^sub>2> is \<theta>'<t\<^sub>2> : T\<^sub>2" by fact
  {
    fix \<Gamma>'' s' t'
    assume "\<Gamma>' \<subseteq> \<Gamma>''" and hl:"\<Gamma>''\<turnstile> s' is t' : T\<^sub>1" and hk: "valid \<Gamma>''"
    then have "\<Gamma>'' \<turnstile> \<theta> is \<theta>' over \<Gamma>" using h2 logical_subst_monotonicity by blast
    then have "\<Gamma>'' \<turnstile> (x,s')#\<theta> is (x,t')#\<theta>' over (x,T\<^sub>1)#\<Gamma>" using equiv_subst_ext hl fs by blast
    then have "\<Gamma>'' \<turnstile> ((x,s')#\<theta>)<s\<^sub>2> is ((x,t')#\<theta>')<t\<^sub>2> : T\<^sub>2" using ih hk by blast
    then have "\<Gamma>''\<turnstile> \<theta><s\<^sub>2>[x::=s'] is \<theta>'<t\<^sub>2>[x::=t'] : T\<^sub>2" using fs2 psubst_subst_psubst by auto
    moreover have "App (Lam [x]. \<theta><s\<^sub>2>) s' \<leadsto>  \<theta><s\<^sub>2>[x::=s']"
              and "App (Lam [x].\<theta>'<t\<^sub>2>) t' \<leadsto> \<theta>'<t\<^sub>2>[x::=t']" by auto
    ultimately have "\<Gamma>'' \<turnstile> App (Lam [x]. \<theta><s\<^sub>2>) s' is App (Lam [x].\<theta>'<t\<^sub>2>) t' : T\<^sub>2"
      using logical_weak_head_closure by auto
  }
  moreover have "valid \<Gamma>'" by fact
  ultimately have "\<Gamma>' \<turnstile> Lam [x].\<theta><s\<^sub>2> is Lam [x].\<theta>'<t\<^sub>2> : T\<^sub>1\<rightarrow>T\<^sub>2" by auto
  then show "\<Gamma>' \<turnstile> \<theta><Lam [x].s\<^sub>2> is \<theta>'<Lam [x].t\<^sub>2> : T\<^sub>1\<rightarrow>T\<^sub>2" using fs2 by auto
next
  case (Q_App \<Gamma> s\<^sub>1 t\<^sub>1 T\<^sub>1 T\<^sub>2 s\<^sub>2 t\<^sub>2 \<Gamma>' \<theta> \<theta>')
  then show "\<Gamma>' \<turnstile> \<theta><App s\<^sub>1 s\<^sub>2> is \<theta>'<App t\<^sub>1 t\<^sub>2> : T\<^sub>2" by auto
next
  case (Q_Beta x \<Gamma> s\<^sub>2 t\<^sub>2 T\<^sub>1 s12 t12 T\<^sub>2 \<Gamma>' \<theta> \<theta>')
  have h: "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
  and  h': "valid \<Gamma>'" by fact+
  have fs: "x\<sharp>\<Gamma>" by fact
  have fs2: " x\<sharp>\<theta>" "x\<sharp>\<theta>'" by fact+
  have ih1: "\<And>\<Gamma>' \<theta> \<theta>'. \<lbrakk>\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>; valid \<Gamma>'\<rbrakk> \<Longrightarrow> \<Gamma>' \<turnstile> \<theta><s\<^sub>2> is \<theta>'<t\<^sub>2> : T\<^sub>1" by fact
  have ih2: "\<And>\<Gamma>' \<theta> \<theta>'. \<lbrakk>\<Gamma>' \<turnstile> \<theta> is \<theta>' over (x,T\<^sub>1)#\<Gamma>; valid \<Gamma>'\<rbrakk> \<Longrightarrow> \<Gamma>' \<turnstile> \<theta><s12> is \<theta>'<t12> : T\<^sub>2" by fact
  have "\<Gamma>' \<turnstile> \<theta><s\<^sub>2> is \<theta>'<t\<^sub>2> : T\<^sub>1" using ih1 h' h by auto
  then have "\<Gamma>' \<turnstile> (x,\<theta><s\<^sub>2>)#\<theta> is (x,\<theta>'<t\<^sub>2>)#\<theta>' over (x,T\<^sub>1)#\<Gamma>" using equiv_subst_ext h fs by blast
  then have "\<Gamma>' \<turnstile> ((x,\<theta><s\<^sub>2>)#\<theta>)<s12> is ((x,\<theta>'<t\<^sub>2>)#\<theta>')<t12> : T\<^sub>2" using ih2 h' by auto
  then have "\<Gamma>' \<turnstile> \<theta><s12>[x::=\<theta><s\<^sub>2>] is \<theta>'<t12>[x::=\<theta>'<t\<^sub>2>] : T\<^sub>2" using fs2 psubst_subst_psubst by auto
  then have "\<Gamma>' \<turnstile> \<theta><s12>[x::=\<theta><s\<^sub>2>] is \<theta>'<t12[x::=t\<^sub>2]> : T\<^sub>2" using fs2 psubst_subst_propagate by auto
  moreover have "App (Lam [x].\<theta><s12>) (\<theta><s\<^sub>2>) \<leadsto> \<theta><s12>[x::=\<theta><s\<^sub>2>]" by auto
  ultimately have "\<Gamma>' \<turnstile> App (Lam [x].\<theta><s12>) (\<theta><s\<^sub>2>) is \<theta>'<t12[x::=t\<^sub>2]> : T\<^sub>2"
    using logical_weak_head_closure' by auto
  then show "\<Gamma>' \<turnstile> \<theta><App (Lam [x].s12) s\<^sub>2> is \<theta>'<t12[x::=t\<^sub>2]> : T\<^sub>2" using fs2 by simp
next
  case (Q_Ext x \<Gamma> s t T\<^sub>1 T\<^sub>2 \<Gamma>' \<theta> \<theta>')
  have h2: "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
  and  h2': "valid \<Gamma>'" by fact+
  have fs:"x\<sharp>\<Gamma>" "x\<sharp>s" "x\<sharp>t" by fact+
  have ih:"\<And>\<Gamma>' \<theta> \<theta>'. \<lbrakk>\<Gamma>' \<turnstile> \<theta> is \<theta>' over (x,T\<^sub>1)#\<Gamma>; valid \<Gamma>'\<rbrakk>
                          \<Longrightarrow> \<Gamma>' \<turnstile> \<theta><App s (Var x)> is \<theta>'<App t (Var x)> : T\<^sub>2" by fact
   {
    fix \<Gamma>'' s' t'
    assume hsub: "\<Gamma>' \<subseteq> \<Gamma>''" and hl: "\<Gamma>''\<turnstile> s' is t' : T\<^sub>1" and hk: "valid \<Gamma>''"
    then have "\<Gamma>'' \<turnstile> \<theta> is \<theta>' over \<Gamma>" using h2 logical_subst_monotonicity by blast
    then have "\<Gamma>'' \<turnstile> (x,s')#\<theta> is (x,t')#\<theta>' over (x,T\<^sub>1)#\<Gamma>" using equiv_subst_ext hl fs by blast
    then have "\<Gamma>'' \<turnstile> ((x,s')#\<theta>)<App s (Var x)>  is ((x,t')#\<theta>')<App t (Var x)> : T\<^sub>2" using ih hk by blast
    then
    have "\<Gamma>'' \<turnstile> App (((x,s')#\<theta>)<s>) (((x,s')#\<theta>)<(Var x)>) is App (((x,t')#\<theta>')<t>) (((x,t')#\<theta>')<(Var x)>) : T\<^sub>2"
      by auto
    then have "\<Gamma>'' \<turnstile> App ((x,s')#\<theta>)<s> s'  is App ((x,t')#\<theta>')<t> t' : T\<^sub>2" by auto
    then have "\<Gamma>'' \<turnstile> App (\<theta><s>) s' is App (\<theta>'<t>) t' : T\<^sub>2" using fs fresh_psubst_simp by auto
  }
  moreover have "valid \<Gamma>'" by fact
  ultimately show "\<Gamma>' \<turnstile> \<theta><s> is \<theta>'<t> : T\<^sub>1\<rightarrow>T\<^sub>2" by auto
next
  case (Q_Unit \<Gamma> s t \<Gamma>' \<theta> \<theta>')
  then show "\<Gamma>' \<turnstile> \<theta><s> is \<theta>'<t> : TUnit" by auto
qed

theorem completeness:
  assumes asm: "\<Gamma> \<turnstile> s \<equiv> t : T"
  shows   "\<Gamma> \<turnstile> s \<Leftrightarrow> t : T"
proof -
  have val: "valid \<Gamma>" using def_equiv_implies_valid asm by simp
  moreover
  {
    fix x T
    assume "(x,T) \<in> set \<Gamma>" "valid \<Gamma>"
    then have "\<Gamma> \<turnstile> Var x is Var x : T" using main_lemma(2) by blast
  }
  ultimately have "\<Gamma> \<turnstile> [] is [] over \<Gamma>" by auto
  then have "\<Gamma> \<turnstile> []<s> is []<t> : T" using fundamental_theorem_2 val asm by blast
  then have "\<Gamma> \<turnstile> s is t : T" by simp
  then show  "\<Gamma> \<turnstile> s \<Leftrightarrow> t : T" using main_lemma(1) val by simp
qed

text \<open>We leave soundness as an exercise - just like Crary in the ATS book :-) \\
 @{prop[mode=IfThen] "\<lbrakk>\<Gamma> \<turnstile> s \<Leftrightarrow> t : T; \<Gamma> \<turnstile> t : T; \<Gamma> \<turnstile> s : T\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s \<equiv> t : T"} \\
 \<^prop>\<open>\<lbrakk>\<Gamma> \<turnstile> s \<leftrightarrow> t : T; \<Gamma> \<turnstile> t : T; \<Gamma> \<turnstile> s : T\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s \<equiv> t : T\<close>
\<close>

end


(*  Author:     Makarius

Example theory involving Unicode characters (UTF-8 encoding) -- both
formal and informal ones.
*)

section \<open>A Hebrew theory\<close>

theory Hebrew
imports Main
begin

text \<open>
  \<^bold>\<open>Warning:\<close> Bidirectional Unicode text may confuse display in browsers, editors, etc.!
\<close>

subsection \<open>The Hebrew Alef-Bet (א-ב).\<close>

datatype alef_bet =
    Alef    ("א")
  | Bet     ("ב")
  | Gimel   ("ג")
  | Dalet   ("ד")
  | He      ("ה")
  | Vav     ("ו")
  | Zayin   ("ז")
  | Het     ("ח")
  | Tet     ("ט")
  | Yod     ("י")
  | Kaf     ("כ")
  | Lamed   ("ל")
  | Mem     ("מ")
  | Nun     ("נ")
  | Samekh  ("ס")
  | Ayin    ("ע")
  | Pe      ("פ")
  | Tsadi   ("צ")
  | Qof     ("ק")
  | Resh    ("ר")
  | Shin    ("ש")
  | Tav     ("ת")

thm alef_bet.induct

subsection \<open>Interpreting Hebrew letters as numbers.\<close>

primrec mispar :: "alef_bet \<Rightarrow> nat"
where
  "mispar א = 1"
| "mispar ב = 2"
| "mispar ג = 3"
| "mispar ד = 4"
| "mispar ה = 5"
| "mispar ו = 6"
| "mispar ז = 7"
| "mispar ח = 8"
| "mispar ט = 9"
| "mispar י = 10"
| "mispar כ = 20"
| "mispar ל = 30"
| "mispar מ = 40"
| "mispar נ = 50"
| "mispar ס = 60"
| "mispar ע = 70"
| "mispar פ = 80"
| "mispar צ = 90"
| "mispar ק = 100"
| "mispar ר = 200"
| "mispar ש = 300"
| "mispar ת = 400"

thm mispar.simps

lemma "mispar ק + mispar ל + mispar ה = 135"
  by simp

end