           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               November 2004               |
            |                   June 2005  (modified)   |
            |                   July 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                  April 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Infra_order
imports Infra_common
begin

(*****************************************************
                    order
 *****************************************************)

lemma order_antisymE:
  "[| (a::'a::order) = b ; [| a <= b ; b <= a |] ==> P |] ==> P"
apply (simp)
done

(*****************************************************
            Upper Bound and Lower Bound
 *****************************************************)

(* isabelle 2013:
consts
  isUB  :: "'a::order => 'a::order set => bool"  ("_ isUB _" [55,55] 55)
  isLUB :: "'a::order => 'a::order set => bool"  ("_ isLUB _"[55,55] 55)
  isLB  :: "'a::order => 'a::order set => bool"  ("_ isLB _" [55,55] 55)
  isGLB :: "'a::order => 'a::order set => bool"  ("_ isGLB _"[55,55] 55)

def
  isUB_def  : "x isUB X  == ALL y. y:X --> y <= x"
  isLUB_def : "x isLUB X == (x isUB X) & (ALL y. y isUB X --> x <= y)"
  isLB_def  : "x isLB X  == ALL y. y:X --> x <= y"
  isGLB_def : "x isGLB X == (x isLB X) & (ALL y. y isLB X --> y <= x)"
*)

definition
    isUB  :: "'a::order => 'a::order set => bool"  ("_ isUB _" [55,55] 55)
  where
  "x isUB X  == (ALL y. y:X --> y <= x)"

definition
  isLUB :: "'a::order => 'a::order set => bool"  ("_ isLUB _"[55,55] 55)
  where
  "x isLUB X == (x isUB X) & (ALL y. y isUB X --> x <= y)"

definition
  isLB  :: "'a::order => 'a::order set => bool"  ("_ isLB _" [55,55] 55)
  where
  "x isLB X  == ALL y. y:X --> x <= y"

definition
  isGLB :: "'a::order => 'a::order set => bool"  ("_ isGLB _"[55,55] 55)
  where
  "x isGLB X == (x isLB X) & (ALL y. y isLB X --> y <= x)"

 (* isGLB_def : "x isGLB X == (x isLB X) & (ALL y. y isLB X --> y <= x)" *)

(* test
lemma "0 isUB {0}"
apply (simp add: isUB_def)
done
*)

(* Isabelle 2013

consts
  hasLUB :: "'a::order set => bool" ("_ hasLUB" [1000] 55)
  hasGLB :: "'a::order set => bool" ("_ hasGLB" [1000] 55)

defs
  hasLUB_def: "X hasLUB == (EX x. x isLUB X)"
  hasGLB_def: "X hasGLB == (EX x. x isGLB X)"

consts
  LUB    :: "'a::order set => 'a::order"
  GLB    :: "'a::order set => 'a::order"

defs
  LUB_def    : "LUB X == if (X hasLUB) then THE x. (x isLUB X) else the None"
  GLB_def    : "GLB X == if (X hasGLB) then THE x. (x isGLB X) else the None"
*)

definition
  hasLUB :: "'a::order set => bool" ("_ hasLUB" [1000] 55)
  where
  "X hasLUB == (EX x. x isLUB X)"

definition
  hasGLB :: "'a::order set => bool" ("_ hasGLB" [1000] 55)
  where
  "X hasGLB == (EX x. x isGLB X)"

definition
  LUB    :: "'a::order set => 'a::order"
  where
  "LUB X == if (X hasLUB) then THE x. (x isLUB X) else the None"

definition
  GLB    :: "'a::order set => 'a::order"
  where
  "GLB X == if (X hasGLB) then THE x. (x isGLB X) else the None"

(*** LUB is unique ***)

lemma LUB_unique : "[| x isLUB X ; y isLUB X |] ==> x = y"
apply (unfold isLUB_def)
apply (elim conjE)
apply (drule_tac x="y" in spec)
apply (drule_tac x="x" in spec)
by (simp)

(*** GLB is unique ***)

lemma GLB_unique : "[| x isGLB X ; y isGLB X |] ==> x = y"
apply (unfold isGLB_def)
apply (elim conjE)
apply (drule_tac x="y" in spec)
apply (drule_tac x="x" in spec)
by (simp)

(*-----------------------*
 |       the LUB         |
 *-----------------------*)

lemma isLUB_to_LUB : "X hasLUB ==> x isLUB X = (x = LUB X)"
apply (simp add: LUB_def)
apply (rule iffI)

apply (rule sym)
apply (rule the_equality)
apply (simp)
apply (simp add: LUB_unique)

apply (simp add: hasLUB_def)
apply (erule exE)
apply (rule theI[of "(%x. x isLUB X)"])
apply (simp)
apply (simp add: LUB_unique)
done

lemmas LUB_to_isLUB = isLUB_to_LUB[THEN sym]

lemma LUB_to_isLUB_sym :
    "X hasLUB ==> (LUB X = x) = x isLUB X"
by (auto simp add: isLUB_to_LUB)

lemmas LUB_iff = LUB_to_isLUB LUB_to_isLUB_sym

lemma LUB_is: "X hasLUB ==> (LUB X) isLUB X"
apply (insert LUB_to_isLUB[of X "LUB X"])
by (simp)

lemma isLUB_LUB : "x isLUB X ==> (LUB X = x)"
apply (subgoal_tac "X hasLUB")
apply (simp add: LUB_iff)
apply (simp add: hasLUB_def)
apply (rule_tac x="x" in exI, simp)
done

(*-----------------------*
 |       the GLB         |
 *-----------------------*)

lemma isGLB_to_GLB : "X hasGLB ==> x isGLB X = (x = GLB X)"
apply (simp add: GLB_def)
apply (rule iffI)

apply (rule sym)
apply (rule the_equality)
apply (simp)
apply (simp add: GLB_unique)

apply (simp add: hasGLB_def)
apply (erule exE)
apply (rule theI[of "(%x. x isGLB X)"])
apply (simp)
apply (simp add: GLB_unique)
done

lemmas GLB_to_isGLB = isGLB_to_GLB[THEN sym]

lemma GLB_to_isGLB_sym :
    "X hasGLB ==> (GLB X = x) = x isGLB X"
by (auto simp add: isGLB_to_GLB)

lemmas GLB_iff = GLB_to_isGLB GLB_to_isGLB_sym

lemma GLB_is: "X hasGLB ==> (GLB X) isGLB X"
apply (insert GLB_to_isGLB[of X "GLB X"])
by (simp)

lemma isGLB_GLB : "x isGLB X ==> (GLB X = x)"
apply (subgoal_tac "X hasGLB")
apply (simp add: GLB_iff)
apply (simp add: hasGLB_def)
apply (rule_tac x="x" in exI, simp)
done

(*-----------------------*
 |     LUB subset        |
 *-----------------------*)

lemma isLUB_subset : "[| x isLUB X ; y isLUB Y ; X <= Y |] ==> x <= y"
apply (simp add: isLUB_def)
apply (elim conjE)

apply (drule_tac x="y" in spec)
apply (rotate_tac -1)
apply (drule mp)

apply (simp add: isUB_def)
apply (intro allI impI)
apply (rotate_tac 2)
apply (drule_tac x="ya" in spec)
apply (force)
by (simp)

(*-----------------------*
 |     GLB subset        |
 *-----------------------*)

lemma isGLB_subset : "[| x isGLB X ; y isGLB Y ; X <= Y |] ==> y <= x"
apply (simp add: isGLB_def)
apply (elim conjE)

apply (drule_tac x="y" in spec)
apply (rotate_tac -1)
apply (drule mp)

apply (simp add: isLB_def)
apply (intro allI impI)
apply (rotate_tac 2)
apply (drule_tac x="ya" in spec)
apply (force)
by (simp)

(*--------------------------*
 |  GLB exists for nat set  |
 *--------------------------*)

lemma EX_GLB_nat_lm:
  "ALL m m'. m' <= m & m' : (X::nat set) --> (EX n. n isGLB X & n:X)"
apply (rule allI)
apply (induct_tac m)

(* base *)
apply (intro allI impI)
apply (rule_tac x="0" in exI)
apply (erule conjE)
apply (simp add: isGLB_def isLB_def)
apply (intro allI impI)
apply (drule_tac x="0" in spec)
apply (simp)

(* step *)
apply (intro allI impI)
apply (case_tac "EX m''. m'' <= n & m'':X")
apply (erule exE)
apply (drule_tac x="m''" in spec)
apply (simp)

apply (rule_tac x="m'" in exI)
apply (simp add: isGLB_def isLB_def)
apply (intro allI impI)

apply (case_tac "y < m'")
apply (drule_tac x="y" in spec)
by (auto)

(*** EX ***)

lemma EX_GLB_nat:
  "(X::nat set) ~= {} ==> (EX n. n isGLB X & n:X)"
apply (subgoal_tac "EX m. m:X")
apply (erule exE)
apply (insert EX_GLB_nat_lm[of X])
apply (drule_tac x="m" in spec)
apply (drule_tac x="m" in spec)
apply (simp)
by (auto)

(*--------------------------*
 |       LUB is least       |
 *--------------------------*)

lemma LUB_least: "[| ALL x:X. x <= Y ; X hasLUB |]==> LUB X <= Y"
apply (insert LUB_is[of X])
apply (simp add: isLUB_def)
apply (elim conjE)
apply (drule_tac x="Y" in spec)
apply (simp add: isUB_def)
done

(*--------------------------*
 |       GLB is great       |
 *--------------------------*)

lemma GLB_great: "[| ALL x:X. Y <= x ; X hasGLB |]==> Y <= GLB X"
apply (insert GLB_is[of X])
apply (simp add: isGLB_def)
apply (elim conjE)
apply (drule_tac x="Y" in spec)
apply (simp add: isLB_def)
done

(*--------------------------*
 |       Union isLUB        |
 *--------------------------*)

(* Union X is an upper bound of X *)

lemma Union_isUB : "(Union X) isUB X"
apply (simp add: isUB_def)
apply (simp add: subset_iff)
apply (intro allI impI)
apply (rule_tac x=y in bexI)
by (auto)

(* UnionT Ts is the least upper bound of Ts *)

lemma Union_isLUB : "Union X isLUB X"
apply (simp add: isLUB_def Union_isUB)
apply (simp add: isUB_def)
apply (simp add: subset_iff)
apply (intro allI impI)
apply (erule bexE)
apply (drule_tac x="Xa" in spec)
by (simp)

(* the least upper bound of X is Union X *)

lemma isLUB_Union_only_if: "x isLUB X ==> x = Union X"
apply (insert Union_isLUB[of X])
apply (rule LUB_unique)
by (simp_all)

(* iff *)

lemma isLUB_Union : "(x isLUB X) = (x = Union X)"
apply (rule iffI)
apply (simp add: isLUB_Union_only_if)
apply (simp add: Union_isLUB)
done

(* LUB is Union X *)

lemma LUB_Union : "LUB X = Union X"
by (simp add: isLUB_LUB Union_isLUB)

(*****************************************************
                   MIN and MAX
 *****************************************************)
(* Isabelle 2013
consts
  isMAX :: "'a::order => 'a::order set => bool"  ("_ isMAX _"[55,55] 55)
  isMIN :: "'a::order => 'a::order set => bool"  ("_ isMIN _"[55,55] 55)

defs
  isMAX_def : "x isMAX X == (x isUB X) & (x : X)"
  isMIN_def : "x isMIN X == (x isLB X) & (x : X)"
*)

definition
  isMAX :: "'a::order => 'a::order set => bool"  ("_ isMAX _"[55,55] 55)
  where
  "x isMAX X == (x isUB X) & (x : X)"

definition
  isMIN :: "'a::order => 'a::order set => bool"  ("_ isMIN _"[55,55] 55)
  where
  "x isMIN X == (x isLB X) & (x : X)"

(* Isabelle 2013
consts
  hasMAX :: "'a::order set => bool" ("_ hasMAX" [1000] 55)
  hasMIN :: "'a::order set => bool" ("_ hasMIN" [1000] 55)

defs
  hasMAX_def: "X hasMAX == (EX x. x isMAX X)"
  hasMIN_def: "X hasMIN == (EX x. x isMIN X)"
*)

definition
  hasMAX :: "'a::order set => bool" ("_ hasMAX" [1000] 55)
  where
  "X hasMAX == (EX x. x isMAX X)"

definition
  hasMIN :: "'a::order set => bool" ("_ hasMIN" [1000] 55)
  where
  "X hasMIN == (EX x. x isMIN X)"

(* Isabelle 2013
consts
  MAX    :: "'a::order set => 'a::order"
  MIN    :: "'a::order set => 'a::order"

defs
  MAX_def    : "MAX X == if (X hasMAX) then THE x. (x isMAX X) else the None"
  MIN_def    : "MIN X == if (X hasMIN) then THE x. (x isMIN X) else the None"
*)

definition
  MAX    :: "'a::order set => 'a::order"
  where
  "MAX X == if (X hasMAX) then THE x. (x isMAX X) else the None"

definition
  MIN    :: "'a::order set => 'a::order"
  where
  "MIN X == if (X hasMIN) then THE x. (x isMIN X) else the None"

(*** MAX is unique ***)

lemma MAX_unique : "[| x isMAX X ; y isMAX X |] ==> x = y"
apply (unfold isMAX_def isUB_def)
apply (elim conjE)
apply (drule_tac x="y" in spec)
apply (drule_tac x="x" in spec)
by (simp)

(*** MIN is unique ***)

lemma MIN_unique : "[| x isMIN X ; y isMIN X |] ==> x = y"
apply (unfold isMIN_def isLB_def)
apply (elim conjE)
apply (drule_tac x="y" in spec)
apply (drule_tac x="x" in spec)
by (simp)

(*-----------------------*
 |       the MAX         |
 *-----------------------*)

lemma isMAX_to_MAX : "X hasMAX ==> x isMAX X = (x = MAX X)"
apply (simp add: MAX_def)
apply (rule iffI)

apply (rule sym)
apply (rule the_equality)
apply (simp)
apply (simp add: MAX_unique)

apply (simp add: hasMAX_def)
apply (erule exE)
apply (rule theI[of "(%x. x isMAX X)"])
apply (simp)
apply (simp add: MAX_unique)
done

lemmas MAX_to_isMAX = isMAX_to_MAX[THEN sym]

lemma MAX_to_isMAX_sym :
    "X hasMAX ==> (MAX X = x) = x isMAX X"
by (auto simp add: isMAX_to_MAX)

lemmas MAX_iff = MAX_to_isMAX MAX_to_isMAX_sym

(*-----------------------*
 |       the MIN         |
 *-----------------------*)

lemma isMIN_to_MIN : "X hasMIN ==> x isMIN X = (x = MIN X)"
apply (simp add: MIN_def)
apply (rule iffI)

apply (rule sym)
apply (rule the_equality)
apply (simp)
apply (simp add: MIN_unique)

apply (simp add: hasMIN_def)
apply (erule exE)
apply (rule theI[of "(%x. x isMIN X)"])
apply (simp)
apply (simp add: MIN_unique)
done

lemmas MIN_to_isMIN = isMIN_to_MIN[THEN sym]

lemma MIN_to_isMIN_sym :
    "X hasMIN ==> (MIN X = x) = x isMIN X"
by (auto simp add: isMIN_to_MIN)

lemmas MIN_iff = MIN_to_isMIN MIN_to_isMIN_sym

(*-----------------------*
 |     MAX subset        |
 *-----------------------*)

lemma isMAX_subset : "[| x isMAX X ; y isMAX Y ; X <= Y |] ==> x <= y"
apply (simp add: isMAX_def isUB_def)
apply (elim conjE)

apply (rotate_tac 3)
apply (drule_tac x="x" in spec)
by (force)

(*-----------------------*
 |     MIN subset        |
 *-----------------------*)

lemma isMIN_subset : "[| x isMIN X ; y isMIN Y ; X <= Y |] ==> y <= x"
apply (simp add: isMIN_def isLB_def)
apply (elim conjE)

apply (rotate_tac 3)
apply (drule_tac x="x" in spec)
by (force)

(*--------------------------*
 |  MIN exists for nat set  |
 *--------------------------*)

lemma EX_MIN_nat_lm:
  "ALL m m'. m' <= m & m' : (X::nat set) --> (EX n. n isMIN X)"
apply (rule allI)
apply (induct_tac m)

(* base *)
apply (intro allI impI)
apply (rule_tac x="0" in exI)
apply (erule conjE)
apply (simp add: isMIN_def isLB_def)

(* step *)
apply (intro allI impI)
apply (case_tac "EX m''. m'' <= n & m'':X")
apply (erule exE)
apply (drule_tac x="m''" in spec)
apply (simp)

apply (rule_tac x="m'" in exI)
apply (simp add: isMIN_def isLB_def)
apply (intro allI impI)

apply (case_tac "y < m'")
apply (drule_tac x="y" in spec)
by (auto)

(*** EX ***)

lemma EX_MIN_nat:
  "(X::nat set) ~= {} ==> EX n. n isMIN X"
apply (subgoal_tac "EX m. m:X")
apply (erule exE)
apply (insert EX_MIN_nat_lm[of X])
apply (drule_tac x="m" in spec)
apply (drule_tac x="m" in spec)
apply (simp)
by (auto)

(*****************************************************
                   Fixed Point
 *****************************************************)

(* Isabelle 2013
consts
 isUFP :: "'a        => ('a       => 'a        ) => bool" (infixl "isUFP" 55)
 isLFP :: "'a::order => ('a::order => 'a::order) => bool" (infixl "isLFP" 55)
 isGFP :: "'a::order => ('a::order => 'a::order) => bool" (infixl "isGFP" 55)

defs
  isUFP_def : "x isUFP f == (x = f x & (ALL y. y = f y --> x  = y))"
  isLFP_def : "x isLFP f == (x = f x & (ALL y. y = f y --> x <= y))"
  isGFP_def : "x isGFP f == (x = f x & (ALL y. y = f y --> y <= x))"

consts
  hasUFP:: "('a        => 'a       ) => bool" ("_ hasUFP" [1000] 55)
  hasLFP:: "('a::order => 'a::order) => bool" ("_ hasLFP" [1000] 55)
  hasGFP:: "('a::order => 'a::order) => bool" ("_ hasGFP" [1000] 55)

defs
  hasUFP_def: "f hasUFP == (EX x. x isUFP f)"
  hasLFP_def: "f hasLFP == (EX x. x isLFP f)"
  hasGFP_def: "f hasGFP == (EX x. x isGFP f)"

consts
  UFP    :: "('a        => 'a       ) => 'a"
  LFP    :: "('a::order => 'a::order) => 'a::order"
  GFP    :: "('a::order => 'a::order) => 'a::order"

defs
  UFP_def : "UFP f == if (f hasUFP) then (THE x. x isUFP f) else the None"
  LFP_def : "LFP f == if (f hasLFP) then (THE x. x isLFP f) else the None"
  GFP_def : "GFP f == if (f hasGFP) then (THE x. x isGFP f) else the None"

*)

definition
  isUFP :: "'a        => ('a       => 'a        ) => bool" (infixl "isUFP" 55)
  where
  "x isUFP f == (x = f x & (ALL y. y = f y --> x  = y))"

definition
  isLFP :: "'a::order => ('a::order => 'a::order) => bool" (infixl "isLFP" 55)
  where
  "x isLFP f == (x = f x & (ALL y. y = f y --> x <= y))"

definition
  isGFP :: "'a::order => ('a::order => 'a::order) => bool" (infixl "isGFP" 55)
  where
  "x isGFP f == (x = f x & (ALL y. y = f y --> y <= x))"

definition
  hasUFP:: "('a        => 'a       ) => bool" ("_ hasUFP" [1000] 55)
  where
  "f hasUFP == (EX x. x isUFP f)"

definition
  hasLFP:: "('a::order => 'a::order) => bool" ("_ hasLFP" [1000] 55)
  where
  "f hasLFP == (EX x. x isLFP f)"

definition
  hasGFP:: "('a::order => 'a::order) => bool" ("_ hasGFP" [1000] 55)
  where
  "f hasGFP == (EX x. x isGFP f)"

definition
  UFP    :: "('a        => 'a       ) => 'a"
  where
  "UFP f == if (f hasUFP) then (THE x. x isUFP f) else the None"

definition
  LFP    :: "('a::order => 'a::order) => 'a::order"
  where
  "LFP f == if (f hasLFP) then (THE x. x isLFP f) else the None"

definition
  GFP    :: "('a::order => 'a::order) => 'a::order"
  where
  "GFP f == if (f hasGFP) then (THE x. x isGFP f) else the None"

(*******************************
            lemmas
 *******************************)

(*** UFP is unique ***)

lemma UFP_unique : "[| x isUFP f ; y isUFP f |] ==> x = y"
by (simp add: isUFP_def)

(*** LFP is unique ***)

lemma LFP_unique : "[| x isLFP f ; y isLFP f |] ==> x = y"
apply (unfold isLFP_def)
apply (erule conjE)+
apply (drule_tac x="y" in spec)
apply (drule_tac x="x" in spec)
by (simp)

(*** GFP is unique ***)

lemma GFP_unique : "[| x isGFP f ; y isGFP f |] ==> x = y"
apply (unfold isGFP_def)
apply (erule conjE)+
apply (drule_tac x="y" in spec)
apply (drule_tac x="x" in spec)
by (simp)

(*-----------------------*
 |       the UFP         |
 *-----------------------*)

lemma isUFP_to_UFP : "f hasUFP ==> x isUFP f = (x = UFP f)"
apply (simp add: UFP_def)
apply (rule iffI)

apply (rule sym)
apply (rule the_equality)
apply (simp)
apply (simp add: UFP_unique)

apply (simp add: hasUFP_def)
apply (erule exE)
apply (rule theI[of "(%x. x isUFP f)"])
apply (simp)
apply (simp add: UFP_unique)
done

lemmas UFP_to_isUFP = isUFP_to_UFP[THEN sym]

lemma UFP_to_isUFP_sym :
    "f hasUFP ==> (UFP f = x) = x isUFP f"
by (auto simp add: isUFP_to_UFP)

lemmas UFP_iff = UFP_to_isUFP UFP_to_isUFP_sym

(*** UFP is ***)

lemma UFP_is : "f hasUFP ==> (UFP f) isUFP f"
by (simp add: isUFP_to_UFP)

lemma isUFP_UFP : "x isUFP f ==> (UFP f = x)"
apply (subgoal_tac "f hasUFP")
apply (simp add: UFP_iff)
apply (simp add: hasUFP_def)
apply (rule_tac x="x" in exI, simp)
done

(*** UFP is fixed point ***)

lemma UFP_fp_lm : "[| f hasUFP ; x = UFP f |] ==> f x = x"
apply (simp add: UFP_iff)
apply (simp add: isUFP_def)
done

lemma UFP_fp : "f hasUFP ==> f (UFP f) = UFP f"
by (simp add: UFP_fp_lm)

(*** unique solution ***)

lemma hasUFP_unique_solution :
  "[| f hasUFP ; f x = x ; f y = y |] ==> x = y"
apply (simp add: hasUFP_def)
apply (erule exE)
apply (simp add: isUFP_def)
apply (erule conjE)
apply (frule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (simp)
done

(*-----------------------*
 |       the LFP         |
 *-----------------------*)

lemma isLFP_to_LFP : "f hasLFP ==> x isLFP f = (x = LFP f)"
apply (simp add: LFP_def)
apply (rule iffI)

apply (rule sym)
apply (rule the_equality)
apply (simp)
apply (simp add: LFP_unique)

apply (simp add: hasLFP_def)
apply (erule exE)
apply (rule theI[of "(%x. x isLFP f)"])
apply (simp)
apply (simp add: LFP_unique)
done

lemmas LFP_to_isLFP = isLFP_to_LFP[THEN sym]

lemma LFP_to_isLFP_sym :
    "f hasLFP ==> (LFP f = x) = x isLFP f"
by (auto simp add: isLFP_to_LFP)

lemmas LFP_iff = LFP_to_isLFP LFP_to_isLFP_sym

(*** LFP is ***)

lemma LFP_is : "f hasLFP ==> (LFP f) isLFP f"
by (simp add: isLFP_to_LFP)

lemma isLFP_LFP : "x isLFP f ==> (LFP f = x)"
apply (subgoal_tac "f hasLFP")
apply (simp add: LFP_iff)
apply (simp add: hasLFP_def)
apply (rule_tac x="x" in exI, simp)
done

(*** LFP is fixed point ***)

lemma LFP_fp_lm : "[| f hasLFP ; x = LFP f |] ==> f x = x"
apply (simp add: LFP_iff)
apply (simp add: isLFP_def)
done

lemma LFP_fp : "f hasLFP ==> f (LFP f) = LFP f"
by (simp add: LFP_fp_lm)

(*** LFP is least ***)

lemma LFP_least : "[| f hasLFP ; f x = x |] ==> LFP f <= x"
apply (insert LFP_is[of f])
apply (simp add: isLFP_def)
done

(*-----------------------*
 |       the GFP         |
 *-----------------------*)

lemma isGFP_to_GFP : "f hasGFP ==> x isGFP f = (x = GFP f)"
apply (simp add: GFP_def)
apply (rule iffI)

apply (rule sym)
apply (rule the_equality)
apply (simp)
apply (simp add: GFP_unique)

apply (simp add: hasGFP_def)
apply (erule exE)
apply (rule theI[of "(%x. x isGFP f)"])
apply (simp)
apply (simp add: GFP_unique)
done

lemmas GFP_to_isGFP = isGFP_to_GFP[THEN sym]

lemma GFP_to_isGFP_sym :
    "f hasGFP ==> (GFP f = x) = x isGFP f"
by (auto simp add: isGFP_to_GFP)

lemmas GFP_iff = GFP_to_isGFP GFP_to_isGFP_sym

(*** GFP is ***)

lemma GFP_is : "f hasGFP ==> (GFP f) isGFP f"
by (simp add: isGFP_to_GFP)

lemma isGFP_GFP : "x isGFP f ==> (GFP f = x)"
apply (subgoal_tac "f hasGFP")
apply (simp add: GFP_iff)
apply (simp add: hasGFP_def)
apply (rule_tac x="x" in exI, simp)
done

(*** GFP is fixed point ***)

lemma GFP_fp_lm : "[| f hasGFP ; x = GFP f |] ==> f x = x"
apply (simp add: GFP_iff)
apply (simp add: isGFP_def)
done

lemma GFP_fp : "f hasGFP ==> f (GFP f) = GFP f"
by (simp add: GFP_fp_lm)

(*** GFP is greatest ***)

lemma GFP_greatest : "[| f hasGFP ; f x = x |] ==> x <= GFP f"
apply (insert GFP_is[of f])
apply (simp add: isGFP_def)
done

(*-----------------------*
 |     UFP --> LFP       |
 *-----------------------*)

lemma hasUFP_hasLFP: "f hasUFP ==> f hasLFP"
apply (simp add: hasUFP_def hasLFP_def)
apply (simp add: isUFP_def isLFP_def)
by (auto)

lemma hasUFP_LFP_UFP: "f hasUFP ==> LFP f = UFP f"
apply (simp add: isUFP_to_UFP[THEN sym])
apply (insert LFP_is[of f])
apply (simp add: hasUFP_hasLFP)
apply (simp add: hasUFP_def)
apply (simp add: isUFP_def isLFP_def)
apply (intro allI impI)
apply (elim conjE exE)
apply (rotate_tac -1)
apply (frule_tac x="y" in spec)
apply (drule_tac x="LFP f" in spec)
by (simp)

(*-----------------------*
 |     UFP --> GFP       |
 *-----------------------*)

lemma hasUFP_hasGFP: "f hasUFP ==> f hasGFP"
apply (simp add: hasUFP_def hasGFP_def)
apply (simp add: isUFP_def isGFP_def)
by (auto)

lemma hasUFP_GFP_UFP: "f hasUFP ==> GFP f = UFP f"
apply (simp add: isUFP_to_UFP[THEN sym])
apply (insert GFP_is[of f])
apply (simp add: hasUFP_hasGFP)
apply (simp add: hasUFP_def)
apply (simp add: isUFP_def isGFP_def)
apply (intro allI impI)
apply (elim conjE exE)
apply (rotate_tac -1)
apply (frule_tac x="y" in spec)
apply (drule_tac x="GFP f" in spec)
by (simp)

end


(*  Title:      ZF/Fixedpt.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section\<open>Least and Greatest Fixed Points; the Knaster-Tarski Theorem\<close>

theory Fixedpt imports equalities begin

definition
  (*monotone operator from Pow(D) to itself*)
  bnd_mono :: "[i,i=>i]=>o"  where
     "bnd_mono(D,h) == h(D)<=D & (\<forall>W X. W<=X \<longrightarrow> X<=D \<longrightarrow> h(W) \<subseteq> h(X))"

definition
  lfp      :: "[i,i=>i]=>i"  where
     "lfp(D,h) == \<Inter>({X: Pow(D). h(X) \<subseteq> X})"

definition
  gfp      :: "[i,i=>i]=>i"  where
     "gfp(D,h) == \<Union>({X: Pow(D). X \<subseteq> h(X)})"

text\<open>The theorem is proved in the lattice of subsets of \<^term>\<open>D\<close>,
      namely \<^term>\<open>Pow(D)\<close>, with Inter as the greatest lower bound.\<close>

subsection\<open>Monotone Operators\<close>

lemma bnd_monoI:
    "[| h(D)<=D;
        !!W X. [| W<=D;  X<=D;  W<=X |] ==> h(W) \<subseteq> h(X)
     |] ==> bnd_mono(D,h)"
by (unfold bnd_mono_def, clarify, blast)

lemma bnd_monoD1: "bnd_mono(D,h) ==> h(D) \<subseteq> D"
apply (unfold bnd_mono_def)
apply (erule conjunct1)
done

lemma bnd_monoD2: "[| bnd_mono(D,h);  W<=X;  X<=D |] ==> h(W) \<subseteq> h(X)"
by (unfold bnd_mono_def, blast)

lemma bnd_mono_subset:
    "[| bnd_mono(D,h);  X<=D |] ==> h(X) \<subseteq> D"
by (unfold bnd_mono_def, clarify, blast)

lemma bnd_mono_Un:
     "[| bnd_mono(D,h);  A \<subseteq> D;  B \<subseteq> D |] ==> h(A) \<union> h(B) \<subseteq> h(A \<union> B)"
apply (unfold bnd_mono_def)
apply (rule Un_least, blast+)
done

(*unused*)
lemma bnd_mono_UN:
     "[| bnd_mono(D,h);  \<forall>i\<in>I. A(i) \<subseteq> D |]
      ==> (\<Union>i\<in>I. h(A(i))) \<subseteq> h((\<Union>i\<in>I. A(i)))"
apply (unfold bnd_mono_def)
apply (rule UN_least)
apply (elim conjE)
apply (drule_tac x="A(i)" in spec)
apply (drule_tac x="(\<Union>i\<in>I. A(i))" in spec)
apply blast
done

(*Useful??*)
lemma bnd_mono_Int:
     "[| bnd_mono(D,h);  A \<subseteq> D;  B \<subseteq> D |] ==> h(A \<inter> B) \<subseteq> h(A) \<inter> h(B)"
apply (rule Int_greatest)
apply (erule bnd_monoD2, rule Int_lower1, assumption)
apply (erule bnd_monoD2, rule Int_lower2, assumption)
done

subsection\<open>Proof of Knaster-Tarski Theorem using \<^term>\<open>lfp\<close>\<close>

(*lfp is contained in each pre-fixedpoint*)
lemma lfp_lowerbound:
    "[| h(A) \<subseteq> A;  A<=D |] ==> lfp(D,h) \<subseteq> A"
by (unfold lfp_def, blast)

(*Unfolding the defn of Inter dispenses with the premise bnd_mono(D,h)!*)
lemma lfp_subset: "lfp(D,h) \<subseteq> D"
by (unfold lfp_def Inter_def, blast)

(*Used in datatype package*)
lemma def_lfp_subset:  "A == lfp(D,h) ==> A \<subseteq> D"
apply simp
apply (rule lfp_subset)
done

lemma lfp_greatest:
    "[| h(D) \<subseteq> D;  !!X. [| h(X) \<subseteq> X;  X<=D |] ==> A<=X |] ==> A \<subseteq> lfp(D,h)"
by (unfold lfp_def, blast)

lemma lfp_lemma1:
    "[| bnd_mono(D,h);  h(A)<=A;  A<=D |] ==> h(lfp(D,h)) \<subseteq> A"
apply (erule bnd_monoD2 [THEN subset_trans])
apply (rule lfp_lowerbound, assumption+)
done

lemma lfp_lemma2: "bnd_mono(D,h) ==> h(lfp(D,h)) \<subseteq> lfp(D,h)"
apply (rule bnd_monoD1 [THEN lfp_greatest])
apply (rule_tac [2] lfp_lemma1)
apply (assumption+)
done

lemma lfp_lemma3:
    "bnd_mono(D,h) ==> lfp(D,h) \<subseteq> h(lfp(D,h))"
apply (rule lfp_lowerbound)
apply (rule bnd_monoD2, assumption)
apply (rule lfp_lemma2, assumption)
apply (erule_tac [2] bnd_mono_subset)
apply (rule lfp_subset)+
done

(*Definition form, to control unfolding*)
lemma def_lfp_unfold:
    "[| A==lfp(D,h);  bnd_mono(D,h) |] ==> A = h(A)"
apply simp
apply (erule lfp_unfold)
done

subsection\<open>General Induction Rule for Least Fixedpoints\<close>

lemma Collect_is_pre_fixedpt:
    "[| bnd_mono(D,h);  !!x. x \<in> h(Collect(lfp(D,h),P)) ==> P(x) |]
     ==> h(Collect(lfp(D,h),P)) \<subseteq> Collect(lfp(D,h),P)"
by (blast intro: lfp_lemma2 [THEN subsetD] bnd_monoD2 [THEN subsetD]
                 lfp_subset [THEN subsetD])

(*This rule yields an induction hypothesis in which the components of a
  data structure may be assumed to be elements of lfp(D,h)*)
lemma induct:
    "[| bnd_mono(D,h);  a \<in> lfp(D,h);
        !!x. x \<in> h(Collect(lfp(D,h),P)) ==> P(x)
     |] ==> P(a)"
apply (rule Collect_is_pre_fixedpt
              [THEN lfp_lowerbound, THEN subsetD, THEN CollectD2])
apply (rule_tac [3] lfp_subset [THEN Collect_subset [THEN subset_trans]],
       blast+)
done

(*Definition form, to control unfolding*)
lemma def_induct:
    "[| A == lfp(D,h);  bnd_mono(D,h);  a:A;
        !!x. x \<in> h(Collect(A,P)) ==> P(x)
     |] ==> P(a)"
by (rule induct, blast+)

(*This version is useful when "A" is not a subset of D
  second premise could simply be h(D \<inter> A) \<subseteq> D or !!X. X<=D ==> h(X)<=D *)
lemma lfp_Int_lowerbound:
    "[| h(D \<inter> A) \<subseteq> A;  bnd_mono(D,h) |] ==> lfp(D,h) \<subseteq> A"
apply (rule lfp_lowerbound [THEN subset_trans])
apply (erule bnd_mono_subset [THEN Int_greatest], blast+)
done

(*Monotonicity of lfp, where h precedes i under a domain-like partial order
  monotonicity of h is not strictly necessary; h must be bounded by D*)
lemma lfp_mono:
  assumes hmono: "bnd_mono(D,h)"
      and imono: "bnd_mono(E,i)"
      and subhi: "!!X. X<=D ==> h(X) \<subseteq> i(X)"
    shows "lfp(D,h) \<subseteq> lfp(E,i)"
apply (rule bnd_monoD1 [THEN lfp_greatest])
apply (rule imono)
apply (rule hmono [THEN [2] lfp_Int_lowerbound])
apply (rule Int_lower1 [THEN subhi, THEN subset_trans])
apply (rule imono [THEN bnd_monoD2, THEN subset_trans], auto)
done

(*This (unused) version illustrates that monotonicity is not really needed,
  but both lfp's must be over the SAME set D;  Inter is anti-monotonic!*)
lemma lfp_mono2:
    "[| i(D) \<subseteq> D;  !!X. X<=D ==> h(X) \<subseteq> i(X)  |] ==> lfp(D,h) \<subseteq> lfp(D,i)"
apply (rule lfp_greatest, assumption)
apply (rule lfp_lowerbound, blast, assumption)
done

lemma lfp_cong:
     "[|D=D'; !!X. X \<subseteq> D' ==> h(X) = h'(X)|] ==> lfp(D,h) = lfp(D',h')"
apply (simp add: lfp_def)
apply (rule_tac t=Inter in subst_context)
apply (rule Collect_cong, simp_all)
done

subsection\<open>Proof of Knaster-Tarski Theorem using \<^term>\<open>gfp\<close>\<close>

(*gfp contains each post-fixedpoint that is contained in D*)
lemma gfp_upperbound: "[| A \<subseteq> h(A);  A<=D |] ==> A \<subseteq> gfp(D,h)"
apply (unfold gfp_def)
apply (rule PowI [THEN CollectI, THEN Union_upper])
apply (assumption+)
done

lemma gfp_subset: "gfp(D,h) \<subseteq> D"
by (unfold gfp_def, blast)

(*Used in datatype package*)
lemma def_gfp_subset: "A==gfp(D,h) ==> A \<subseteq> D"
apply simp
apply (rule gfp_subset)
done

lemma gfp_least:
    "[| bnd_mono(D,h);  !!X. [| X \<subseteq> h(X);  X<=D |] ==> X<=A |] ==>
     gfp(D,h) \<subseteq> A"
apply (unfold gfp_def)
apply (blast dest: bnd_monoD1)
done

lemma gfp_lemma1:
    "[| bnd_mono(D,h);  A<=h(A);  A<=D |] ==> A \<subseteq> h(gfp(D,h))"
apply (rule subset_trans, assumption)
apply (erule bnd_monoD2)
apply (rule_tac [2] gfp_subset)
apply (simp add: gfp_upperbound)
done

lemma gfp_lemma2: "bnd_mono(D,h) ==> gfp(D,h) \<subseteq> h(gfp(D,h))"
apply (rule gfp_least)
apply (rule_tac [2] gfp_lemma1)
apply (assumption+)
done

lemma gfp_lemma3:
    "bnd_mono(D,h) ==> h(gfp(D,h)) \<subseteq> gfp(D,h)"
apply (rule gfp_upperbound)
apply (rule bnd_monoD2, assumption)
apply (rule gfp_lemma2, assumption)
apply (erule bnd_mono_subset, rule gfp_subset)+
done

lemma gfp_unfold: "bnd_mono(D,h) ==> gfp(D,h) = h(gfp(D,h))"
apply (rule equalityI)
apply (erule gfp_lemma2)
apply (erule gfp_lemma3)
done

(*Definition form, to control unfolding*)
lemma def_gfp_unfold:
    "[| A==gfp(D,h);  bnd_mono(D,h) |] ==> A = h(A)"
apply simp
apply (erule gfp_unfold)
done

subsection\<open>Coinduction Rules for Greatest Fixed Points\<close>

(*weak version*)
lemma weak_coinduct: "[| a: X;  X \<subseteq> h(X);  X \<subseteq> D |] ==> a \<in> gfp(D,h)"
by (blast intro: gfp_upperbound [THEN subsetD])

lemma coinduct_lemma:
    "[| X \<subseteq> h(X \<union> gfp(D,h));  X \<subseteq> D;  bnd_mono(D,h) |] ==>
     X \<union> gfp(D,h) \<subseteq> h(X \<union> gfp(D,h))"
apply (erule Un_least)
apply (rule gfp_lemma2 [THEN subset_trans], assumption)
apply (rule Un_upper2 [THEN subset_trans])
apply (rule bnd_mono_Un, assumption+)
apply (rule gfp_subset)
done

(*strong version*)
lemma coinduct:
     "[| bnd_mono(D,h);  a: X;  X \<subseteq> h(X \<union> gfp(D,h));  X \<subseteq> D |]
      ==> a \<in> gfp(D,h)"
apply (rule weak_coinduct)
apply (erule_tac [2] coinduct_lemma)
apply (simp_all add: gfp_subset Un_subset_iff)
done

(*Definition form, to control unfolding*)
lemma def_coinduct:
    "[| A == gfp(D,h);  bnd_mono(D,h);  a: X;  X \<subseteq> h(X \<union> A);  X \<subseteq> D |] ==>
     a \<in> A"
apply simp
apply (rule coinduct, assumption+)
done

(*The version used in the induction/coinduction package*)
lemma def_Collect_coinduct:
    "[| A == gfp(D, %w. Collect(D,P(w)));  bnd_mono(D, %w. Collect(D,P(w)));
        a: X;  X \<subseteq> D;  !!z. z: X ==> P(X \<union> A, z) |] ==>
     a \<in> A"
apply (rule def_coinduct, assumption+, blast+)
done

(*Monotonicity of gfp!*)
lemma gfp_mono:
    "[| bnd_mono(D,h);  D \<subseteq> E;
        !!X. X<=D ==> h(X) \<subseteq> i(X)  |] ==> gfp(D,h) \<subseteq> gfp(E,i)"
apply (rule gfp_upperbound)
apply (rule gfp_lemma2 [THEN subset_trans], assumption)
apply (blast del: subsetI intro: gfp_subset)
apply (blast del: subsetI intro: subset_trans gfp_subset)
done

end


theory Binary_Decision_Diagrams
  imports
    Main
    "Boolean_Expression_Checkers.Boolean_Expression_Checkers"
    "Boolean_Expression_Checkers.Boolean_Expression_Checkers_AList_Mapping"
begin

text\<open>Beware that following @{term val_ifex} definition the left branch
corresponds to @{term True} and the left branch to @{term False}\<close>

fun depth :: "'a ifex \<Rightarrow> nat"
  where
    "depth Trueif = 0" | "depth Falseif = 0" |
    "depth (IF b t f) = 1 + min (depth t) (depth f)"

fun Alexander_dual :: "'a ifex \<Rightarrow> 'a ifex"
  where "Alexander_dual Trueif = Falseif" |
    "Alexander_dual Falseif = Trueif" |
    "Alexander_dual (IF b t f) = (IF b (Alexander_dual f) (Alexander_dual t))"

lift_definition neg_env :: "'a env_bool \<Rightarrow> 'a env_bool"
  is "\<lambda>m k. case m k of None \<Rightarrow> None | Some v \<Rightarrow> Some (\<not> v)" .

lemma "val_ifex (Alexander_dual t) env = (\<not> val_ifex (t) (\<lambda>x. \<not> env x))"
  by (induct t) auto

lemma "depth (Alexander_dual t) = depth t"
  by (induct t) auto

lemma "Alexander_dual (Alexander_dual t) = t"
  by (induct t) auto

value "Alexander_dual (IF (1::int) Trueif Falseif)"

value "Alexander_dual (IF (1::int) (IF 2 (Trueif) (Falseif))
                         (IF 3 (Trueif) (Falseif)))"

value "Alexander_dual (IF (1::int) (IF 2 ((IF 3 (Falseif) (Trueif))) (Falseif))
                         (IF 3 (Trueif) (Falseif)))"

text\<open>Beware that the depth of a reduced BDT is not always smaller than the
  one of the original BDT (it may depend on the chosen environment).\<close>

value "depth (IF finite_4.a\<^sub>1 (IF finite_4.a\<^sub>2 (IF finite_4.a\<^sub>3 Trueif Falseif) (IF finite_4.a\<^sub>4 Falseif Trueif)) Trueif)"

value "depth (IF finite_4.a\<^sub>1
                (IF finite_4.a\<^sub>1
                  (IF finite_4.a\<^sub>2 (IF finite_4.a\<^sub>3 Trueif Falseif)
                                  (IF finite_4.a\<^sub>4 Falseif Trueif))
                  Trueif)
                Trueif)"

value "depth (reduce_alist  [(finite_4.a\<^sub>1, True)]
    (IF finite_4.a\<^sub>1 (IF finite_4.a\<^sub>2 (IF finite_4.a\<^sub>3 Trueif Falseif) (IF finite_4.a\<^sub>4 Falseif Trueif))
                      Trueif))"

value "depth (reduce_alist [(finite_4.a\<^sub>1, True)] (IF finite_4.a\<^sub>1
                (IF finite_4.a\<^sub>1
                  (IF finite_4.a\<^sub>2 (IF finite_4.a\<^sub>3 Trueif Falseif)
                                  (IF finite_4.a\<^sub>4 Falseif Trueif))
                  Trueif)
                Trueif))"

value "depth (reduce_alist  [] (IF finite_4.a\<^sub>1
                (IF finite_4.a\<^sub>1
                  (IF finite_4.a\<^sub>2 (IF finite_4.a\<^sub>3 Trueif Falseif)
                                  (IF finite_4.a\<^sub>4 Falseif Trueif))
                  Trueif)
                Trueif))"

value "depth (reduce_alist  [(finite_4.a\<^sub>1, False)]
    (IF finite_4.a\<^sub>1 (IF finite_4.a\<^sub>2 (IF finite_4.a\<^sub>3 Trueif Falseif) (IF finite_4.a\<^sub>4 Falseif Trueif))
                      Trueif))"

lemma depth_mkIF: "depth (mkIF x t1 t2) \<le> Suc (min (depth t1) (depth t2))"
  unfolding mkIF_def by auto

fun vars :: "'a ifex \<Rightarrow> 'a set"
  where "vars (IF x t f) = insert x (vars t \<union> vars f)" |
        "vars _ = {}"

lemma vars_IFT_subset: "vars t \<subseteq> vars (IF x t f)" by auto
lemma vars_IFF_subset: "vars f \<subseteq> vars (IF x t f)" by auto

lemma vars_mkIF: "vars (mkIF x t f) \<subseteq> vars (IF x t f)"
  by (metis dual_order.eq_iff mkIF_def vars_IFT_subset)

lemma
  shows "vars (reduce env b) \<subseteq> vars b"
proof (induction b arbitrary: env)
  case Trueif
  then show ?case by simp
next
  case Falseif
  then show ?case by simp
next
  case (IF x1 b1 b2)
  show ?case
  proof (cases "Mapping.lookup env x1 = None")
    case True
    have vt: "vars (reduce (Mapping.update x1 True env) b1) \<subseteq> vars b1"
        and vf: "vars (reduce (Mapping.update x1 False env) b2) \<subseteq> vars b2"
      using IF.IH by simp_all
    with vars_mkIF show ?thesis unfolding reduce.simps using True by fastforce
  next
    case False
    have vt: "vars (reduce env b1) \<subseteq> vars b1"
        and vf: "vars (reduce env b2) \<subseteq> vars b2" using IF.IH by simp_all
    thus ?thesis unfolding reduce.simps using False
      by auto (metis (mono_tags, lifting) subset_eq)
  qed
qed

fun ifex_no_twice where
  "ifex_no_twice (IF v t e) = (
  v \<notin> (vars t \<union> vars e) \<and> ifex_no_twice t \<and> ifex_no_twice e)" |
 "ifex_no_twice _ = True"

lemma
  env_not_in_vars:
  assumes m: "Mapping.lookup env x = Some b"
  shows "x \<notin> vars (reduce env bdd)"
  using m proof (induction bdd arbitrary: env b)
  case Trueif
  then show ?case by simp
next
  case Falseif
  then show ?case by simp
next
  case (IF x1 bdd1 bdd2 _ b)
  show ?case
  proof (cases "x = x1")
    case True
    have rw: "reduce env (IF x1 bdd1 bdd2) = reduce env (if b then bdd1 else bdd2)"
      using IF.prems True unfolding reduce.simps by auto
    show ?thesis unfolding rw using IF.IH [OF IF.prems] by (cases b, auto)
  next
    case False
    have "x \<notin> vars (reduce (Mapping.update x1 True env) bdd1)"
      and "x \<notin> vars (reduce (Mapping.update x1 False env) bdd2)"
      using False IF.IH(1,2) IF.prems by auto
    moreover have "x \<notin> vars (reduce env bdd1)"
      and "x \<notin> vars (reduce env bdd2)"
      using False IF.IH(1,2) IF.prems by auto
    ultimately show ?thesis unfolding reduce.simps
      apply (cases "Mapping.lookup env x1 = None")
      using False unfolding mkIF_def by (simp_all) force
  qed
qed

lemma "x \<notin> vars (reduce (Mapping.update x b env) bdd)"
  using env_not_in_vars by force

lemma "ifex_no_twice (reduce env b)"
proof (induction b arbitrary: env)
  case Trueif
  then show ?case by simp
next
  case Falseif
  then show ?case by simp
next
  case (IF x1 b1 b2)
  show ?case
  proof (cases "Mapping.lookup env x1 = None")
    case True
    have vt: "ifex_no_twice (reduce (Mapping.update x1 True env) b1)"
        and vf: "ifex_no_twice (reduce (Mapping.update x1 False env) b2)"
      using IF.IH by simp_all
    show ?thesis unfolding reduce.simps using True
      by auto (simp add: env_not_in_vars mkIF_def vf vt)
  next
    case False
    have vt: "ifex_no_twice (reduce env b1)"
        and vf: "ifex_no_twice (reduce env b2)"
      using IF.IH by simp_all
    show ?thesis unfolding reduce.simps using False
      using vf vt by force
  qed
qed

lemma
  depth_reduce_le:
  assumes ib: "ifex_no_twice b"
    and k: "vars b \<inter> Mapping.keys env = {}"
  shows "depth (reduce env b) \<le> depth b"
using ib k proof (induction b arbitrary: env)
  case Trueif show ?case by simp
next
  case Falseif show ?case by simp
next
  case (IF x t f)
  from IF.prems
  have int: "ifex_no_twice t" and inf: "ifex_no_twice f"
    and xt: "x \<notin> vars t" and xf: "x \<notin> vars f"
    and vt: "vars t \<inter> Mapping.keys (Mapping.update x True env) = {}"
    and vf: "vars f \<inter> Mapping.keys (Mapping.update x False env) = {}"
    by auto
  have drdt: "depth (reduce (Mapping.update x True env) t) \<le> depth t"
    and drdf: "depth (reduce (Mapping.update x False env) f) \<le> depth f"
     by (rule IF.IH, intro int, intro vt)
          (rule IF.IH, intro inf, intro vf)
  have mlxnone: "Mapping.lookup env x = None"
     using IF.prems (2)
     by (metis disjoint_iff_not_equal domIff insertCI keys_dom_lookup vars.simps(1))
  have "depth (reduce env (IF x t f)) =
          depth (mkIF x (reduce (Mapping.update x True env) t)
      (reduce (Mapping.update x False env) f))"
        (is "_ = depth (mkIF x ?xt ?xf)")
      using mlxnone reduce.simps (1) [of env x t f] by simp
  also have "... \<le> Suc (min (depth ?xt) (depth ?xf))"
      using depth_mkIF by metis
  also have "... \<le> Suc (min (depth t) (depth f))"
      using drdt drdf by auto
  also have "... = depth (IF x t f)" by simp
  finally show ?case .
qed

fun path :: "'a env_bool \<Rightarrow> 'a ifex \<Rightarrow> 'a list option"
  where "path _ Trueif = Some []" |
  "path _ Falseif = Some []" |
  "path eval (IF x t f) = (case Mapping.lookup eval x of
      None \<Rightarrow> None |
      Some True \<Rightarrow> (case (path eval t) of
                        None \<Rightarrow> None |
                        Some l \<Rightarrow> Some (x # l)) |
      Some False \<Rightarrow> (case (path eval f) of
                        None \<Rightarrow> None |
                        Some l \<Rightarrow> Some (x # l)))"

value "path Mapping.empty (IF x Trueif Falseif)"

lemma "path (Mapping.update x False env) (IF x (IF y Trueif Falseif) Falseif)
  = Some [x]"
  by simp

lemma "path (Mapping.of_alist [(x, True), (y, True)])
                  (IF x (IF y Trueif Falseif) Falseif)
  = Some [x, y]"
  by auto (simp add: lookup_of_alist)

definition olength :: "'a list option \<Rightarrow> nat option"
  where "olength l = (case l of None \<Rightarrow> None | Some m \<Rightarrow> Some (length m))"

value "olength (path (Mapping.of_alist [(finite_4.a\<^sub>1, True)])
            (IF finite_4.a\<^sub>1 Falseif Falseif))"

value "olength (path (Mapping.of_alist [(finite_4.a\<^sub>3, False)])
            (IF finite_4.a\<^sub>3 (IF finite_4.a\<^sub>1 Falseif Falseif) (Falseif)))"

lemma
  path_exists:
  assumes v: "vars bdd \<subseteq> Mapping.keys eval"
  shows "path eval bdd \<noteq> None"
  using v proof (induction bdd)
  case Trueif
  then show ?case by simp
next
  case Falseif
  then show ?case by simp
next
  case (IF x1 b11 b12)
  from IF.prems
  have vb11: "vars b11 \<subseteq> Mapping.keys eval" and vb12: "vars b12 \<subseteq> Mapping.keys eval"
    and x1: "x1 \<in> Mapping.keys eval"
    by simp_all
  obtain l11 l12 x11
    where "path eval b11 = Some l11" and "path eval b12 = Some l12"
      and "Mapping.lookup eval x1 = Some x11"
    using IF.IH (1) [OF vb11] IF.IH (2) [OF vb12] x1
    by auto (meson in_keysD)
  then show ?case unfolding path.simps
    by (simp add: case_bool_if)
qed

lemma
  path_reduce_exists:
  assumes v: "vars bdd \<subseteq> Mapping.keys eval"
  shows "path eval (reduce env bdd) \<noteq> None"
  using v path_exists [OF v] proof (induction bdd arbitrary: env)
  case Trueif
  then show ?case by simp
next
  case Falseif
  then show ?case by simp
next
  case (IF x1 b1 b2)
  show ?case
  proof (cases "Mapping.lookup env x1 = None")
    case False
    then obtain x11 where mx1: "Mapping.lookup env x1 = Some (x11)" by auto
    from IF.prems (1)
    have vb1: "vars b1 \<subseteq> Mapping.keys eval" and vb2: "vars b2 \<subseteq> Mapping.keys eval"
      by simp_all
    obtain l11 l12
      where perb1: "path eval (reduce env b1) = Some l11"
        and perb2: "path eval (reduce env b2) = Some l12"
      using IF.IH (1) [OF vb1 path_exists [OF vb1]]
        IF.IH (2) [OF vb2 path_exists [OF vb2]] (*x1*)
      by auto (meson in_keysD)
    thus ?thesis unfolding reduce.simps using mx1 by auto
  next
    case True
    from IF.prems (1)
    have vb1: "vars b1 \<subseteq> Mapping.keys eval" and vb2: "vars b2 \<subseteq> Mapping.keys eval"
      and x1: "x1 \<in> Mapping.keys eval"
      by simp_all
    obtain l11 l12 x11
      where perb1: "path eval (reduce (Mapping.update x1 True env) b1) = Some l11"
        and perb2: "path eval (reduce (Mapping.update x1 True env) b2) = Some l12"
        and mx1: "Mapping.lookup eval x1 = Some x11"
      using IF.IH (1) [OF vb1 path_exists [OF vb1]]
        IF.IH (2) [OF vb2 path_exists [OF vb2]] x1
      by auto (meson in_keysD)
    thus ?thesis
      using True perb1 perb2 unfolding reduce.simps mkIF_def
      apply auto
      apply (cases x11)
      by (simp add: IF.IH(2) option.case_eq_if path_exists vb2)+
  qed
qed

corollary
  path_some:
  assumes v: "vars bdd \<subseteq> Mapping.keys eval"
  obtains l
  where "path eval bdd = Some l"
  using path_exists [OF v] by auto

corollary
  path_reduce_some:
  assumes v: "vars bdd \<subseteq> Mapping.keys eval"
  obtains l
  where "path eval (reduce env bdd) = Some l"
  using path_reduce_exists [OF v] by auto

corollary
  olength_some:
  assumes v: "vars bdd \<subseteq> Mapping.keys eval"
  obtains i
  where "olength (path eval bdd) = Some i"
  using path_some [OF v] unfolding olength_def
  by (metis option.simps(5))

corollary
  olength_reduce_some:
  assumes v: "vars bdd \<subseteq> Mapping.keys eval"
  obtains i
  where "olength (path eval (reduce env bdd)) = Some i"
  using path_reduce_some [OF v] unfolding olength_def
  by (metis option.simps(5))

(*lemma assumes pm: "path eval
       (mkIF x1 (reduce env1 b1) (reduce env2 b2)) = Some l"
      and p: "path eval (IF x1 b1 b2) = Some m"
    shows "set l \<subseteq> set m" and "length l \<le> length m"
proof (cases "(reduce (Mapping.update x1 True env1) b1) =
         (reduce (Mapping.update x1 False env1) b2)")
  case True
  hence "mkIF x1 (reduce (Mapping.update x1 True env1) b1)
         (reduce (Mapping.update x1 False env2) b2) =
         reduce (Mapping.update x1 True env1) b1"
    unfolding mkIF_def by simp*)

text\<open>Beware that if we omit the first premise of the following result
  then it does not hold:
  Nitpick found a counterexample for card 'a = 6:
  Free variables:
    @{term "b = IF a\<^sub>1 (IF a\<^sub>2 (IF a\<^sub>3 Falseif Trueif) Falseif) Trueif"},
    @{term "env = [a\<^sub>1 \<mapsto> True, a\<^sub>6 \<mapsto> False]"},
    @{term "eval =
      [a\<^sub>1 \<mapsto> False, a\<^sub>2 \<mapsto> True, a\<^sub>3 \<mapsto> False, a\<^sub>4 \<mapsto> False, a\<^sub>5 \<mapsto> False, a\<^sub>6
        \<mapsto> False]"},
    @{term "i = 2"},
    @{term "j = 1"}.
\<close>

lemma
  assumes v: "vars bdd \<subseteq> Mapping.keys eval"
    and c: "\<forall>x\<in>Mapping.keys eval.
          (Mapping.lookup env x = Mapping.lookup eval x \<or> Mapping.lookup env x = None)"
    and li: "olength (path eval (reduce env bdd)) = Some i"
    and lj: "olength (path eval bdd) = Some j"
  shows "i \<le> j"
  using c v li lj proof (induction bdd arbitrary: eval env i j)
  case Trueif
  then show ?case by simp
next
  case Falseif
  then show ?case by simp
next
  case (IF x1 b1 b2)
  from IF.prems (2)
  have vb1: "vars b1 \<subseteq> Mapping.keys eval" and vb2: "vars b2 \<subseteq> Mapping.keys eval"
    and x1: "x1 \<in> Mapping.keys eval"
    by simp_all
  obtain x11 where x1some: "Mapping.lookup eval x1 = Some x11"
    using x1 by (meson in_keysD)
  obtain lb1 where pb1: "path eval b1 = Some lb1" by (meson path_some vb1)
  obtain lb2 where pb2: "path eval b2 = Some lb2" by (meson path_some vb2)
  obtain lrb1t where pb1t: "path eval (reduce (Mapping.update x1 True env) b1) = Some lrb1t"
    using path_reduce_some vb1 by blast
  obtain lrb1f where pb1f: "path eval (reduce (Mapping.update x1 False env) b1) = Some lrb1f"
    using path_reduce_some vb1 by blast
  obtain lrb2t where pb2t: "path eval (reduce (Mapping.update x1 True env) b2) = Some lrb2t"
    using path_reduce_some vb2 by blast
  obtain lrb2f where pb2f: "path eval (reduce (Mapping.update x1 False env) b2) = Some lrb2f"
    using path_reduce_some vb2 by blast
  obtain i1 where oreb1: "olength (path eval (reduce env b1)) = Some i1"
    using olength_reduce_some [OF vb1] by auto
  obtain i12 where oreb12: "olength (path eval (reduce (Mapping.update x1 True env) b1)) = Some i12"
    using olength_reduce_some [OF vb1] by auto
  obtain j1 where ob1: "olength (path eval b1) = Some j1"
    using olength_some [OF vb1] by auto
  have i1j1: "i1 \<le> j1" using IF.IH (1) [OF IF.prems (1) vb1 oreb1 ob1] .
  (*have i12j1: "i12 \<le> j1" using IF.IH (1) [OF _ vb1 oreb12 ob1] .*)
  obtain i2 where oreb2: "olength (path eval (reduce env b2)) = Some i2"
    using olength_reduce_some [OF vb2] by auto
  obtain i22 where oreb22: "olength (path eval (reduce (Mapping.update x1 False env) b2)) = Some i22"
    using olength_reduce_some [OF vb2] by auto
  obtain j2 where ob2: "olength (path eval b2) = Some j2"
    using olength_some [OF vb2] by auto
  have i2j2: "i2 \<le> j2" using IF.IH (2) [OF IF.prems (1) vb2 oreb2 ob2] .
  (*have i22j2: "i22 \<le> j2" using IF.IH (2) [OF _ vb2 oreb22 ob2] .*)
  show ?case
  proof (cases "Mapping.lookup env x1 = None")
    case True note x1none = True
    have r: "reduce env (IF x1 b1 b2) =
      mkIF x1 (reduce (Mapping.update x1 True env) b1)
              (reduce (Mapping.update x1 False env) b2)"
      unfolding reduce.simps using True by simp
    show ?thesis
    proof (cases "reduce (Mapping.update x1 True env) b1 =
           reduce (Mapping.update x1 False env) b2")
      case False
      hence mk: "mkIF x1 (reduce (Mapping.update x1 True env) b1)
              (reduce (Mapping.update x1 False env) b2) =
        IF x1 (reduce (Mapping.update x1 True env) b1)
              (reduce (Mapping.update x1 False env) b2)"
        unfolding mkIF_def by simp
      show ?thesis
      proof (cases "x11")
        case True
        have i12j1: "i12 \<le> j1"
          using IF.IH (1) [OF _ vb1 oreb12 ob1]
            IF.prems (1) x1none
          by (simp add: True lookup_update_unfold x1some)
        have li12: "length (the (path eval (reduce (Mapping.update x1 True env) b1)))
          = i12"
            and li: "length (the (path eval (reduce env (IF x1 b1 b2)))) = i"
          using pb1t oreb12 IF.prems (3)
          unfolding olength_def apply simp_all
          by (metis (no_types, lifting) option.case_eq_if option.distinct(1) option.sel)
        have "i = i12 + 1"
          unfolding li12 [symmetric] li [symmetric]
          unfolding r mk unfolding path.simps
          using True x1some pb1t by auto
        moreover have "length (the (path eval (IF x1 b1 b2))) = j"
          and "j = j1 + 1" using IF.prems (4) unfolding path.simps
          using x1some using ob1 unfolding olength_def using True
           apply auto
            apply (metis option.case_eq_if option.distinct(1) option.sel)
          by (smt (verit, ccfv_SIG) True length_Cons option.case_eq_if option.distinct(1) option.sel)
        ultimately show ?thesis using IF.prems (2,3)
          using i12j1 oreb12
          unfolding olength_def by auto
      next
        case False
        have i22j2: "i22 \<le> j2"
          using IF.IH (2) [OF _ vb2 oreb22 ob2]
            IF.prems (1) x1none
          by (simp add: False lookup_update_unfold x1some)
        have li22: "length (the (path eval (reduce (Mapping.update x1 False env) b2)))
          = i22"
            and li: "length (the (path eval (reduce env (IF x1 b1 b2)))) = i"
          using pb2f oreb22 IF.prems (3)
          unfolding olength_def apply simp_all
          by (metis (no_types, lifting) option.case_eq_if option.distinct(1) option.sel)
        have "i = i22 + 1"
          unfolding li22 [symmetric] li [symmetric]
          unfolding r mk unfolding path.simps
          using False x1some pb2f by auto
        moreover have "length (the (path eval (IF x1 b1 b2))) = j"
          and "j = j2 + 1" using IF.prems (4) unfolding path.simps
          using x1some using ob2 unfolding olength_def using False
           apply auto
            apply (metis option.case_eq_if option.distinct(1) option.sel)
          by (smt (verit, ccfv_SIG) False length_Cons option.case_eq_if option.distinct(1) option.sel)
        ultimately show ?thesis using IF.prems (2,3)
          using i22j2 oreb22
          unfolding olength_def by auto
      qed
    next
      case True note b1b2eq = True
      have rb1: "reduce env (IF x1 b1 b2) = reduce (Mapping.update x1 True env) b1"
        unfolding r unfolding mkIF_def using True
        unfolding reduce.simps using x1some by auto
      show ?thesis
      proof (cases "x11")
        case True
        have i12j1: "i12 \<le> j1"
          using IF.IH (1) [OF _ vb1 oreb12 ob1]
            IF.prems (1) x1none
          by (simp add: True lookup_update_unfold x1some)
        have li12: "length (the (path eval (reduce (Mapping.update x1 True env) b1)))
          = i12"
            and li: "length (the (path eval (reduce env (IF x1 b1 b2)))) = i"
          using pb1t oreb12 IF.prems (3)
          unfolding olength_def apply simp_all
          by (metis (no_types, lifting) option.case_eq_if option.distinct(1) option.sel)
        have "i12 \<le> i"
          unfolding li12 [symmetric] li [symmetric]
          unfolding r rb1 unfolding path.simps
          using True x1some pb1t
          using r rb1 by auto
        moreover have "length (the (path eval (IF x1 b1 b2))) = j"
          and "j = j1 + 1" using IF.prems (4) unfolding path.simps
          using x1some using ob1 unfolding olength_def using True
           apply auto
            apply (metis option.case_eq_if option.distinct(1) option.sel)
          by (smt (verit, ccfv_SIG) True length_Cons option.case_eq_if option.distinct(1) option.sel)
        ultimately show ?thesis using IF.prems (2,3)
          using i12j1 oreb12
          unfolding olength_def
          by (metis li li12 rb1 trans_le_add1)
      next
        case False
        have i22j2: "i22 \<le> j2"
          using IF.IH (2) [OF _ vb2 oreb22 ob2]
            IF.prems (1) x1none
          by (simp add: False lookup_update_unfold x1some)
        have li22: "length (the (path eval (reduce (Mapping.update x1 False env) b2)))
          = i22"
            and li: "length (the (path eval (reduce env (IF x1 b1 b2)))) = i"
          using pb2f oreb22 IF.prems (3)
          unfolding olength_def apply simp_all
          by (metis (no_types, lifting) option.case_eq_if option.distinct(1) option.sel)
        have "i22 \<le> i"
          unfolding li22 [symmetric] li [symmetric]
          unfolding r rb1 unfolding path.simps
          using True x1some pb1t
          using r rb1 by auto
        moreover have "length (the (path eval (IF x1 b1 b2))) = j"
          and "j = j2 + 1" using IF.prems (4) unfolding path.simps
          using x1some using ob2 unfolding olength_def using False
           apply auto
            apply (metis option.case_eq_if option.distinct(1) option.sel)
          by (smt (verit, ccfv_SIG) False length_Cons option.case_eq_if option.distinct(1) option.sel)
        ultimately show ?thesis using IF.prems (2,3)
          using i22j2 oreb12
          unfolding olength_def
          by (metis True li li22 rb1 trans_le_add1)
        qed
      qed
  next
    case False
    then obtain bl where x1envsome: "Mapping.lookup env x1 = Some bl" by auto
    show ?thesis
    proof (cases bl)
      case True
      have r: "reduce env (IF x1 b1 b2) = reduce env b1"
        unfolding reduce.simps using x1envsome True by auto
      show ?thesis
      proof (cases "x11")
        case True
        have li12: "length (the (path eval (reduce env b1)))
          = i1"
            and li: "length (the (path eval (reduce env (IF x1 b1 b2)))) = i"
          using vb1 oreb1 IF.prems (3)
          unfolding olength_def apply simp_all
          apply (simp add: option.case_eq_if path_reduce_exists)
          by (metis (no_types, lifting) option.case_eq_if option.distinct(1) option.inject)
        have "i1 = i"
          unfolding li12 [symmetric] li [symmetric]
          unfolding r unfolding path.simps ..
        moreover have "length (the (path eval (IF x1 b1 b2))) = j"
          and "j = j1 + 1" using IF.prems (4) unfolding path.simps
          using x1some using ob1 unfolding olength_def using True
           apply auto
            apply (metis option.case_eq_if option.distinct(1) option.sel)
          by (smt (verit, ccfv_SIG) True length_Cons option.case_eq_if option.distinct(1) option.sel)
        ultimately show ?thesis using IF.prems (2,3)
          using i1j1 oreb12
          unfolding olength_def by auto
      next
        case False
        with IF.prems (1) x1some x1envsome True have False
          using x1 by fastforce
        thus ?thesis by fast
      qed
    next
      case False note nbl = False
      have r: "reduce env (IF x1 b1 b2) = reduce env b2"
        unfolding reduce.simps using x1envsome False by auto
      show ?thesis
      proof (cases "x11")
        case False
        have li12: "length (the (path eval (reduce env b2)))
          = i2"
            and li: "length (the (path eval (reduce env (IF x1 b1 b2)))) = i"
          using vb2 oreb2 IF.prems (3)
          unfolding olength_def apply simp_all
          apply (simp add: option.case_eq_if path_reduce_exists)
          by (metis (no_types, lifting) option.case_eq_if option.distinct(1) option.inject)
        have "i2 = i"
          unfolding li12 [symmetric] li [symmetric]
          unfolding r unfolding path.simps ..
        moreover have "length (the (path eval (IF x1 b1 b2))) = j"
          and "j = j2 + 1" using IF.prems (4) unfolding path.simps
          using x1some using ob2 unfolding olength_def using False
           apply auto
            apply (metis option.case_eq_if option.distinct(1) option.sel)
          by (smt (verit, ccfv_SIG) False length_Cons option.case_eq_if option.distinct(1) option.sel)
        ultimately show ?thesis using IF.prems (2,3)
          using i2j2 oreb12
          unfolding olength_def by auto
      next
        case True
        with IF.prems (1) x1some x1envsome nbl have False
          using x1 by fastforce
        thus ?thesis by fast
      qed
    qed
  qed
qed

lemma
  assumes x: "x \<notin> Mapping.keys env"
  shows "depth (reduce env (IF x b1 b2)) \<le> depth (IF x b1 b2)"
  using x proof (induct rule: reduce.induct)
  case ("2_1" env)
  show ?case by simp
next
  case ("2_2" env)
  show ?case by simp
next
  case (1 uu x t1 t2)
  from "1.prems" have "Mapping.lookup uu y = None" try
  show ?case using "1.hyps" and "1.prems" sorry
qed

proof (induct b)
  case Trueif
  then show ?case by simp
next
  case Falseif
  then show ?case by simp
next
  case (IF x1 b1 b2)
  then show ?case sorry
qed

lemma "depth (reduce_alist [] b) \<le> depth b"
proof (induct b)
  case Trueif
  show ?case by simp
next
  case Falseif
  show ?case by simp
next
  case (IF x1 b1 b2)
  show ?case
    unfolding reduce_alist.simps
  proof (simp)
    have "depth (mkIF x1 (reduce_alist [(x1, True)] b1) (reduce_alist [(x1, False)] b2))
    \<le> Suc (min (depth (reduce_alist [(x1, True)] b1)) (depth (reduce_alist [(x1, False)] b2)))"
      by (rule depth_mkIF)
    have "depth (reduce_alist [(x1, True)] b1) \<le> depth b1 + 1"
    proof (induct b1)
      case Trueif
      then show ?case by simp
    next
      case Falseif
      then show ?case by simp
    next
      case (IF x2 b11 b12)
      show ?case proof (cases "x1 = x2")
        case True
        show ?thesis unfolding True reduce_alist.simps
          apply simp using IF.hyps (1)
          apply auto unfolding True
          using suc_min
        try
        by (metis add.commute le_add_same_cancel2 reduce_alist.elims reduce_alist.simps(1) zero_order(1))
    qed
      try
      show "depth (mkIF x1 (reduce_alist [(x1, True)] b1) (reduce_alist [(x1, False)] b2))
    \<le> Suc (min (depth b1) (depth b2))"
      using IF.hyps using depth_mkIF

         try
  proof (cases "Mapping.lookup env x1")
    case None
    have "depth (mkIF x1 (reduce (Mapping.update x1 True env) b1) (reduce (Mapping.update x1 False env) b2))
          \<le> depth (IF x1 b1 b2)"
      unfolding depth.simps (3)
      using IF.hyps (1) [of "(Mapping.update x1 True env)"]
      using IF.hyps (2) [of "(Mapping.update x1 False env)"]
      unfolding mkIF_def by auto
    thus ?thesis using None unfolding reduce.simps by simp
  next
    case (Some b)
    show ?thesis
    proof (cases b)
      case True note b = True
      show ?thesis
      proof (cases "depth b1 \<le> depth b2")
        case True hence db1: "depth (IF x1 b1 b2) = Suc (depth b1)" by simp
        show ?thesis unfolding reduce.simps Some using b using db1
          by (simp add: IF.hyps(1) le_SucI)
      next
        case False hence db2: "depth (IF x1 b1 b2) = Suc (depth b2)" by simp
        show ?thesis unfolding reduce.simps Some using b using IF.hyps(1,2) [of env] using db2
          apply auto try

      qed

        using Some unfolding reduce.simps using True apply simp sorry
    next
      case False
      then show ?thesis sorry
    qed
      unfolding reduce.simps
    have "depth (reduce env (IF x1 b1 b2)) \<le> depth (IF x1 b1 b2)" try
    have "depth (reduce env (if b then b1 else b2)) \<le> depth (IF x1 b1 b2)"
      using IF.hyps [of env] apply (cases b) apply auto try
      unfolding reduce.simps

    show ?thesis unfolding reduce.simps
  qed

(*datatype ifex = CIF bool | VIF nat | IF ifex ifex ifex*)

datatype ifex = CIF bool | IF nat ifex ifex

primrec
valif :: "ifex => (nat => bool) => bool"
  where
  "valif (CIF b)    env = b" |
  "valif (IF b f t) env = (if env b then valif f env
                                      else valif t env)"

(*primrec valif :: "ifex => (nat => bool) => bool"
  where
  "valif (CIF b)    env = b" |
  "valif (VIF x)    env = env x" |
  "valif (IF b t e) env = (if valif b env then valif t env
                                      else valif e env)"
*)

lemma "valif (CIF True) f" by simp

lemma "\<not> valif (CIF False) f" by simp

(*lemma "valif (VIF 3) (\<lambda>x. True)" by simp*)

(*lemma "\<not> valif (VIF 3) (\<lambda>x. False)" by simp*)

lemma "valif (IF 3 (IF 3 (CIF True) (CIF False))
                         (IF 3 (CIF True) (CIF False)))
              (\<lambda>x. if x = 3 then True else False)" by simp

(*lemma "valif (IF (VIF 3) (IF (VIF 3) (CIF True) (CIF False))
                         (IF (VIF 3) (CIF True) (CIF False)))
              (\<lambda>x. if x = 3 then True else False)" by simp*)

(*lemma "\<not> valif (IF (VIF 3) (IF (VIF 2) (CIF True) (CIF False))
                         (IF (VIF 4) (CIF True) (CIF False)))
              (\<lambda>x. if x = 3 then True else False)" by simp*)

lemma "\<not> valif (IF 3 (IF 3 (CIF True) (CIF False))
                         (IF 3 (CIF True) (CIF False)))
              (\<lambda>x. if x = 2 then True else False)" by simp

(*lemma "\<not> valif (IF (VIF 3) (IF (VIF 3) (CIF True) (CIF False))
                         (IF (VIF 3) (CIF True) (CIF False)))
              (\<lambda>x. if x = 2 then True else False)" by simp*)

lemma "\<not> valif (IF 1 (IF 2 (IF 3 (IF 4 (CIF True) (CIF False))
                                 (IF 4 (CIF True) (CIF False)))
                           (IF 3 (IF 4 (CIF True) (CIF False))
                                 (IF  4 (CIF True) (CIF False))))
                           (IF 4 (CIF True) (CIF False)))
              (\<lambda>x. if x = 3 then True else False)" by simp

(*lemma "\<not> valif (IF (VIF 1) (IF (VIF 2) (IF (VIF 3) (IF (VIF 4) (CIF True) (CIF False))
                                                   (IF (VIF 4) (CIF True) (CIF False)))
                                       (IF (VIF 3) (IF (VIF 4) (CIF True) (CIF False))
                                                   (IF (VIF 4) (CIF True) (CIF False))))
                           (IF (VIF 4) (CIF True) (CIF False)))
              (\<lambda>x. if x = 3 then True else False)" by simp*)

fun vars :: "ifex \<Rightarrow> nat set"
  where
  "vars (IF v f t) =  insert v (vars f \<union> vars t)" |
  "vars (CIF b) = {}"

fun ifex_unique_var :: "ifex \<Rightarrow> bool"
  where
    "ifex_unique_var (CIF b) = True" |
    "ifex_unique_var (IF n f t) = (n \<notin> vars t \<and> n \<notin> vars f)"

lemma "ifex_unique_var (IF 1 (IF 2 (IF 3 (IF 4 (CIF True) (CIF False))
                                 (IF 4 (CIF True) (CIF False)))
                           (IF 3 (IF 4 (CIF True) (CIF False))
                                 (IF  4 (CIF True) (CIF False))))
                           (IF 4 (CIF True) (CIF False)))" by simp

lemma "\<not> ifex_unique_var (IF 3 (IF 3 (CIF True) (CIF False))
                         (IF 3 (CIF True) (CIF False)))" by simp

fun depth :: "ifex \<Rightarrow> nat"
  where
    "depth (CIF b) = 0" |
    "depth (IF b f t) = 1 + min (depth f) (depth t)"

lemma "depth (IF 1 (IF 2 (IF 3 (IF 4 (CIF True) (CIF False))
                                 (IF 4 (CIF True) (CIF False)))
                           (IF 3 (IF 4 (CIF True) (CIF False))
                                 (IF  4 (CIF True) (CIF False))))
                           (IF 4 (CIF True) (CIF False))) = 2" by simp

text\<open>Pending definition\<close>

fun reduce :: "ifex \<Rightarrow> (nat \<Rightarrow> bool) \<Rightarrow> ifex"
  where
    "reduce (CIF b) env = CIF b" |
    "reduce (IF a f t) env = (if f = t then (reduce f env) else IF a (reduce f (env(a:=True)))
                               (reduce t (env(a:=False))))"

value "reduce (IF 1 (IF 2 (IF 3 (IF 4 (CIF True) (CIF False))
                                 (IF 4 (CIF True) (CIF False)))
                           (IF 3 (IF 4 (CIF True) (CIF False))
                                 (IF  4 (CIF True) (CIF False))))
                           (IF 4 (CIF True) (CIF False))) (\<lambda>x. if x = 3 then False else True)"

section\<open>Boolean expressions\<close>

text\<open>We are interested in boolean expressions that come from
  simplicial complexes, that is, collections of simplices
  that can be expressed as conjunctive normal forms.\<close>

datatype 'a bexp =
  Const bool |
  Atom 'a |
  Neg "'a bexp" |
  And "'a bexp" "'a bexp" |
  Or "'a bexp" "'a bexp"

fun bval where
  "bval (Const b) s = b" |
  "bval (Atom a) s = s a" |
  "bval (Neg b) s = (\<not> bval b s)" |
  "bval (And b1 b2) s = (bval b1 s \<and> bval b2 s)" |
  "bval (Or b1 b2) s = (bval b1 s \<or> bval b2 s)"

fun bool_expr_of_bexp :: "'a bexp \<Rightarrow> 'a bool_expr"
where
  "bool_expr_of_bexp (Const b) = Const_bool_expr b"
  | "bool_expr_of_bexp (Atom a) = Atom_bool_expr a"
  | "bool_expr_of_bexp (Neg b) = Neg_bool_expr(bool_expr_of_bexp b)"
  | "bool_expr_of_bexp (And b1 b2) = And_bool_expr (bool_expr_of_bexp b1) (bool_expr_of_bexp b2)"
  | "bool_expr_of_bexp (Or b1 b2) = Or_bool_expr (bool_expr_of_bexp b1) (bool_expr_of_bexp b2)"

lemma val_preservation:
  "val_bool_expr (bool_expr_of_bexp b) s = bval b s"
  by (induction b) auto
term range
definition bexp_from_simplice :: "nat set => nat \<Rightarrow> nat bexp"
  where "bexp_from_simplice \<sigma> n = range
    (\<lambda>i. if i \<in> \<sigma> then (And i (bexp_from_simplice (\<sigma> - {i})) else (bexp_from_simplice (\<sigma> - {i})) {..<n}"

lemma

  assumes "depth (IF a t f) = n"
    and "a \<in> vars t"
  shows "True"

end


theory Abstract_Quantales
  imports Main
begin

no_notation
  times (infixl "*" 70) and
  one_class.one ("1")

locale abs_complete_lattice =
  fixes Join :: "'a set \<Rightarrow> 'a" ("\<Oplus>_" [900] 900)
  assumes Join_singleton: "\<Oplus>{x} = x"
  and Join_Union: "\<Oplus>{\<Oplus>x| x. x \<in> X} = \<Oplus>(\<Union>X)"
  and Join_limit: "(\<And>x. x \<in> A \<Longrightarrow> z = \<Oplus>{x, z}) \<Longrightarrow> z = \<Oplus> {z, \<Oplus> A}"

context abs_complete_lattice begin

lemma Join_absorb: "x \<in> A \<Longrightarrow> \<Oplus>A = \<Oplus> {x, \<Oplus> A}"
proof -
  assume "x \<in> A"
  hence "\<Oplus>A = \<Oplus>(\<Union>{{x},A})"
    by auto (metis insert_absorb)
  also have "... = \<Oplus> {\<Oplus> {x}, \<Oplus> A}"
    by (subst Join_Union[symmetric]) (auto intro: cong[of "\<lambda>X.\<Oplus>X"])
  finally show ?thesis
    by (metis Join_singleton)
qed

lemma Join_simp1: "\<Oplus>{x, \<Oplus>{y, z}} = \<Oplus>{x, y, z}"
proof -
  have "\<Oplus>{x, \<Oplus>{y, z}} = \<Oplus>{\<Oplus>{x}, \<Oplus>{y, z}}"
    by (metis Join_singleton)
  also have "... = \<Oplus>(\<Union>{{x}, {y, z}})"
    by (subst Join_Union[symmetric]) (auto intro: cong[of "\<lambda>X.\<Oplus>X"])
  finally show ?thesis
    by (auto simp: insert_commute)
qed

lemma Join_simp2: "\<Oplus>{x, \<Oplus>A} = \<Oplus>{y. y = x \<or> y \<in> A}"
proof -
  have "\<Oplus>{x, \<Oplus>A} = \<Oplus>{\<Oplus>{x}, \<Oplus>A}"
    by (metis Join_singleton)
  also have "... = \<Oplus>(\<Union>{{x}, A})"
    by (subst Join_Union[symmetric]) (auto intro: cong[of "\<lambda>X.\<Oplus>X"])
  finally show ?thesis
    by auto (metis insert_compr)
qed

lemma Join_reduce1: "x = \<Oplus>{x, y, z} \<Longrightarrow> x = \<Oplus>{x, y}"
  by (metis Join_absorb insertI1 insert_commute)

lemma Join_reduce2: "x = \<Oplus>{x, y, z} \<Longrightarrow> x = \<Oplus>{x, z}"
  by (metis Join_reduce1 insert_commute)

lemma Join_trans: "y = \<Oplus>{x, y} \<Longrightarrow> z = \<Oplus>{y, z} \<Longrightarrow> z = \<Oplus>{x, z}"
  by (metis Join_simp1 insert_commute)

definition join :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<oplus>" 70) where
  "x \<oplus> y \<equiv> \<Oplus> {x, y}"

definition less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 55) where
  "x \<sqsubseteq> y \<equiv> y = x \<oplus> y"

definition less :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubset>" 55) where
  "x \<sqsubset> y \<equiv> x \<sqsubseteq> y \<and> \<not> y \<sqsubseteq> x"

lemma less_le_not_le: "x \<sqsubset> y \<longleftrightarrow> (x \<sqsubseteq> y \<and> \<not> y \<sqsubseteq> x)"
  by (simp add: less_eq_def less_def)

lemma order_refl [iff]: "x \<sqsubseteq> x"
  by (simp add: less_eq_def join_def Join_singleton)

lemma order_trans [trans]: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z"
  by (auto simp: less_eq_def join_def intro: Join_trans)

lemma antisym: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> x = y"
  by (auto simp: less_eq_def join_def insert_commute)

lemma less_var: "x \<sqsubset> y \<longleftrightarrow> x \<sqsubseteq> y \<and> x \<noteq> y"
  apply (auto simp: less_def)
  by (metis antisym)

lemma ineq: "x \<noteq> y \<Longrightarrow> \<not> x \<sqsubseteq> y \<or> \<not> y \<sqsubseteq> x"
  by (metis antisym)

lemma less_eq_less: "x \<sqsubset> y \<Longrightarrow> x \<sqsubseteq> y"
  by (simp add: less_def)

definition Meet :: "'a set \<Rightarrow> 'a" ("\<Odot>_" [900] 900) where
  "\<Odot>A \<equiv> \<Oplus>{x. \<forall>y \<in> A. x \<sqsubseteq> y}"

definition meet :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<odot>" 65) where
  "x \<odot> y \<equiv> \<Odot>{x, y}"

lemma meet_le1 [simp]: "x \<odot> y \<sqsubseteq> x"
  by (auto simp add: meet_def Meet_def less_eq_def join_def insert_commute intro: Join_limit)

lemma meet_le2 [simp]: "x \<odot> y \<sqsubseteq> y"
  by (metis meet_comm meet_le1)

lemma meet_greatest: "x \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<odot> z"
  by (auto simp add: meet_def Meet_def less_eq_def join_def insert_commute intro: Join_absorb)

lemma join_comm: "x \<oplus> y = y \<oplus> x"
  by (simp add: insert_commute join_def)

lemma join_ge1 [simp]: "x \<sqsubseteq> x \<oplus> y"
  by (auto simp add: less_eq_def join_def insert_commute intro: Join_absorb)

lemma join_ge2 [simp]: "y \<sqsubseteq> x \<oplus> y"
  by (metis join_comm join_ge1)

lemma join_least: "y \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> x \<Longrightarrow> y \<oplus> z \<sqsubseteq> x"
  by (auto simp: less_eq_def join_def insert_commute intro: Join_limit)

definition top :: "'a" ("\<top>") where "top \<equiv> \<Odot>{}"

definition bot :: "'a" ("\<bottom>") where "bot \<equiv> \<Oplus>{}"

lemma top_greatest: "x \<sqsubseteq> \<top>"
  by (auto simp: top_def Meet_def less_eq_def join_def insert_commute intro: Join_absorb)

lemma bot_least: "\<bottom> \<sqsubseteq> x"
  by (auto simp: bot_def less_eq_def join_def insert_commute intro: Join_limit)

lemma Meet_lower: "x \<in> A \<Longrightarrow> \<Odot>A \<sqsubseteq> x"
  by (auto simp: Meet_def less_eq_def join_def insert_commute intro: Join_limit)

lemma Meet_greatest: "(\<And>x. x \<in> A \<Longrightarrow> z \<sqsubseteq> x) \<Longrightarrow> z \<sqsubseteq> \<Odot>A"
  by (auto simp: Meet_def less_eq_def join_def intro: Join_absorb)

lemma Join_upper: "x \<in> A \<Longrightarrow> x \<sqsubseteq> \<Oplus>A"
  by (auto simp: less_eq_def join_def intro: Join_absorb)

lemma Join_least: "(\<And>x. x \<in> A \<Longrightarrow> x \<sqsubseteq> z) \<Longrightarrow> \<Oplus>A \<sqsubseteq> z"
  by (auto simp: less_eq_def join_def insert_commute intro: Join_limit)

lemma Join_Collect_upper: "P x \<Longrightarrow> x \<sqsubseteq> \<Oplus> Collect P"
  by (metis Join_upper mem_Collect_eq)

lemma Meet_Collect_lower: "P x \<Longrightarrow> \<Odot> Collect P \<sqsubseteq> x"
  by (metis Meet_lower mem_Collect_eq)

definition complements :: "'a \<Rightarrow> 'a set" where
  "complements x = {y. x \<oplus> y = \<top> \<and> x \<odot> y = \<bottom>}"

lemma complementsE1: "y \<in> complements x \<Longrightarrow> x \<oplus> y = \<top>"
  by (metis (lifting, mono_tags) complements_def mem_Collect_eq)

lemma complementsE2: "y \<in> complements x \<Longrightarrow> x \<odot> y = \<bottom>"
  by (metis (lifting, full_types) complements_def mem_Collect_eq)

lemma complementsI1: "\<lbrakk>x \<oplus> y = \<top>; x \<odot> y = \<bottom>\<rbrakk> \<Longrightarrow> y \<in> complements x"
  by (metis (lifting, full_types) complements_def mem_Collect_eq)

lemma complementsI2: "\<lbrakk>x \<oplus> y = \<top>; x \<odot> y = \<bottom>\<rbrakk> \<Longrightarrow> x \<in> complements y"
  by (metis complementsI1 join_comm meet_comm)

lemma pre_order [simp]: "class.preorder op \<sqsubseteq> op \<sqsubset>"
  by default (auto simp: less_le_not_le, metis order_trans)

lemma order [simp]: "class.order_axioms op \<sqsubseteq>"
  by default (metis antisym)

lemma semillatice_inf [simp]: "class.semilattice_inf_axioms op \<odot> op \<sqsubseteq>"
  by default (simp_all add: meet_greatest)

lemma semilattice_sup [simp]: "class.semilattice_sup_axioms op \<oplus> op \<sqsubseteq>"
  by default (simp_all add: join_least)

lemma order_bot [simp]: "class.order_bot_axioms \<bottom> op \<sqsubseteq>"
  by default (metis bot_least)

lemma order_top [simp]: "class.order_top_axioms op \<sqsubseteq> \<top>"
  by default (metis top_greatest)

lemma comp_lattice [simp]: "class.complete_lattice Meet Join meet less_eq less join bot top"
  apply (intro_locales, simp_all)
  by default (simp_all add: top_def bot_def Meet_lower Meet_greatest Join_upper Join_least)

lemma dual_comp_lattice: "class.complete_lattice Join Meet join (\<lambda>x y. y \<sqsubseteq> x) (\<lambda>x y. y \<sqsubset> x) meet top bot"
  by unfold_locales (simp_all add: less_le_not_le antisym top_def bot_def join_least meet_greatest
    Meet_lower Meet_greatest Join_upper Join_least, metis order_trans)

end

locale abs_distrib_complete_lattice = abs_complete_lattice +
  assumes join_Meet: "x \<oplus> \<Odot>Y = \<Odot>{x \<oplus> y | y. y \<in> Y}"
  and meet_Join: "x \<odot> \<Oplus>Y = \<Oplus>{x \<odot> y | y. y \<in> Y}"
begin

lemma meet_join: "x \<odot> (y \<oplus> z) = (x \<odot> y) \<oplus> (x \<odot> z)"
  apply (insert meet_Join[of x "{y, z}"])
  by (auto simp add: join_def intro: cong[of "\<lambda>X. \<Oplus>X"])

lemma join_meet: "x \<oplus> (y \<odot> z) = (x \<oplus> y) \<odot> (x \<oplus> z)"
  apply (insert join_Meet[of x "{y, z}"])
  by (auto simp: join_def meet_def intro!: cong[of "\<lambda>X. \<Odot>X"])

lemma compl_uniq_le: "\<lbrakk>y \<in> complements x; z \<in> complements x\<rbrakk> \<Longrightarrow> z \<sqsubseteq> y"
proof (auto simp: complements_def)
  assume hyp: "x \<oplus> y = \<top>" "x \<odot> y = \<bottom>" "x \<oplus> z = \<top>" "x \<odot> z = \<bottom>"
  have "y = y \<oplus> \<bottom>"
    by (metis Join_limit bot_def ex_in_conv join_def)
  also have "... = y \<oplus> (x \<odot> z)"
    by (metis hyp(4))
  also have "... = (y \<oplus> x) \<odot> (y \<oplus> z)"
    by (metis join_meet)
  also have "... = \<top> \<odot> (y \<oplus> z)"
    by (metis hyp(1) join_comm)
  finally show "z \<sqsubseteq> y"
    by (metis join_ge2 meet_greatest top_greatest)
qed

lemma compl_uniq: "\<lbrakk>y \<in> complements x; z \<in> complements x\<rbrakk> \<Longrightarrow> y = z"
  by (metis antisym compl_uniq_le)

definition compl :: "'a \<Rightarrow> 'a" ("-- _" [99] 100) where
  "-- x \<equiv> THE y. y \<in> complements x"

definition diff :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "--" 65) where
  "x -- y \<equiv> x \<oplus> (-- y)"

lemma distrib_lattice [simp]: "class.distrib_lattice_axioms op \<odot> op \<oplus>"
  by default (metis join_meet)

end

locale abs_near_quantale = abs_complete_lattice + semigroup +
  assumes Join_distr: "\<Oplus> Y * x = \<Oplus> ((\<lambda>y. y * x) ` Y)"

locale abs_pre_quantale = abs_near_quantale +
  assumes Join_subdistl: "x * \<Oplus> Y = \<Oplus> {\<Oplus> ((\<lambda>y. x * y) ` Y), x * \<Oplus> Y}"

locale abs_near_quantale_unital = abs_near_quantale + monoid

locale abs_quantale = abs_pre_quantale +
  assumes Join_supdistl: "\<Oplus> ((\<lambda>y. x * y) ` Y) = \<Oplus> {\<Oplus> ((\<lambda>y. x * y) ` Y), x * \<Oplus> Y}"

locale abs_quantale_unital = abs_quantale + monoid

locale abs_comm_quantale = abs_quantale + abel_semigroup

locale abs_comm_quantale_unital = abs_quantale + comm_monoid

context abs_near_quantale begin

lemma qdistr: "(x \<oplus> y) * z = (x * z) \<oplus> (y * z)"
  by (insert Join_distr[of "{x, y}"]) (simp add: join_def)

lemma qannir [simp]: "\<bottom>  *  x = \<bottom>"
  by (insert Join_distr[of "{}"]) (simp add: bot_def)

lemma qisor: "x \<sqsubseteq> y \<Longrightarrow> x  *  z \<sqsubseteq> y  *  z"
  by (metis less_eq_def qdistr)

lemma join_subdistr: "(x \<oplus> y)  *  z \<sqsubseteq> (x  *  z) \<oplus> (y  *  z)"
  by (metis order_refl qdistr)

lemma Meet_subdistr: "\<Odot>Y * x \<sqsubseteq> \<Odot>{y * x | y. y \<in> Y}"
  by (auto simp add: Meet_def Join_distr qisor intro!: Join_least Join_upper)

lemma Join_eqI2: "(\<And>x. x \<in> A \<Longrightarrow> x \<in> B) \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> x \<in> A) \<Longrightarrow> \<Oplus>A = \<Oplus>B"
  by (metis subsetI subset_antisym)

lemma Meet_eqI2: "(\<And>x. x \<in> A \<Longrightarrow> x \<in> B) \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> x \<in> A) \<Longrightarrow> \<Odot>A = \<Odot>B"
  by (metis subsetI subset_antisym)

end

context abs_near_quantale_unital begin

primrec qpower :: "'a \<Rightarrow> nat \<Rightarrow> 'a" ("_ power _" [101,99] 100) where
  "x power (0 :: nat) = (1 :: 'a)"
| "x power (Suc n) = x * x power n"

lemma qpower_add: "x power m * x power n = x power (plus m n)"
  by (induct m, simp_all) (metis assoc)

lemma qpower_comm: "x power n * x = x * x power n"
  by (metis add_Suc_right qpower.simps qpower_add right_neutral)

lemma qpower_inductr: "y * x \<sqsubseteq> y \<Longrightarrow> y * x power n \<sqsubseteq> y"
  by (induct n, auto) (metis assoc order_trans qisor)

definition qstar :: "'a \<Rightarrow> 'a" ("_\<^sup>\<star>" [101] 100) where
  "x\<^sup>\<star> \<equiv> \<Oplus> {y. \<exists>i. y = x power i}"

lemma qstar_distr: "x\<^sup>\<star> * y = \<Oplus> {z * y | z. \<exists>i. z = x power i}"
  by (auto simp: qstar_def Join_distr intro: Join_eqI2)

lemma qstar_ref [simp]: "(1 :: 'a) \<sqsubseteq> x\<^sup>\<star>"
  by (auto simp: qstar_def intro!: Join_upper exI[of _ 0])

lemma qstar_refi: "x power i \<sqsubseteq> x\<^sup>\<star>"
  by (auto simp add: qstar_def intro: Join_upper)

lemma qstar_unfoldr_var: "x\<^sup>\<star> * x \<sqsubseteq> x\<^sup>\<star>"
  by (subst qstar_def, auto simp: Join_distr qpower_comm intro!: Join_least) (metis qpower.simps(2) qstar_refi)

lemma qstar_unfoldr1: "1 \<oplus> (x\<^sup>\<star> * x) \<sqsubseteq> x\<^sup>\<star>"
  by (auto simp add: qstar_unfoldr_var intro: join_least)

lemma qstar_unfoldr2: "x\<^sup>\<star> \<sqsubseteq> 1 \<oplus> (x\<^sup>\<star> * x)"
  apply (subst qstar_def, auto intro!: Join_least, induct_tac i, auto)
  by (metis join_ge2 order_trans qpower_comm qisor qstar_refi)

lemma qstar_unfoldr: "1 \<oplus> (x\<^sup>\<star> * x) = x\<^sup>\<star>"
  by (metis antisym qstar_unfoldr1 qstar_unfoldr2)

end

context abs_pre_quantale begin

lemma Join_qsubdistl: "\<Oplus> ((\<lambda>y. x * y) ` Y) \<sqsubseteq> x * \<Oplus> Y"
  by (metis Join_subdistl join_def less_eq_def)

lemma qsubdistl: "(x * y) \<oplus> (x * z) \<sqsubseteq> x * (y \<oplus> z)"
  by (insert Join_qsubdistl[of _ "{y, z}"]) (simp add: join_def)

lemma qisol: "x \<sqsubseteq> y \<Longrightarrow> z * x \<sqsubseteq> z * y"
  by (metis antisym join_ge2 less_eq_def qsubdistl)

end

context abs_quantale begin

lemma Join_qsupdistl: "x * \<Oplus> Y \<sqsubseteq> \<Oplus> ((\<lambda>y. x * y) ` Y)"
  by (metis Join_subdistl Join_supdistl order_refl)

lemma Join_distl: "x * \<Oplus> Y = \<Oplus> ((\<lambda>y. x * y) ` Y)"
  by (metis Join_subdistl Join_supdistl)

lemma qsupdistl: "x * (y \<oplus> z) \<sqsubseteq> (x * y) \<oplus> (x * z)"
  by (insert Join_qsupdistl[of _ "{y, z}"]) (simp add: join_def)

lemma qdistl: "z * (x \<oplus> y) = (z * x) \<oplus> (z * y)"
  by (metis antisym qsubdistl qsupdistl)

lemma qannil [simp]: "x * \<bottom>  = \<bottom>"
  by (insert Join_distl[of _ "{}"]) (simp add: bot_def)

end

context abs_quantale_unital begin

sublocale abs_near_quantale_unital ..

lemma power_inductl: "x * y \<sqsubseteq> y \<Longrightarrow> x power n * y \<sqsubseteq> y"
  by (induct n, auto) (metis assoc qisol order_trans)

lemma qstar_distl: "x * y\<^sup>\<star> = \<Oplus>{x * z | z. \<exists>i. z = y power i}"
  by (auto simp: qstar_def Join_distl intro: Join_eqI2)

lemma qstar_unfoldl_var: "x * x\<^sup>\<star> \<sqsubseteq> x\<^sup>\<star>"
  by (subst qstar_def, auto simp: Join_distl qpower_comm intro!: Join_least) (metis qpower.simps(2) qstar_refi)

lemma qstar_unfoldl1: "1 \<oplus> (x * x\<^sup>\<star>) \<sqsubseteq> x\<^sup>\<star>"
  by (auto simp add: qstar_unfoldl_var intro: join_least)

lemma qstar_unfoldl2: "x\<^sup>\<star> \<sqsubseteq> 1 \<oplus> (x * x\<^sup>\<star>)"
  apply (subst qstar_def, auto intro!: Join_least, induct_tac i, auto)
  by (metis join_ge2 order_trans qisol qstar_refi)

lemma qstar_unfoldl: "1 \<oplus> (x * x\<^sup>\<star>) = x\<^sup>\<star>"
  by (metis antisym qstar_unfoldl1 qstar_unfoldl2)

lemma qstar_inductr: "y \<oplus> (x * w) \<sqsubseteq> w \<Longrightarrow> x\<^sup>\<star> * y \<sqsubseteq> w"
  apply (auto simp add: qstar_distr intro!: Join_least)
  apply (induct_tac i, auto)
  apply (metis join_ge1 order_trans)
  by (metis assoc join_ge2 order_trans qisol)

lemma qstar_inductl: "y \<oplus> (w * x) \<sqsubseteq> w \<Longrightarrow> y * x\<^sup>\<star> \<sqsubseteq> w"
  apply (auto simp add: qstar_distl intro!: Join_least)
  apply (induct_tac i, auto)
  apply (metis join_ge1 order_trans)
  apply (subst qpower_comm[symmetric])
  by (metis join_ge2 assoc order_trans qisor)

end

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_55
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun len :: "'a list => Nat" where
  "len (nil2) = Z"
| "len (cons2 z xs) = S (len xs)"

fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) z = z"
| "drop (S z2) (nil2) = nil2"
| "drop (S z2) (cons2 x2 x3) = drop z2 x3"

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

theorem property0 :
  "((drop n (x xs ys)) = (x (drop n xs) (drop (t2 n (len xs)) ys)))"
  oops

end


theory E4_3
  imports Main
begin

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

lemma assumes a: "ev (Suc (Suc n))" shows "ev n"
proof -
  from a show ?thesis
  proof cases
    case ev0
  next
    case evSS
    thus ?thesis by auto
  qed
qed


(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Surjections from A to B up to a Permutation on A\<close>

theory Twelvefold_Way_Entry6
imports Twelvefold_Way_Entry4
begin

subsection \<open>Properties for Bijections\<close>

lemma set_mset_eq_implies_surj_on:
  assumes "finite A"
  assumes "size M = card A" "set_mset M = B"
  assumes "f \<in> functions_of A M"
  shows   "f ` A = B"
proof -
  from \<open>f \<in> functions_of A M\<close> have "image_mset f (mset_set A) = M"
    unfolding functions_of_def by auto
  from \<open>image_mset f (mset_set A) = M\<close> show "f ` A = B"
    using \<open>set_mset M = B\<close> \<open>finite A\<close> finite_set_mset_mset_set set_image_mset by force
qed

lemma surj_on_implies_set_mset_eq:
  assumes "finite A"
  assumes "F \<in> (A \<rightarrow>\<^sub>E B) // domain_permutation A B"
  assumes "univ (\<lambda>f. f ` A = B) F"
  shows "set_mset (msubset_of A F) = B"
proof -
  from \<open>F \<in> (A \<rightarrow>\<^sub>E B) // domain_permutation A B\<close> obtain f where "f \<in> A \<rightarrow>\<^sub>E B"
    and F_eq: "F = domain_permutation A B `` {f}" using quotientE by blast
  have "msubset_of A F = univ (\<lambda>f. image_mset f (mset_set A)) F"
    unfolding msubset_of_def ..
  also have "\<dots> = univ (\<lambda>f. image_mset f (mset_set A)) (domain_permutation A B `` {f})"
    unfolding F_eq ..
  also have "\<dots> = image_mset f (mset_set A)"
    using equiv_domain_permutation image_mset_respects_domain_permutation \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>
    by (subst univ_commute') auto
  finally have eq: "msubset_of A F = image_mset f (mset_set A)" .
  from iffD1[OF univ_commute', OF equiv_domain_permutation, OF surjective_respects_domain_permutation, OF \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>]
    \<open>univ (\<lambda>f. f ` A = B) F\<close> have "f ` A = B" by (simp add: F_eq)
  have "set_mset (image_mset f (mset_set A)) = B"
  proof
    show "set_mset (image_mset f (mset_set A)) \<subseteq> B"
      using \<open>finite A\<close> \<open>f ` A = B\<close> by auto
  next
    show "B \<subseteq> set_mset (image_mset f (mset_set A))"
      using \<open>finite A\<close> by (simp add: \<open>f ` A = B\<close>[symmetric] in_image_mset)
  qed
  from this show "set_mset (msubset_of A F) = B"
    unfolding eq .
qed

lemma functions_of_is_surj_on:
  assumes "finite A"
  assumes "size M = card A" "set_mset M = B"
  shows "univ (\<lambda>f. f ` A = B) (functions_of A M)"
proof -
  have "functions_of A M \<in> (A \<rightarrow>\<^sub>E B) // domain_permutation A B"
    using functions_of \<open>finite A\<close> \<open>size M = card A\<close> \<open>set_mset M = B\<close>  by fastforce
  from this obtain f where eq_f: "functions_of A M = domain_permutation A B `` {f}" and "f \<in> A \<rightarrow>\<^sub>E B"
    using quotientE by blast
  from eq_f have "f \<in> functions_of A M"
    using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> equiv_domain_permutation equiv_class_self by fastforce
  have "f ` A = B"
    using \<open>f \<in> functions_of A M\<close> assms set_mset_eq_implies_surj_on by fastforce
  from this show ?thesis
    unfolding eq_f using equiv_domain_permutation surjective_respects_domain_permutation \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>
    by (subst univ_commute') assumption+
qed

subsection \<open>Bijections\<close>

lemma bij_betw_msubset_of:
  assumes "finite A"
  shows "bij_betw (msubset_of A) ({f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_permutation A B)
    {M. set_mset M = B \<and> size M = card A}"
    (is "bij_betw _ ?FSet ?MSet")
proof (rule bij_betw_byWitness[where f'="\<lambda>M. functions_of A M"])
  have quotient_eq: "?FSet = {F \<in> ((A \<rightarrow>\<^sub>E B) // domain_permutation A B). univ (\<lambda>f. f ` A = B) F}"
    using equiv_domain_permutation[of A B] surjective_respects_domain_permutation[of A B]
    by (simp only: univ_preserves_predicate)
  show "\<forall>f\<in>?FSet. functions_of A (msubset_of A f) = f"
    using \<open>finite A\<close> by (auto simp only: quotient_eq functions_of_msubset_of)
  show "\<forall>M\<in>?MSet. msubset_of A (functions_of A M) = M"
    using \<open>finite A\<close> msubset_of_functions_of by blast
  show "msubset_of A ` ?FSet \<subseteq> ?MSet"
    using \<open>finite A\<close> by (auto simp add: quotient_eq surj_on_implies_set_mset_eq msubset_of)
  show "functions_of A ` ?MSet \<subseteq> ?FSet"
    using \<open>finite A\<close> by (auto simp add: quotient_eq intro: functions_of functions_of_is_surj_on)
qed

subsection \<open>Cardinality\<close>

lemma card_surjective_functions_domain_permutation:
  assumes "finite A" "finite B"
  assumes "card B \<le> card A"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_permutation A B) = (card A - 1) choose (card A - card B)"
proof -
  let ?FSet = "{f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_permutation A B"
  and ?MSet = "{M. set_mset M = B \<and> size M = card A}"
  have "bij_betw (msubset_of A) ?FSet ?MSet"
    using \<open>finite A\<close> by (rule bij_betw_msubset_of)
  from this have "card ?FSet = card ?MSet"
    by (rule bij_betw_same_card)
  also have "card ?MSet = (card A - 1) choose (card A - card B)"
    using \<open>finite B\<close> \<open>card B \<le> card A\<close> by (rule card_multisets_covering_set)
  finally show ?thesis .
qed

end


theory ConcreteSemantics10_1_Def_Init_Exp
  imports Main "~~/src/HOL/IMP/Vars"
begin
subsection "Initialization-Sensitive Expressions Evaluation"

type_synonym state = "vname \<Rightarrow> val option"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val option" where
"aval (N i) s = Some i" |
"aval (V x) s = s x" |
"aval (Plus a\<^sub>1 a\<^sub>2) s =
  (case (aval a\<^sub>1 s, aval a\<^sub>2 s) of
     (Some i\<^sub>1,Some i\<^sub>2) \<Rightarrow> Some(i\<^sub>1+i\<^sub>2) | _ \<Rightarrow> None)"

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool option" where
"bval (Bc v) s = Some v" |
"bval (Not b) s = (case bval b s of None \<Rightarrow> None | Some bv \<Rightarrow> Some(\<not> bv))" |
"bval (And b\<^sub>1 b\<^sub>2) s = (case (bval b\<^sub>1 s, bval b\<^sub>2 s) of
  (Some bv\<^sub>1, Some bv\<^sub>2) \<Rightarrow> Some(bv\<^sub>1 & bv\<^sub>2) | _ \<Rightarrow> None)" |
"bval (Less a\<^sub>1 a\<^sub>2) s = (case (aval a\<^sub>1 s, aval a\<^sub>2 s) of
 (Some i\<^sub>1, Some i\<^sub>2) \<Rightarrow> Some(i\<^sub>1 < i\<^sub>2) | _ \<Rightarrow> None)"

(* Lemma 10.1 (Initialized arithmetic expressions). *)
lemma aval_Some: "vars a \<subseteq> dom s \<Longrightarrow> \<exists> i. aval a s = Some i"
  apply(induct a)
  by(auto)

(* Lemma 10.2 (Initialized boolean expressions). *)
lemma bval_Some: "vars b \<subseteq> dom s \<Longrightarrow> \<exists> bv. bval b s = Some bv"
  apply(induct b)
     apply(auto)
  by (metis aval_Some option.simps(5))

end


theory Exponents
imports Main
begin

(* these first few lines just give "my" names to some predefined rules *)
lemma rMulComm: "(a*b ::nat) = (b*a ::nat)"
by (rule Groups.ab_semigroup_mult_class.mult.commute)

lemma rExpMul: "((a^b)^c ::int) = (a^(b*c) ::int)"
by (rule Int.zpower_zpower)

(* and now for the proof: *)
theorem "((a^b)^c ::int) = ((a^c)^b :: int)"
proof -
  have  "(a^b)^c = a^(b*c)" by (simp only: rExpMul)
  hence "   ...  = a^(c*b)" by (simp only: rMulComm)
  thus  "(a^b)^c = (a^c)^b" by (simp only: rExpMul)
qed

end


theory prop_83
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype ('a, 'b) Pair2 = Pair "'a" "'b"
  datatype Nat = Z | S "Nat"
  fun zip2 :: "'a list => 'b list => (('a, 'b) Pair2) list" where
  "zip2 (Nil2) y = Nil2"
  | "zip2 (Cons2 z x2) (Nil2) = Nil2"
  | "zip2 (Cons2 z x2) (Cons2 x3 x4) = Cons2 (Pair z x3) (zip2 x2 x4)"
  fun take :: "Nat => 'a list => 'a list" where
  "take (Z) y = Nil2"
  | "take (S z) (Nil2) = Nil2"
  | "take (S z) (Cons2 x2 x3) = Cons2 x2 (take z x3)"
  fun len :: "'a list => Nat" where
  "len (Nil2) = Z"
  | "len (Cons2 y xs) = S (len xs)"
  fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
  | "drop (S z) (Nil2) = Nil2"
  | "drop (S z) (Cons2 x2 x3) = drop z x3"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster zip2 take len drop append *)

lemma lemma_a [thy_expl]: "prop_83.drop x3 Nil2 = Nil2"
by (hipster_induct_schemes prop_83.drop.simps)

lemma lemma_aa [thy_expl]: "prop_83.drop (S Z) (prop_83.drop x3 y3) = prop_83.drop (S x3) y3"
by (hipster_induct_schemes prop_83.drop.simps)

lemma lemma_ai [thy_expl]: "prop_83.take x3 Nil2 = Nil2"
by (hipster_induct_schemes prop_83.take.simps)

lemma lemma_aj [thy_expl]: "prop_83.take x3 (prop_83.take x3 y3) = prop_83.take x3 y3"
by (hipster_induct_schemes prop_83.take.simps)

lemma lemma_ak [thy_expl]: "prop_83.take (S x3) (prop_83.take x3 y3) = prop_83.take x3 y3"
by (hipster_induct_schemes prop_83.take.simps)

(*hipster append*)
lemma lemma_ab [thy_expl]: "prop_83.append x2 Nil2 = x2"
by (hipster_induct_schemes prop_83.append.simps)

lemma lemma_ac [thy_expl]: "prop_83.append (prop_83.append x2 y2) z2 =
prop_83.append x2 (prop_83.append y2 z2)"
by (hipster_induct_schemes prop_83.append.simps)

lemma lemma_abz [thy_expl]: "zip2 Nil2 x1 = zip2 x1 Nil2"
by (hipster_induct_schemes zip2.simps)

lemma lemma_acz [thy_expl]: "zip2 Nil2 x1 = zip2 y1 Nil2"
by (hipster_induct_schemes zip2.simps)

  theorem x0 :
    "(zip2 (append xs ys) zs) =
       (append (zip2 xs (take (len xs) zs)) (zip2 ys (drop (len xs) zs)))"
       by (hipster_induct_schemes zip2.simps len.simps take.simps drop.simps append.simps)

end