theory Tangle_Algebra
imports Tangles
begin

text{*the following definition is used to construct a block of n vert strands*}
primrec make_vert_block:: "nat \<Rightarrow> block"
where
"make_vert_block 0 = []"
|"make_vert_block (Suc n) = vert#(make_vert_block n)"

lemma domain_make_vert:"domain_block (make_vert_block n) = int n"
   apply(induct_tac n)
   apply(auto)
   done

lemma codomain_make_vert:"codomain_block (make_vert_block n) = int n"
   apply(induct_tac n)
   apply(auto)
   done

(*we defined the tensor of wall as described in the standard tangle algebra*)
fun tensor::"wall => wall => wall" (infixr "\<otimes>" 65)
where
1:"tensor (basic x) (basic y) = (basic (x \<otimes> y))"
|2:"tensor (x*xs) (basic y) = (
                  if (codomain_block y = 0)
                  then (x \<otimes> y)*xs
                   else
                    (x \<otimes> y)
                     *(xs\<otimes>(basic (make_vert_block (nat (codomain_block y))))))"
|3:"tensor (basic x) (y*ys) = (
                  if (codomain_block x = 0)
                   then (x \<otimes> y)*ys
                   else
                    (x \<otimes> y)
                    *((basic (make_vert_block (nat (codomain_block x))))\<otimes> ys))"
|4:"tensor (x*xs) (y*ys) = (x \<otimes> y)* (xs \<otimes> ys)"

lemma Nil_right_tensor:"(basic ([])) \<otimes> xs = xs"
 apply(case_tac xs)
 apply(auto)
 done

text{*The definition of tensors is extended to diagrams by using the
following function*}
definition tensor_Tangle ::"Tangle_Diagram \<Rightarrow> Tangle_Diagram \<Rightarrow> Tangle_Diagram" (infixl "\<otimes>" 65)
where
"tensor_Tangle x y = Abs_Tangle_Diagram ((Rep_Tangle_Diagram x) \<otimes> (Rep_Tangle_Diagram y))"

(*some lemmas*)
lemma "tensor (basic [vert]) (basic ([vert])) = (basic (([vert]) \<otimes> ([vert])))"
by simp

text{*domain_wall of a tensor product of two walls is the sum of
the $domain\_wall$ of each of the tensor
 products*}

lemma tensor_domain_wall_additivity:
 "domain_wall (xs \<otimes> ys) = domain_wall xs + domain_wall ys"
 proof(cases xs)
 fix x
 assume A:"xs = basic x"
 then have "domain_wall (xs \<otimes> ys) = domain_wall xs + domain_wall ys"
   proof(cases ys)
   fix y
   assume B:"ys = basic y"
     have "domain_block (x \<otimes> y) = domain_block x + domain_block y"
       using domain_additive by auto
     then have "domain_wall (xs \<otimes> ys) = domain_wall xs + domain_wall ys"
       using tensor.simps(1) A B by auto
     thus ?thesis by auto
  next
  fix z zs
  assume C:"ys = (z*zs)"
    have "domain_wall (xs \<otimes> ys) = domain_wall xs + domain_wall ys"
     proof(case_tac "(codomain_block x) = 0")
      assume "codomain_block x = 0"
       then have "(xs \<otimes> ys) = (x \<otimes> z)*zs"
          using A C tensor.simps(4) by auto
       then have "domain_wall (xs \<otimes> ys) = domain_block (x \<otimes> z)"
          by auto
       moreover have "domain_wall ys = domain_block z"
          unfolding domain_wall_def C by auto
       moreover have "domain_wall xs = domain_block x"
          unfolding domain_wall_def A by auto
       moreover have "domain_block (x \<otimes> z) = domain_block x + domain_block z"
          using domain_additive by auto
       ultimately show ?thesis by auto
     next
     assume "codomain_block x \<noteq> 0"
     have "(xs \<otimes> ys)
                 = (x \<otimes> z)
                    *((basic (make_vert_block (nat (codomain_block x))))\<otimes> zs)"
          using tensor.simps(3) A C `codomain_block x \<noteq> 0`  by auto
     then have "domain_wall (xs \<otimes> ys) = domain_block (x \<otimes> z)"
          by auto
        moreover have "domain_wall ys = domain_block z"
          unfolding domain_wall_def C by auto
       moreover have "domain_wall xs = domain_block x"
          unfolding domain_wall_def A by auto
       moreover have "domain_block (x \<otimes> z) = domain_block x + domain_block z"
          using domain_additive by auto
       ultimately show ?thesis by auto
      qed
      then show ?thesis by auto
   qed
 then show ?thesis by auto
 next
 fix z zs
 assume D:"xs = z * zs"
 then have "domain_wall (xs \<otimes> ys) = domain_wall xs + domain_wall ys"
    proof(cases ys)
     fix y
     assume E:"ys = basic y"
     then have "domain_wall (xs \<otimes> ys) = domain_wall xs + domain_wall ys"
         proof(cases "codomain_block y = 0")
         assume "codomain_block y = 0"
         have "(xs \<otimes> ys) = (z \<otimes> y)*zs"
            using tensor.simps(2)  D E `codomain_block y = 0` by auto
       then have "domain_wall (xs \<otimes> ys) = domain_block (z \<otimes> y)"
          by auto
       moreover have "domain_wall xs = domain_block z"
          unfolding domain_wall_def D by auto
       moreover have "domain_wall ys = domain_block y"
          unfolding domain_wall_def E by auto
       moreover have "domain_block (z \<otimes> y) = domain_block z + domain_block y"
          using domain_additive by auto
       ultimately show ?thesis by auto
     next
     assume "codomain_block y \<noteq> 0"
     have "(xs \<otimes> ys)
               =
                (z \<otimes> y)
                  *(zs\<otimes>(basic (make_vert_block (nat (codomain_block y)))))"
          using tensor.simps(3) D E `codomain_block y \<noteq> 0`  by auto
     then have "domain_wall (xs \<otimes> ys) = domain_block (z \<otimes> y)"
          by auto
        moreover have "domain_wall ys = domain_block y"
          unfolding domain_wall_def E by auto
       moreover have "domain_wall xs = domain_block z"
          unfolding domain_wall_def D by auto
       moreover have "domain_block (z \<otimes> y) = domain_block z + domain_block y"
          using domain_additive by auto
       ultimately show ?thesis by auto
      qed
      then show ?thesis by auto
     next
     fix w ws
     assume F:"ys = w*ws"
     have "(xs \<otimes> ys) = (z \<otimes> w) * (zs \<otimes> ws)"
          using D F by auto
     then have "domain_wall (xs \<otimes> ys) = domain_block (z \<otimes> w)"
          by auto
     moreover have "domain_wall ys = domain_block w"
          unfolding domain_wall_def F by auto
    moreover have "domain_wall xs = domain_block z"
          unfolding domain_wall_def D by auto
    moreover have "domain_block (z \<otimes> w) = domain_block z + domain_block w"
          using domain_additive by auto
    ultimately show ?thesis by auto
    qed
    then show ?thesis by auto
  qed

text{*codomain of tensor of two walls is the sum of the respective
codomain's is shown by the following theorem*}

lemma tensor_codomain_wall_additivity:
 "codomain_wall (xs \<otimes> ys) = codomain_wall xs + codomain_wall ys"
 proof(induction xs ys  rule:tensor.induct)
  fix xs ys
  let ?case = "(codomain_wall ((basic xs) \<otimes> (basic ys))
                       = (codomain_wall (basic (xs)))
                              + (codomain_wall (basic ys)))"
  show ?case using codomain_wall.simps codomain_block.simps tensor.simps
                     by (metis codomain_additive)
 next
  fix x xs y
    assume case_2:
         "codomain_block y \<noteq> 0
           \<Longrightarrow> codomain_wall
                (xs \<otimes> basic (make_vert_block (nat (codomain_block y))))
                  = codomain_wall xs
                     + codomain_wall
                          (basic (make_vert_block (nat (codomain_block y))))"

  let ?case = "codomain_wall ((x*xs)\<otimes> (basic y))
                  = (codomain_wall (x*xs)) + (codomain_wall (basic y))"
  show ?case
     proof(cases "(codomain_block y = 0)")
     case True
       have "((x*xs)\<otimes> (basic y)) =  (x \<otimes> y)*xs "
                using "Tangle_Algebra.2" True by auto
       then have "codomain_wall ((x*xs)\<otimes> (basic y))
                                = codomain_wall ((x \<otimes> y)*xs)"
                         by auto
       then have "... = codomain_wall xs"
                       using codomain_wall.simps by auto
       then have "... = codomain_wall xs + codomain_wall (basic y)"
                   using True codomain_wall.simps(1) by auto
      then show ?thesis by auto
    next
    case False
      have "(x*xs) \<otimes> (basic y)
                 = (x \<otimes> y)
                     *(xs\<otimes>(basic (make_vert_block (nat (codomain_block y)))))"
                using False by (metis "Tangle_Algebra.2")
      moreover then have "codomain_wall ((x*xs) \<otimes> (basic y))
                      = codomain_wall(...)"
               by auto
      moreover have "...
                  = codomain_wall
                      (xs\<otimes>(basic (make_vert_block (nat (codomain_block y)))))"
                      using domain_wall.simps by auto
      moreover have "...
                  = codomain_wall xs
                     + codomain_wall
                          (basic (make_vert_block (nat (codomain_block y))))"
                 using case_2 False by auto
      moreover have "... = codomain_wall (x*xs)
                       + codomain_block y"
                   using codomain_wall.simps
                by (metis codomain_block_nonnegative
                   codomain_make_vert int_nat_eq)
      moreover have "... = codomain_wall (x*xs) + codomain_wall (basic y)"
                  using codomain_wall.simps(1) by auto
      ultimately show ?thesis by auto
    qed
  next
  fix x y ys
  assume case_3:"(codomain_block x \<noteq> 0 \<Longrightarrow>
        codomain_wall
             (basic (make_vert_block (nat (codomain_block x))) \<otimes> ys)
            = codomain_wall
               (basic (make_vert_block (nat (codomain_block x))))
                  + codomain_wall ys)"
  let ?case = "codomain_wall ((basic x) \<otimes> (y*ys))
                  = codomain_wall (basic x) + codomain_wall (y*ys)"
  show ?case
       proof(cases "codomain_block x = 0")
       case True
         have "(basic x)\<otimes>(y*ys) = (x \<otimes> y)*ys"
                using True 3 by auto
         then have "codomain_wall (...) = codomain_wall (...)"
                    by auto
         then have "... = codomain_wall ys"
                     by auto
         then have "... = codomain_wall ys + codomain_wall (basic x)"
                      using codomain_wall.simps(1) True by auto
         then show ?thesis by auto
       next
       case False
        have "(basic x) \<otimes> (y*ys)
                 = (x \<otimes> y)
                    *((basic (make_vert_block (nat (codomain_block x))))\<otimes> ys)"
               using False 3 by auto
        then have "codomain_wall (...) = codomain_wall (...)"
               by auto
        then have "...
                 = codomain_wall
                     ((basic (make_vert_block (nat (codomain_block x))))\<otimes> ys)"
               using codomain_wall.simps(2) by auto
        then have "... = codomain_block x + codomain_wall ys"
               using codomain_wall.simps case_3 False
               codomain_block_nonnegative codomain_make_vert int_nat_eq
               by auto
        then have "... = codomain_wall (basic x) + codomain_wall (y*ys)"
              using codomain_wall.simps by auto
        then show ?thesis by (metis `basic x \<otimes> y * ys = (x \<otimes> y) * (basic (make_vert_block (nat (codomain_block x))) \<otimes> ys)` `codomain_wall ((x \<otimes> y) * (basic (make_vert_block (nat (codomain_block x))) \<otimes> ys)) = codomain_wall (basic (make_vert_block (nat (codomain_block x))) \<otimes> ys)` `codomain_wall (basic (make_vert_block (nat (codomain_block x))) \<otimes> ys) = codomain_block x + codomain_wall ys`)
      qed
  next
   fix x xs y ys
   assume case_4:"codomain_wall (xs \<otimes> ys) = codomain_wall xs + codomain_wall ys "
   let ?case = "codomain_wall ((x*xs) \<otimes> (y*ys)) = codomain_wall (x*xs) + codomain_wall (y*ys)"
   have " ((x*xs) \<otimes> (y*ys)) = (x \<otimes> y)*(xs \<otimes> ys)"
           using 4 by auto
   then have "codomain_wall (...) = codomain_wall (...)"
         by auto
   then have "... = codomain_wall (xs \<otimes> ys)"
         using codomain_wall.simps(2) by auto
   then have "... = codomain_wall xs + codomain_wall ys"
         using case_4 by auto
   then have "... = codomain_wall (x*xs) + (codomain_wall (y*ys))"
         using codomain_wall.simps(2) by auto
   then show ?case by (metis `codomain_wall ((x \<otimes> y) * (xs \<otimes> ys)) = codomain_wall (xs \<otimes> ys)` `x * xs \<otimes> y * ys = (x \<otimes> y) * (xs \<otimes> ys)` case_4)
qed

(*the following theorem tells us that
given a tensor product of a tangle diagram with a block consisting of
only vertical strands, it gives a tangle diagram*)
theorem is_tangle_make_vert_right:
 "(is_tangle_diagram xs)
          \<Longrightarrow> is_tangle_diagram (xs \<otimes> (basic (make_vert_block n)))"
proof(induct xs)
 case (basic xs)
  show ?case using tensor_def by auto
 next
 case (prod x xs)
  have ?case
   proof(cases n)
    case 0
     have
        "codomain_block (x \<otimes> (make_vert_block 0))
               = (codomain_block x) + codomain_block(make_vert_block 0)"
            using  codomain_additive by auto
     moreover have "codomain_block (make_vert_block 0) = 0"
            by auto
     ultimately have "codomain_block (x \<otimes> (make_vert_block 0)) = codomain_block (x)"
            by auto
     moreover have "is_tangle_diagram xs"
          using prod.prems by (metis is_tangle_diagram.simps(2))
     then have "is_tangle_diagram ((x \<otimes> (make_vert_block 0))*xs)"
          using is_tangle_diagram.simps(2) by (metis calculation prod.prems)
     then  have "is_tangle_diagram ((x*xs) \<otimes> (basic (make_vert_block 0)))"
          by auto
     then show ?thesis using  "0" by (metis)
    next
    case (Suc k)
     have "codomain_block (make_vert_block (k+1)) = int (k+1)"
         using codomain_make_vert  by auto
     then have "(nat (codomain_block (make_vert_block (k+1)))) = k+1"
         by auto
     then have "make_vert_block (nat (codomain_block (make_vert_block (k+1))))
                             = make_vert_block (k+1)"
          by auto
     moreover have "codomain_wall (basic (make_vert_block (k+1)))>0"
       using make_vert_block.simps codomain_wall.simps  Suc_eq_plus1
       codomain_make_vert of_nat_0_less_iff zero_less_Suc
       by metis
     ultimately have 1: "(x*xs) \<otimes> (basic (make_vert_block (k+1)))
             =  (x\<otimes>(make_vert_block (k+1)))*(xs\<otimes>(basic (make_vert_block (k+1))))"
        using tensor.simps(2)  by (metis codomain_wall.simps(1) int_0 of_nat_less_0_iff)
     have "domain_wall (xs\<otimes>(basic (make_vert_block (k+1))))
                 = domain_wall xs + domain_wall (basic (make_vert_block (k+1)))"
            using tensor_domain_wall_additivity by auto
     then have 2:
          "domain_wall (xs\<otimes>(basic (make_vert_block (k+1))))
                  = (domain_wall xs) + int (k+1)"
             using domain_make_vert domain_wall.simps(1) by auto
     moreover have 3: "codomain_block (x \<otimes> (make_vert_block (k+1)))
                 = codomain_block x + int (k+1)"
             using  codomain_additive codomain_make_vert by (metis)
     have "is_tangle_diagram (x*xs)"
            using prod.prems by auto
     then have 4:"codomain_block x = domain_wall xs"
            using is_tangle_diagram.simps(2) by metis
     from 2 3 4 have
       "domain_wall (xs\<otimes>(basic (make_vert_block (k+1))))
               = codomain_block (x \<otimes> (make_vert_block (k+1))) "
            by auto
     moreover have "is_tangle_diagram (xs\<otimes>(basic (make_vert_block (k+1))))"
            using prod.hyps prod.prems by (metis Suc Suc_eq_plus1 is_tangle_diagram.simps(2))
     ultimately have "is_tangle_diagram ((x*xs) \<otimes> (basic (make_vert_block (k+1))))"
                using 1 by auto
      then show ?thesis using  Suc Suc_eq_plus1 by metis
    qed
   then show ?case by auto
 qed

(*the following theorem tells us that given a tensor product of a vertical strand block with a
tangle diagram, it gives a tangle diagram. If the above result can be treated as right product,
this can be treated as the left product*)

theorem is_tangle_make_vert_left:
 "(is_tangle_diagram xs) \<Longrightarrow> is_tangle_diagram ((basic (make_vert_block n)) \<otimes> xs)"
proof(induct xs)
 case (basic xs)
  show ?case using tensor_def by auto
 next
 case (prod x xs)
  have ?case
   proof(cases n)
    case 0
     have
        "codomain_block ( (make_vert_block 0) \<otimes> x)
               = (codomain_block x) + codomain_block(make_vert_block 0)"
            using  codomain_additive by auto
     moreover have "codomain_block (make_vert_block 0) = 0"
            by auto
     ultimately have "codomain_block ( (make_vert_block 0) \<otimes> x) = codomain_block (x)"
            by auto
     moreover have "is_tangle_diagram xs"
          using prod.prems by (metis is_tangle_diagram.simps(2))
     then have "is_tangle_diagram (( (make_vert_block 0) \<otimes> x)*xs)"
          using is_tangle_diagram.simps(2) by (metis calculation prod.prems)
     then  have "is_tangle_diagram ((basic (make_vert_block 0)) \<otimes> (x*xs) )"
          by auto
     then show ?thesis using  "0" by (metis)
    next
    case (Suc k)
     have "codomain_block (make_vert_block (k+1)) = int (k+1)"
         using codomain_make_vert  by auto
     then have "(nat (codomain_block (make_vert_block (k+1)))) = k+1"
         by auto
     then have "make_vert_block (nat (codomain_block (make_vert_block (k+1))))
                             = make_vert_block (k+1)"
          by auto
     moreover have "codomain_wall (basic (make_vert_block (k+1)))>0"
       using make_vert_block.simps codomain_wall.simps  Suc_eq_plus1
       codomain_make_vert of_nat_0_less_iff zero_less_Suc
       by metis
     ultimately have 1: "  (basic (make_vert_block (k+1))) \<otimes> (x*xs)
             =  ((make_vert_block (k+1)) \<otimes> x)*((basic (make_vert_block (k+1))) \<otimes> xs)"
        using tensor.simps(3)  by (metis codomain_wall.simps(1) int_0 of_nat_less_0_iff)
     have "domain_wall ((basic (make_vert_block (k+1))) \<otimes> xs)
                 = domain_wall xs + domain_wall (basic (make_vert_block (k+1)))"
            using tensor_domain_wall_additivity by auto
     then have 2:
          "domain_wall ((basic (make_vert_block (k+1))) \<otimes> xs)
                  = (domain_wall xs) + int (k+1)"
             using domain_make_vert domain_wall.simps(1) by auto
     moreover have 3: "codomain_block ( (make_vert_block (k+1)) \<otimes> x)
                 = codomain_block x + int (k+1)"
             using  codomain_additive codomain_make_vert
              comm_semiring_1_class.normalizing_semiring_rules(24)
             by metis
     have "is_tangle_diagram (x*xs)"
            using prod.prems by auto
     then have 4:"codomain_block x = domain_wall xs"
            using is_tangle_diagram.simps(2) by metis
     from 2 3 4 have
       "domain_wall ((basic (make_vert_block (k+1))) \<otimes> xs)
               = codomain_block ((make_vert_block (k+1)) \<otimes> x)"
             by auto
     moreover have "is_tangle_diagram ((basic (make_vert_block (k+1))) \<otimes> xs)"
            using prod.hyps prod.prems by (metis Suc Suc_eq_plus1 is_tangle_diagram.simps(2))
     ultimately have "is_tangle_diagram ((basic (make_vert_block (k+1))) \<otimes> (x*xs))"
                using 1 by auto
      then show ?thesis using  Suc Suc_eq_plus1 by metis
    qed
   then show ?case by auto
 qed

(*We prove that tensor product of two tangle diagrams is a tangle diagram .
The following lemmas are used in the process of proving each of the
inductive cases*)
lemma simp1: "(codomain_block y) \<noteq> 0 \<Longrightarrow>
       is_tangle_diagram (xs)
\<and> is_tangle_diagram ((basic (make_vert_block (nat (codomain_block y))))) \<longrightarrow>
               is_tangle_diagram (xs \<otimes>  ((basic (make_vert_block (nat (codomain_block y)))))) \<Longrightarrow>
(is_tangle_diagram (x * xs) \<and> is_tangle_diagram (basic y) \<longrightarrow> is_tangle_diagram (x * xs \<otimes> basic y))
"
  proof-
  assume A: "(codomain_block y) \<noteq> 0"
  assume B: " is_tangle_diagram (xs)
\<and> is_tangle_diagram ((basic (make_vert_block (nat (codomain_block y))))) \<longrightarrow>
               is_tangle_diagram (xs \<otimes>  ((basic (make_vert_block (nat (codomain_block y))))))"
  have " is_tangle_diagram (x * xs) \<and> is_tangle_diagram (basic y) \<longrightarrow> is_tangle_diagram xs"
        by (metis is_tangle_diagram.simps(2))
  moreover have "(is_tangle_diagram (basic (make_vert_block (nat (codomain_block y))))) "
              using is_tangle_diagram.simps(1) by auto
  ultimately have
      " ((is_tangle_diagram xs)
               \<and>(is_tangle_diagram (basic (make_vert_block (nat (codomain_block y)))))
    \<longrightarrow> is_tangle_diagram (xs \<otimes> basic (make_vert_block (nat (codomain_block y)))))
\<Longrightarrow>
is_tangle_diagram (x * xs) \<and> is_tangle_diagram (basic y) \<longrightarrow>
                is_tangle_diagram (xs \<otimes> basic (make_vert_block (nat (codomain_block y))))"
          by metis
  moreover have 1:"codomain_block y = domain_wall (basic (make_vert_block (nat (codomain_block y))))"
        using codomain_block_nonnegative domain_make_vert domain_wall.simps(1) int_nat_eq by auto
  moreover have 2:"is_tangle_diagram (x * xs) \<and> is_tangle_diagram (basic y) \<longrightarrow>
                 codomain_block x = domain_wall xs"
       using is_tangle_diagram.simps(2) by metis
 moreover have "codomain_block (x \<otimes> y) = codomain_block x +codomain_block y"
       using codomain_additive by auto
 moreover have "domain_wall (xs \<otimes> (basic (make_vert_block (nat (codomain_block y)))))
                 = domain_wall xs + domain_wall (basic (make_vert_block (nat (codomain_block y))))"
          using tensor_domain_wall_additivity by auto
 moreover then have " is_tangle_diagram (x * xs) \<and> is_tangle_diagram (basic y) \<longrightarrow>
          domain_wall (xs \<otimes> (basic (make_vert_block (nat (codomain_block y)))))
                   = codomain_block (x \<otimes> y)"
             by (metis "1" "2" calculation(4))
 ultimately have
      "(is_tangle_diagram xs)
               \<and>(is_tangle_diagram (basic (make_vert_block (nat (codomain_block y)))))
    \<longrightarrow> is_tangle_diagram (xs \<otimes> basic (make_vert_block (nat (codomain_block y))))
\<Longrightarrow>
         is_tangle_diagram (x * xs) \<and> is_tangle_diagram (basic y) \<longrightarrow>
         is_tangle_diagram ((x \<otimes> y)* (xs \<otimes> (basic (make_vert_block (nat (codomain_block y))))))"
          using is_tangle_diagram.simps(2)  by auto
 then have "
       is_tangle_diagram (x * xs) \<and> is_tangle_diagram (basic y) \<longrightarrow>
               is_tangle_diagram ((x*xs) \<otimes> (basic y))"
              by (metis "Tangle_Algebra.2" `codomain_block y \<noteq> 0` is_tangle_make_vert_right)
 then show ?thesis by auto
 qed

lemma simp2: "(codomain_block x) \<noteq> 0 \<Longrightarrow>
       is_tangle_diagram  (basic (make_vert_block (nat (codomain_block x))))
\<and> is_tangle_diagram (ys) \<longrightarrow>
               is_tangle_diagram ((basic (make_vert_block (nat (codomain_block x)))) \<otimes> ys) \<Longrightarrow>
(is_tangle_diagram (basic x) \<and> is_tangle_diagram (y*ys) \<longrightarrow> is_tangle_diagram ((basic x) \<otimes> (y*ys)))
"
  proof-
  assume A: "(codomain_block x) \<noteq> 0"
  assume B: "is_tangle_diagram  (basic (make_vert_block (nat (codomain_block x))))
\<and> is_tangle_diagram (ys) \<longrightarrow>
               is_tangle_diagram ((basic (make_vert_block (nat (codomain_block x)))) \<otimes> ys)"
  have " is_tangle_diagram (basic x) \<and> is_tangle_diagram (y*ys) \<longrightarrow> is_tangle_diagram ys"
        by (metis is_tangle_diagram.simps(2))
  moreover have "(is_tangle_diagram (basic (make_vert_block (nat (codomain_block x))))) "
              using is_tangle_diagram.simps(1) by auto
  ultimately have
      " ((is_tangle_diagram ys)
               \<and>(is_tangle_diagram (basic (make_vert_block (nat (codomain_block x)))))
    \<longrightarrow> is_tangle_diagram ((basic (make_vert_block (nat (codomain_block x)))) \<otimes> ys))
    \<Longrightarrow>
     is_tangle_diagram (basic x) \<and> is_tangle_diagram (y*ys) \<longrightarrow>
                is_tangle_diagram (( basic (make_vert_block (nat (codomain_block x)))) \<otimes> ys)"
          by metis
  moreover have 1:"codomain_block x = domain_wall (basic (make_vert_block (nat (codomain_block x))))"
        using codomain_block_nonnegative domain_make_vert domain_wall.simps(1) int_nat_eq by auto
  moreover have 2:"is_tangle_diagram (basic x) \<and> is_tangle_diagram (y*ys) \<longrightarrow>
                 codomain_block y = domain_wall ys"
       using is_tangle_diagram.simps(2) by metis
 moreover have "codomain_block (x \<otimes> y) = codomain_block x +codomain_block y"
       using codomain_additive by auto
 moreover have "domain_wall ((basic (make_vert_block (nat (codomain_block x)))) \<otimes> ys)
                 = domain_wall (basic (make_vert_block (nat (codomain_block x)))) + domain_wall ys"
          using tensor_domain_wall_additivity by auto
 moreover then have " is_tangle_diagram (basic x) \<and> is_tangle_diagram (y*ys) \<longrightarrow>
          domain_wall ((basic (make_vert_block (nat (codomain_block x)))) \<otimes> ys)
                   = codomain_block (x \<otimes> y)"
             by (metis "1" "2" calculation(4))
 ultimately have
      "(is_tangle_diagram ys)
               \<and>(is_tangle_diagram (basic (make_vert_block (nat (codomain_block x)))))
    \<longrightarrow> is_tangle_diagram ((basic (make_vert_block (nat (codomain_block x))))\<otimes> ys)
        \<Longrightarrow>
         is_tangle_diagram (basic x) \<and> is_tangle_diagram (y*ys) \<longrightarrow>
         is_tangle_diagram ((x \<otimes> y)* ((basic (make_vert_block (nat (codomain_block x)))) \<otimes> ys))"
          using is_tangle_diagram.simps(2)  by auto
 then have "
       is_tangle_diagram (basic x) \<and> is_tangle_diagram (y*ys) \<longrightarrow>
               is_tangle_diagram ((basic x) \<otimes> (y*ys))"
                       by (metis "Tangle_Algebra.3" A B)
 then show ?thesis by auto
 qed

lemma simp3:
 "is_tangle_diagram xs \<and> is_tangle_diagram ys \<longrightarrow> is_tangle_diagram (xs \<otimes> ys)
                                         \<Longrightarrow>
 is_tangle_diagram (x * xs) \<and> is_tangle_diagram (y * ys) \<longrightarrow> is_tangle_diagram (x * xs \<otimes> y * ys)"
proof-
 assume A: "is_tangle_diagram xs \<and> is_tangle_diagram ys \<longrightarrow> is_tangle_diagram (xs \<otimes> ys)"
 have "is_tangle_diagram (x*xs) \<longrightarrow> (codomain_block x = domain_wall xs)"
       using is_tangle_diagram.simps(2) by auto
 moreover have "is_tangle_diagram (y*ys) \<longrightarrow> (codomain_block y = domain_wall ys)"
       using is_tangle_diagram.simps(2) by auto
 ultimately have "is_tangle_diagram (x*xs)\<and> is_tangle_diagram (y*ys)
              \<longrightarrow> codomain_block (x \<otimes> y) = domain_wall (xs \<otimes> ys)"
         using codomain_additive tensor_domain_wall_additivity by auto
 moreover have "is_tangle_diagram (x*xs)\<and> is_tangle_diagram (y*ys)
              \<longrightarrow> is_tangle_diagram (xs \<otimes> ys)"
          using A is_tangle_diagram.simps(2) by auto
 moreover  have "(x*xs) \<otimes> (y*ys) = (x \<otimes> y)*(xs \<otimes> ys)"
      using tensor.simps(4) by auto
 ultimately have "is_tangle_diagram (x*xs)\<and> is_tangle_diagram (y*ys)
              \<longrightarrow> is_tangle_diagram ((x*xs) \<otimes> (y*ys))"
          by auto
 then show ?thesis by simp
 qed

(*tensor product of two tangle diagrams is a tangle diagram*)
theorem is_tangle_diagramness:
 shows"(is_tangle_diagram x)\<and>(is_tangle_diagram y) \<longrightarrow>is_tangle_diagram (tensor x y)"
proof(induction x y  rule:tensor.induct)
 fix z w
 let ?case = "(is_tangle_diagram (basic z))\<and>(is_tangle_diagram (basic w))
                  \<longrightarrow>is_tangle_diagram ((basic z) \<otimes> (basic w))"
  show ?case by auto
 next
  fix x xs y
  let ?case = "(is_tangle_diagram (x*xs))\<and>(is_tangle_diagram (basic y))
                  \<longrightarrow>is_tangle_diagram ((x*xs) \<otimes> (basic y))"
  from simp1 show ?case
       by (metis
       "Tangle_Algebra.2"
        codomain_additive
       comm_semiring_1_class.normalizing_semiring_rules(24)
       comm_semiring_1_class.normalizing_semiring_rules(5) is_tangle_diagram.simps(2)
       is_tangle_make_vert_right)
 next
   fix x y ys
   let ?case = "(is_tangle_diagram (basic x))\<and>(is_tangle_diagram (y*ys))
                  \<longrightarrow>is_tangle_diagram ((basic x) \<otimes> (y*ys))"
   from simp2 show ?case by (metis "Tangle_Algebra.3"
                      codomain_additive comm_monoid_add_class.add.left_neutral
                     is_tangle_diagram.simps(2) is_tangle_make_vert_left)
 next
    fix x y xs ys
    assume A:"  is_tangle_diagram xs \<and> is_tangle_diagram ys \<longrightarrow> is_tangle_diagram (xs \<otimes> ys)"
    let ?case =
    "is_tangle_diagram (x * xs) \<and> is_tangle_diagram (y * ys) \<longrightarrow> is_tangle_diagram (x * xs \<otimes> y * ys)"
   from simp3 show ?case using A by auto
 qed

theorem tensor_preserves_is_tangle:
 assumes "is_tangle_diagram x"
     and "is_tangle_diagram y"
 shows "is_tangle_diagram (x \<otimes> y)"
  using assms  is_tangle_diagramness by auto

definition Tensor_Tangle::"Tangle_Diagram \<Rightarrow> Tangle_Diagram \<Rightarrow> Tangle_Diagram" (infixl "\<circ>" 65)
 where
"Tensor_Tangle x y =
     Abs_Tangle_Diagram ((Rep_Tangle_Diagram x) \<otimes> (Rep_Tangle_Diagram y))"

theorem well_defined_compose:
 assumes "is_tangle_diagram x"
     and "is_tangle_diagram y"
 shows "(Abs_Tangle_Diagram x) \<otimes> (Abs_Tangle_Diagram y) = (Abs_Tangle_Diagram (x \<otimes> y))"
     using  Abs_Tangle_Diagram_inverse assms(1) assms(2)
      mem_Collect_eq tensor_preserves_is_tangle
     tensor_Tangle_def
     by auto

end


(*  Title:      FOL/ex/Intuitionistic.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section \<open>Intuitionistic First-Order Logic\<close>

theory Intuitionistic
imports IFOL
begin

(*
Single-step ML commands:
by (IntPr.step_tac 1)
by (biresolve_tac safe_brls 1);
by (biresolve_tac haz_brls 1);
by (assume_tac 1);
by (IntPr.safe_tac 1);
by (IntPr.mp_tac 1);
by (IntPr.fast_tac @{context} 1);
*)

text\<open>Metatheorem (for \emph{propositional} formulae):
  $P$ is classically provable iff $\neg\neg P$ is intuitionistically provable.
  Therefore $\neg P$ is classically provable iff it is intuitionistically
  provable.

Proof: Let $Q$ be the conjunction of the propositions $A\vee\neg A$, one for
each atom $A$ in $P$.  Now $\neg\neg Q$ is intuitionistically provable because
$\neg\neg(A\vee\neg A)$ is and because double-negation distributes over
conjunction.  If $P$ is provable classically, then clearly $Q\rightarrow P$ is
provable intuitionistically, so $\neg\neg(Q\rightarrow P)$ is also provable
intuitionistically.  The latter is intuitionistically equivalent to $\neg\neg
Q\rightarrow\neg\neg P$, hence to $\neg\neg P$, since $\neg\neg Q$ is
intuitionistically provable.  Finally, if $P$ is a negation then $\neg\neg P$
is intuitionstically equivalent to $P$.  [Andy Pitts]\<close>

lemma \<open>\<not> \<not> (P \<and> Q) \<longleftrightarrow> \<not> \<not> P \<and> \<not> \<not> Q\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

lemma \<open>\<not> \<not> ((\<not> P \<longrightarrow> Q) \<longrightarrow> (\<not> P \<longrightarrow> \<not> Q) \<longrightarrow> P)\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text \<open>Double-negation does NOT distribute over disjunction.\<close>

lemma \<open>\<not> \<not> (P \<longrightarrow> Q) \<longleftrightarrow> (\<not> \<not> P \<longrightarrow> \<not> \<not> Q)\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

lemma \<open>\<not> \<not> \<not> P \<longleftrightarrow> \<not> P\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

lemma \<open>\<not> \<not> ((P \<longrightarrow> Q \<or> R) \<longrightarrow> (P \<longrightarrow> Q) \<or> (P \<longrightarrow> R))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

lemma \<open>(P \<longleftrightarrow> Q) \<longleftrightarrow> (Q \<longleftrightarrow> P)\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

lemma \<open>((P \<longrightarrow> (Q \<or> (Q \<longrightarrow> R))) \<longrightarrow> R) \<longrightarrow> R\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

lemma
  \<open>(((G \<longrightarrow> A) \<longrightarrow> J) \<longrightarrow> D \<longrightarrow> E) \<longrightarrow> (((H \<longrightarrow> B) \<longrightarrow> I) \<longrightarrow> C \<longrightarrow> J)
    \<longrightarrow> (A \<longrightarrow> H) \<longrightarrow> F \<longrightarrow> G \<longrightarrow> (((C \<longrightarrow> B) \<longrightarrow> I) \<longrightarrow> D) \<longrightarrow> (A \<longrightarrow> C)
    \<longrightarrow> (((F \<longrightarrow> A) \<longrightarrow> B) \<longrightarrow> I) \<longrightarrow> E\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text \<open>Admissibility of the excluded middle for negated formulae\<close>
lemma \<open>(P \<or> \<not>P \<longrightarrow> \<not>Q) \<longrightarrow> \<not>Q\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text \<open>The same in a more general form, no ex falso quodlibet\<close>
lemma \<open>(P \<or> (P\<longrightarrow>R) \<longrightarrow> Q \<longrightarrow> R) \<longrightarrow> Q \<longrightarrow> R\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

subsection \<open>Lemmas for the propositional double-negation translation\<close>

lemma \<open>P \<longrightarrow> \<not> \<not> P\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

lemma \<open>\<not> \<not> (\<not> \<not> P \<longrightarrow> P)\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

lemma \<open>\<not> \<not> P \<and> \<not> \<not> (P \<longrightarrow> Q) \<longrightarrow> \<not> \<not> Q\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text \<open>The following are classically but not constructively valid.
  The attempt to prove them terminates quickly!\<close>
lemma \<open>((P \<longrightarrow> Q) \<longrightarrow> P) \<longrightarrow> P\<close>
apply (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)?
apply (rule asm_rl) \<comment> \<open>Checks that subgoals remain: proof failed.\<close>
oops

lemma \<open>(P \<and> Q \<longrightarrow> R) \<longrightarrow> (P \<longrightarrow> R) \<or> (Q \<longrightarrow> R)\<close>
apply (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)?
apply (rule asm_rl) \<comment> \<open>Checks that subgoals remain: proof failed.\<close>
oops

subsection \<open>de Bruijn formulae\<close>

text \<open>de Bruijn formula with three predicates\<close>
lemma
  \<open>((P \<longleftrightarrow> Q) \<longrightarrow> P \<and> Q \<and> R) \<and>
    ((Q \<longleftrightarrow> R) \<longrightarrow> P \<and> Q \<and> R) \<and>
    ((R \<longleftrightarrow> P) \<longrightarrow> P \<and> Q \<and> R) \<longrightarrow> P \<and> Q \<and> R\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text \<open>de Bruijn formula with five predicates\<close>
lemma
  \<open>((P \<longleftrightarrow> Q) \<longrightarrow> P \<and> Q \<and> R \<and> S \<and> T) \<and>
    ((Q \<longleftrightarrow> R) \<longrightarrow> P \<and> Q \<and> R \<and> S \<and> T) \<and>
    ((R \<longleftrightarrow> S) \<longrightarrow> P \<and> Q \<and> R \<and> S \<and> T) \<and>
    ((S \<longleftrightarrow> T) \<longrightarrow> P \<and> Q \<and> R \<and> S \<and> T) \<and>
    ((T \<longleftrightarrow> P) \<longrightarrow> P \<and> Q \<and> R \<and> S \<and> T) \<longrightarrow> P \<and> Q \<and> R \<and> S \<and> T\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text \<open>
  Problems from of Sahlin, Franzen and Haridi,
  An Intuitionistic Predicate Logic Theorem Prover.
  J. Logic and Comp. 2 (5), October 1992, 619-656.
\<close>

text\<open>Problem 1.1\<close>
lemma
  \<open>(\<forall>x. \<exists>y. \<forall>z. p(x) \<and> q(y) \<and> r(z)) \<longleftrightarrow>
    (\<forall>z. \<exists>y. \<forall>x. p(x) \<and> q(y) \<and> r(z))\<close>
  by (tactic \<open>IntPr.best_dup_tac \<^context> 1\<close>)  \<comment> \<open>SLOW\<close>

text\<open>Problem 3.1\<close>
lemma \<open>\<not> (\<exists>x. \<forall>y. mem(y,x) \<longleftrightarrow> \<not> mem(x,x))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>Problem 4.1: hopeless!\<close>
lemma
  \<open>(\<forall>x. p(x) \<longrightarrow> p(h(x)) \<or> p(g(x))) \<and> (\<exists>x. p(x)) \<and> (\<forall>x. \<not> p(h(x)))
    \<longrightarrow> (\<exists>x. p(g(g(g(g(g(x)))))))\<close>
  oops

subsection \<open>Intuitionistic FOL: propositional problems based on Pelletier.\<close>

text\<open>\<open>\<not>\<not>\<close>1\<close>
lemma \<open>\<not> \<not> ((P \<longrightarrow> Q) \<longleftrightarrow> (\<not> Q \<longrightarrow> \<not> P))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>\<open>\<not>\<not>\<close>2\<close>
lemma \<open>\<not> \<not> (\<not> \<not> P \<longleftrightarrow> P)\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>3\<close>
lemma \<open>\<not> (P \<longrightarrow> Q) \<longrightarrow> (Q \<longrightarrow> P)\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>\<open>\<not>\<not>\<close>4\<close>
lemma \<open>\<not> \<not> ((\<not> P \<longrightarrow> Q) \<longleftrightarrow> (\<not> Q \<longrightarrow> P))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>\<open>\<not>\<not>\<close>5\<close>
lemma \<open>\<not> \<not> ((P \<or> Q \<longrightarrow> P \<or> R) \<longrightarrow> P \<or> (Q \<longrightarrow> R))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>\<open>\<not>\<not>\<close>6\<close>
lemma \<open>\<not> \<not> (P \<or> \<not> P)\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>\<open>\<not>\<not>\<close>7\<close>
lemma \<open>\<not> \<not> (P \<or> \<not> \<not> \<not> P)\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>\<open>\<not>\<not>\<close>8. Peirce's law\<close>
lemma \<open>\<not> \<not> (((P \<longrightarrow> Q) \<longrightarrow> P) \<longrightarrow> P)\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>9\<close>
lemma \<open>((P \<or> Q) \<and> (\<not> P \<or> Q) \<and> (P \<or> \<not> Q)) \<longrightarrow> \<not> (\<not> P \<or> \<not> Q)\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>10\<close>
lemma \<open>(Q \<longrightarrow> R) \<longrightarrow> (R \<longrightarrow> P \<and> Q) \<longrightarrow> (P \<longrightarrow> (Q \<or> R)) \<longrightarrow> (P \<longleftrightarrow> Q)\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

subsection\<open>11. Proved in each direction (incorrectly, says Pelletier!!)\<close>

lemma \<open>P \<longleftrightarrow> P\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>\<open>\<not>\<not>\<close>12. Dijkstra's law\<close>
lemma \<open>\<not> \<not> (((P \<longleftrightarrow> Q) \<longleftrightarrow> R) \<longleftrightarrow> (P \<longleftrightarrow> (Q \<longleftrightarrow> R)))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

lemma \<open>((P \<longleftrightarrow> Q) \<longleftrightarrow> R) \<longrightarrow> \<not> \<not> (P \<longleftrightarrow> (Q \<longleftrightarrow> R))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>13. Distributive law\<close>
lemma \<open>P \<or> (Q \<and> R) \<longleftrightarrow> (P \<or> Q) \<and> (P \<or> R)\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>\<open>\<not>\<not>\<close>14\<close>
lemma \<open>\<not> \<not> ((P \<longleftrightarrow> Q) \<longleftrightarrow> ((Q \<or> \<not> P) \<and> (\<not> Q \<or> P)))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>\<open>\<not>\<not>\<close>15\<close>
lemma \<open>\<not> \<not> ((P \<longrightarrow> Q) \<longleftrightarrow> (\<not> P \<or> Q))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>\<open>\<not>\<not>\<close>16\<close>
lemma \<open>\<not> \<not> ((P \<longrightarrow> Q) \<or> (Q \<longrightarrow> P))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>\<open>\<not>\<not>\<close>17\<close>
lemma \<open>\<not> \<not> (((P \<and> (Q \<longrightarrow> R)) \<longrightarrow> S) \<longleftrightarrow> ((\<not> P \<or> Q \<or> S) \<and> (\<not> P \<or> \<not> R \<or> S)))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text \<open>Dijkstra's ``Golden Rule''\<close>
lemma \<open>(P \<and> Q) \<longleftrightarrow> P \<longleftrightarrow> Q \<longleftrightarrow> (P \<or> Q)\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

section \<open>Examples with quantifiers\<close>

subsection \<open>The converse is classical in the following implications \dots\<close>

lemma \<open>(\<exists>x. P(x) \<longrightarrow> Q) \<longrightarrow> (\<forall>x. P(x)) \<longrightarrow> Q\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

lemma \<open>((\<forall>x. P(x)) \<longrightarrow> Q) \<longrightarrow> \<not> (\<forall>x. P(x) \<and> \<not> Q)\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

lemma \<open>((\<forall>x. \<not> P(x)) \<longrightarrow> Q) \<longrightarrow> \<not> (\<forall>x. \<not> (P(x) \<or> Q))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

lemma \<open>(\<forall>x. P(x)) \<or> Q \<longrightarrow> (\<forall>x. P(x) \<or> Q)\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

lemma \<open>(\<exists>x. P \<longrightarrow> Q(x)) \<longrightarrow> (P \<longrightarrow> (\<exists>x. Q(x)))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

subsection \<open>The following are not constructively valid!\<close>
text \<open>The attempt to prove them terminates quickly!\<close>

lemma \<open>((\<forall>x. P(x)) \<longrightarrow> Q) \<longrightarrow> (\<exists>x. P(x) \<longrightarrow> Q)\<close>
  apply (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)?
  apply (rule asm_rl) \<comment> \<open>Checks that subgoals remain: proof failed.\<close>
  oops

lemma \<open>(P \<longrightarrow> (\<exists>x. Q(x))) \<longrightarrow> (\<exists>x. P \<longrightarrow> Q(x))\<close>
  apply (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)?
  apply (rule asm_rl) \<comment> \<open>Checks that subgoals remain: proof failed.\<close>
  oops

lemma \<open>(\<forall>x. P(x) \<or> Q) \<longrightarrow> ((\<forall>x. P(x)) \<or> Q)\<close>
  apply (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)?
  apply (rule asm_rl) \<comment> \<open>Checks that subgoals remain: proof failed.\<close>
  oops

lemma \<open>(\<forall>x. \<not> \<not> P(x)) \<longrightarrow> \<not> \<not> (\<forall>x. P(x))\<close>
  apply (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)?
  apply (rule asm_rl) \<comment> \<open>Checks that subgoals remain: proof failed.\<close>
  oops

text \<open>Classically but not intuitionistically valid.  Proved by a bug in 1986!\<close>
lemma \<open>\<exists>x. Q(x) \<longrightarrow> (\<forall>x. Q(x))\<close>
  apply (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)?
  apply (rule asm_rl) \<comment> \<open>Checks that subgoals remain: proof failed.\<close>
  oops

subsection \<open>Hard examples with quantifiers\<close>

text \<open>
  The ones that have not been proved are not known to be valid! Some will
  require quantifier duplication -- not currently available.
\<close>

text\<open>\<open>\<not>\<not>\<close>18\<close>
lemma \<open>\<not> \<not> (\<exists>y. \<forall>x. P(y) \<longrightarrow> P(x))\<close>
  oops  \<comment> \<open>NOT PROVED\<close>

text\<open>\<open>\<not>\<not>\<close>19\<close>
lemma \<open>\<not> \<not> (\<exists>x. \<forall>y z. (P(y) \<longrightarrow> Q(z)) \<longrightarrow> (P(x) \<longrightarrow> Q(x)))\<close>
  oops  \<comment> \<open>NOT PROVED\<close>

text\<open>20\<close>
lemma
  \<open>(\<forall>x y. \<exists>z. \<forall>w. (P(x) \<and> Q(y) \<longrightarrow> R(z) \<and> S(w)))
    \<longrightarrow> (\<exists>x y. P(x) \<and> Q(y)) \<longrightarrow> (\<exists>z. R(z))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>21\<close>
lemma \<open>(\<exists>x. P \<longrightarrow> Q(x)) \<and> (\<exists>x. Q(x) \<longrightarrow> P) \<longrightarrow> \<not> \<not> (\<exists>x. P \<longleftrightarrow> Q(x))\<close>
  oops \<comment> \<open>NOT PROVED; needs quantifier duplication\<close>

text\<open>22\<close>
lemma \<open>(\<forall>x. P \<longleftrightarrow> Q(x)) \<longrightarrow> (P \<longleftrightarrow> (\<forall>x. Q(x)))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>\<open>\<not>\<not>\<close>23\<close>
lemma \<open>\<not> \<not> ((\<forall>x. P \<or> Q(x)) \<longleftrightarrow> (P \<or> (\<forall>x. Q(x))))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>24\<close>
lemma
  \<open>\<not> (\<exists>x. S(x) \<and> Q(x)) \<and> (\<forall>x. P(x) \<longrightarrow> Q(x) \<or> R(x)) \<and>
    (\<not> (\<exists>x. P(x)) \<longrightarrow> (\<exists>x. Q(x))) \<and> (\<forall>x. Q(x) \<or> R(x) \<longrightarrow> S(x))
    \<longrightarrow> \<not> \<not> (\<exists>x. P(x) \<and> R(x))\<close>
text \<open>
  Not clear why \<open>fast_tac\<close>, \<open>best_tac\<close>, \<open>ASTAR\<close> and
  \<open>ITER_DEEPEN\<close> all take forever.
\<close>
  apply (tactic \<open>IntPr.safe_tac \<^context>\<close>)
  apply (erule impE)
  apply (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)
  apply (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)
  done

text\<open>25\<close>
lemma
  \<open>(\<exists>x. P(x)) \<and>
      (\<forall>x. L(x) \<longrightarrow> \<not> (M(x) \<and> R(x))) \<and>
      (\<forall>x. P(x) \<longrightarrow> (M(x) \<and> L(x))) \<and>
      ((\<forall>x. P(x) \<longrightarrow> Q(x)) \<or> (\<exists>x. P(x) \<and> R(x)))
    \<longrightarrow> (\<exists>x. Q(x) \<and> P(x))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>\<open>\<not>\<not>\<close>26\<close>
lemma
  \<open>(\<not> \<not> (\<exists>x. p(x)) \<longleftrightarrow> \<not> \<not> (\<exists>x. q(x))) \<and>
    (\<forall>x. \<forall>y. p(x) \<and> q(y) \<longrightarrow> (r(x) \<longleftrightarrow> s(y)))
  \<longrightarrow> ((\<forall>x. p(x) \<longrightarrow> r(x)) \<longleftrightarrow> (\<forall>x. q(x) \<longrightarrow> s(x)))\<close>
  oops  \<comment> \<open>NOT PROVED\<close>

text\<open>27\<close>
lemma
  \<open>(\<exists>x. P(x) \<and> \<not> Q(x)) \<and>
    (\<forall>x. P(x) \<longrightarrow> R(x)) \<and>
    (\<forall>x. M(x) \<and> L(x) \<longrightarrow> P(x)) \<and>
    ((\<exists>x. R(x) \<and> \<not> Q(x)) \<longrightarrow> (\<forall>x. L(x) \<longrightarrow> \<not> R(x)))
  \<longrightarrow> (\<forall>x. M(x) \<longrightarrow> \<not> L(x))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>\<open>\<not>\<not>\<close>28. AMENDED\<close>
lemma
  \<open>(\<forall>x. P(x) \<longrightarrow> (\<forall>x. Q(x))) \<and>
      (\<not> \<not> (\<forall>x. Q(x) \<or> R(x)) \<longrightarrow> (\<exists>x. Q(x) \<and> S(x))) \<and>
      (\<not> \<not> (\<exists>x. S(x)) \<longrightarrow> (\<forall>x. L(x) \<longrightarrow> M(x)))
    \<longrightarrow> (\<forall>x. P(x) \<and> L(x) \<longrightarrow> M(x))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>29. Essentially the same as Principia Mathematica *11.71\<close>
lemma
  \<open>(\<exists>x. P(x)) \<and> (\<exists>y. Q(y))
    \<longrightarrow> ((\<forall>x. P(x) \<longrightarrow> R(x)) \<and> (\<forall>y. Q(y) \<longrightarrow> S(y)) \<longleftrightarrow>
      (\<forall>x y. P(x) \<and> Q(y) \<longrightarrow> R(x) \<and> S(y)))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>\<open>\<not>\<not>\<close>30\<close>
lemma
  \<open>(\<forall>x. (P(x) \<or> Q(x)) \<longrightarrow> \<not> R(x)) \<and>
      (\<forall>x. (Q(x) \<longrightarrow> \<not> S(x)) \<longrightarrow> P(x) \<and> R(x))
    \<longrightarrow> (\<forall>x. \<not> \<not> S(x))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>31\<close>
lemma
  \<open>\<not> (\<exists>x. P(x) \<and> (Q(x) \<or> R(x))) \<and>
      (\<exists>x. L(x) \<and> P(x)) \<and>
      (\<forall>x. \<not> R(x) \<longrightarrow> M(x))
  \<longrightarrow> (\<exists>x. L(x) \<and> M(x))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>32\<close>
lemma
  \<open>(\<forall>x. P(x) \<and> (Q(x) \<or> R(x)) \<longrightarrow> S(x)) \<and>
    (\<forall>x. S(x) \<and> R(x) \<longrightarrow> L(x)) \<and>
    (\<forall>x. M(x) \<longrightarrow> R(x))
  \<longrightarrow> (\<forall>x. P(x) \<and> M(x) \<longrightarrow> L(x))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>\<open>\<not>\<not>\<close>33\<close>
lemma
  \<open>(\<forall>x. \<not> \<not> (P(a) \<and> (P(x) \<longrightarrow> P(b)) \<longrightarrow> P(c))) \<longleftrightarrow>
    (\<forall>x. \<not> \<not> ((\<not> P(a) \<or> P(x) \<or> P(c)) \<and> (\<not> P(a) \<or> \<not> P(b) \<or> P(c))))\<close>
  apply (tactic \<open>IntPr.best_tac \<^context> 1\<close>)
  done

text\<open>36\<close>
lemma
  \<open>(\<forall>x. \<exists>y. J(x,y)) \<and>
    (\<forall>x. \<exists>y. G(x,y)) \<and>
    (\<forall>x y. J(x,y) \<or> G(x,y) \<longrightarrow> (\<forall>z. J(y,z) \<or> G(y,z) \<longrightarrow> H(x,z)))
  \<longrightarrow> (\<forall>x. \<exists>y. H(x,y))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>37\<close>
lemma
  \<open>(\<forall>z. \<exists>w. \<forall>x. \<exists>y.
      \<not> \<not> (P(x,z) \<longrightarrow> P(y,w)) \<and> P(y,z) \<and> (P(y,w) \<longrightarrow> (\<exists>u. Q(u,w)))) \<and>
        (\<forall>x z. \<not> P(x,z) \<longrightarrow> (\<exists>y. Q(y,z))) \<and>
        (\<not> \<not> (\<exists>x y. Q(x,y)) \<longrightarrow> (\<forall>x. R(x,x)))
    \<longrightarrow> \<not> \<not> (\<forall>x. \<exists>y. R(x,y))\<close>
  oops  \<comment> \<open>NOT PROVED\<close>

text\<open>39\<close>
lemma \<open>\<not> (\<exists>x. \<forall>y. F(y,x) \<longleftrightarrow> \<not> F(y,y))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>40. AMENDED\<close>
lemma
  \<open>(\<exists>y. \<forall>x. F(x,y) \<longleftrightarrow> F(x,x)) \<longrightarrow>
    \<not> (\<forall>x. \<exists>y. \<forall>z. F(z,y) \<longleftrightarrow> \<not> F(z,x))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>44\<close>
lemma
  \<open>(\<forall>x. f(x) \<longrightarrow>
    (\<exists>y. g(y) \<and> h(x,y) \<and> (\<exists>y. g(y) \<and> \<not> h(x,y)))) \<and>
    (\<exists>x. j(x) \<and> (\<forall>y. g(y) \<longrightarrow> h(x,y)))
    \<longrightarrow> (\<exists>x. j(x) \<and> \<not> f(x))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>48\<close>
lemma \<open>(a = b \<or> c = d) \<and> (a = c \<or> b = d) \<longrightarrow> a = d \<or> b = c\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>51\<close>
lemma
  \<open>(\<exists>z w. \<forall>x y. P(x,y) \<longleftrightarrow> (x = z \<and> y = w)) \<longrightarrow>
    (\<exists>z. \<forall>x. \<exists>w. (\<forall>y. P(x,y) \<longleftrightarrow> y = w) \<longleftrightarrow> x = z)\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>52\<close>
text \<open>Almost the same as 51.\<close>
lemma
  \<open>(\<exists>z w. \<forall>x y. P(x,y) \<longleftrightarrow> (x = z \<and> y = w)) \<longrightarrow>
    (\<exists>w. \<forall>y. \<exists>z. (\<forall>x. P(x,y) \<longleftrightarrow> x = z) \<longleftrightarrow> y = w)\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>56\<close>
lemma \<open>(\<forall>x. (\<exists>y. P(y) \<and> x = f(y)) \<longrightarrow> P(x)) \<longleftrightarrow> (\<forall>x. P(x) \<longrightarrow> P(f(x)))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>57\<close>
lemma
  \<open>P(f(a,b), f(b,c)) \<and> P(f(b,c), f(a,c)) \<and>
    (\<forall>x y z. P(x,y) \<and> P(y,z) \<longrightarrow> P(x,z)) \<longrightarrow> P(f(a,b), f(a,c))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>60\<close>
lemma \<open>\<forall>x. P(x,f(x)) \<longleftrightarrow> (\<exists>y. (\<forall>z. P(z,y) \<longrightarrow> P(z,f(x))) \<and> P(x,y))\<close>
  by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

end


(*
  Title: Representation Theorems for Orderings and Lattices
  Author: Georg Struth
  Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Representation Theorems for Orderings and Lattices\<close>

theory Representations
  imports Order_Lattice_Props

begin

subsection \<open>Representation of Posets\<close>

text \<open>The isomorphism between partial orders and downsets with set inclusion is well known. It forms the basis of Priestley and Stone duality.
I show it not only for objects, but also order morphisms, hence establish equivalences and isomorphisms between categories.\<close>

typedef (overloaded) 'a downset = "range (\<down>::'a::ord \<Rightarrow> 'a set)"
  by fastforce

setup_lifting type_definition_downset

text \<open>The map ds yields the isomorphism between the set and the powerset level if its range is restricted to downsets.\<close>

definition ds :: "'a::ord \<Rightarrow> 'a downset" where
  "ds = Abs_downset \<circ> \<down>"

text \<open>In a complete lattice, its inverse is Sup.\<close>

definition SSup :: "'a::complete_lattice downset \<Rightarrow> 'a" where
  "SSup = Sup \<circ> Rep_downset"

lemma ds_SSup_inv: "ds \<circ> SSup = (id::'a::complete_lattice downset \<Rightarrow> 'a downset)"
  unfolding ds_def SSup_def
  by (smt Rep_downset Rep_downset_inverse cSup_atMost eq_id_iff imageE o_def ord_class.atMost_def ord_class.downset_prop)

lemma SSup_ds_inv: "SSup \<circ> ds = (id::'a::complete_lattice \<Rightarrow> 'a)"
  unfolding ds_def SSup_def fun_eq_iff id_def comp_def by (simp add: Abs_downset_inverse pointfree_idE)

instantiation downset :: (ord) order
begin

lift_definition less_eq_downset :: "'a downset \<Rightarrow> 'a downset \<Rightarrow> bool" is "(\<lambda>X Y. Rep_downset X \<subseteq> Rep_downset Y)" .

lift_definition less_downset :: "'a downset \<Rightarrow> 'a downset \<Rightarrow> bool" is "(\<lambda>X Y. Rep_downset X \<subset> Rep_downset Y)" .

instance
  by (intro_classes, transfer, auto simp: Rep_downset_inject less_eq_downset_def)

end

lemma ds_iso: "mono ds"
  unfolding mono_def ds_def fun_eq_iff comp_def
  by (metis Abs_downset_inverse downset_iso_iff less_eq_downset.rep_eq rangeI)

lemma ds_faithful: "ds x \<le> ds y \<Longrightarrow> x \<le> (y::'a::order)"
  by (simp add: Abs_downset_inverse downset_faithful ds_def less_eq_downset.rep_eq)

lemma ds_inj: "inj (ds::'a::order \<Rightarrow> 'a downset)"
  by (simp add: ds_faithful dual_order.antisym injI)

lemma ds_surj: "surj ds"
  by (metis (no_types, hide_lams) Rep_downset Rep_downset_inverse ds_def image_iff o_apply surj_def)

lemma ds_bij: "bij (ds::'a::order \<Rightarrow> 'a downset)"
  by (simp add: bijI ds_inj ds_surj)

lemma ds_ord_iso: "ord_iso ds"
  unfolding ord_iso_def comp_def inf_bool_def by (smt UNIV_I ds_bij ds_faithful ds_inj ds_iso ds_surj f_the_inv_into_f inf1I mono_def)

text \<open>The morphishms between orderings and downsets are isotone functions. One can define functors mapping back and forth between these.\<close>

definition map_ds :: "('a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<Rightarrow> ('a downset \<Rightarrow> 'b downset)" where
  "map_ds f = ds \<circ> f \<circ> SSup"

text \<open>This definition is actually contrived. We have shown that a function f between posets P and Q is isotone if and only if the
inverse image of f maps downclosed sets in Q to downclosed sets in P. There is the following duality: ds is a natural transformation
between the identity functor and the preimage functor as a contravariant functor from P to Q. Hence orderings with isotone maps and
downsets with downset-preserving maps are dual, which is a first step towards Stone duality. I don't see a way of proving this with Isabelle,
as the types of the preimage of f are the wrong way and I don't see how I could capture opposition with what I have.\<close>

(*lemma "mono (f::'a::complete_lattice \<Rightarrow> 'b::complete_lattimap_ds f = Abs_downset \<circ> (-`) f \<circ> Rep_downset" doesn't work! *)

lemma map_ds_prop:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "map_ds f \<circ> ds = ds \<circ> f"
  unfolding map_ds_def by (simp add: SSup_ds_inv comp_assoc)

lemma map_ds_prop2:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "map_ds f \<circ> ds = ds \<circ> id f"
  unfolding map_ds_def by (simp add: SSup_ds_inv comp_assoc)

text \<open>This is part of showing that map-ds is naturally isomorphic to the identity functor, ds being the natural isomorphism.\<close>

definition map_SSup :: "('a downset \<Rightarrow> 'b downset) \<Rightarrow> ('a::complete_lattice \<Rightarrow> 'b::complete_lattice)" where
  "map_SSup F = SSup \<circ> F \<circ> ds"

lemma map_ds_iso_pres:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "mono f \<Longrightarrow> mono (map_ds f)"
  unfolding fun_eq_iff mono_def map_ds_def ds_def SSup_def comp_def
  by (metis Abs_downset_inverse Sup_subset_mono downset_iso_iff less_eq_downset.rep_eq rangeI)

lemma map_SSup_iso_pres:
  fixes F :: "'a::complete_lattice downset \<Rightarrow> 'b::complete_lattice downset"
  shows "mono F \<Longrightarrow> mono (map_SSup F)"
  unfolding fun_eq_iff mono_def map_SSup_def ds_def SSup_def comp_def
  by (metis Abs_downset_inverse Sup_subset_mono downset_iso_iff less_eq_downset.rep_eq rangeI)

lemma map_SSup_prop:
  fixes F :: "'a::complete_lattice downset \<Rightarrow> 'b::complete_lattice downset"
  shows "ds \<circ> map_SSup F = F \<circ> ds"
  unfolding map_SSup_def by (metis ds_SSup_inv fun.map_id0 id_def rewriteL_comp_comp)

lemma map_SSup_prop2:
  fixes F :: "'a::complete_lattice downset \<Rightarrow> 'b::complete_lattice downset"
  shows "ds \<circ> map_SSup F = id F \<circ> ds"
  by (simp add: map_SSup_prop)

lemma map_ds_func1: "map_ds id = (id::'a::complete_lattice downset\<Rightarrow> 'a downset)"
  by (simp add: ds_SSup_inv map_ds_def)

lemma map_ds_func2:
  fixes g :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "map_ds (f \<circ> g) = map_ds f \<circ> map_ds g"
  unfolding map_ds_def fun_eq_iff comp_def ds_def SSup_def
  by (metis Abs_downset_inverse Sup_atMost atMost_def downset_prop rangeI)

lemma map_SSup_func1: "map_SSup (id::'a::complete_lattice downset\<Rightarrow> 'a downset) = id"
  by (simp add: SSup_ds_inv map_SSup_def)

lemma map_SSup_func2:
  fixes F :: "'c::complete_lattice downset \<Rightarrow> 'b::complete_lattice downset"
  and G :: "'a::complete_lattice downset \<Rightarrow> 'c downset"
  shows "map_SSup (F \<circ> G) = map_SSup F \<circ> map_SSup G"
  unfolding map_SSup_def fun_eq_iff comp_def id_def ds_def
  by (metis comp_apply ds_SSup_inv ds_def id_apply)

lemma map_SSup_map_ds_inv: "map_SSup \<circ> map_ds = (id::('a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<Rightarrow> ('a \<Rightarrow> 'b))"
  by (metis (no_types, hide_lams) SSup_ds_inv comp_def eq_id_iff fun.map_comp fun.map_id0 id_apply map_SSup_prop map_ds_prop)

lemma inj_map_ds: "inj (map_ds::('a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<Rightarrow> ('a downset \<Rightarrow> 'b downset))"
  by (metis (no_types, lifting) SSup_ds_inv fun.map_id0 id_comp inj_def map_ds_prop rewriteR_comp_comp2)

lemma inj_map_SSup: "inj (map_SSup::('a::complete_lattice downset \<Rightarrow> 'b::complete_lattice downset) \<Rightarrow> ('a \<Rightarrow> 'b))"
  by (metis inj_on_id inj_on_imageI2 map_ds_map_SSup_inv)

lemma map_ds_map_SSup_iff:
  fixes g :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "(f = map_ds g) = (map_SSup f = g)"
  by (metis inj_eq inj_map_ds map_ds_map_SSup_inv pointfree_idE)

text \<open>This gives an isomorphism between categories.\<close>

lemma surj_map_ds: "surj (map_ds::('a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<Rightarrow> ('a downset \<Rightarrow> 'b downset))"
  by (simp add: map_ds_map_SSup_iff surj_def)

lemma surj_map_SSup: "surj (map_SSup::('a::complete_lattice_with_dual downset \<Rightarrow> 'b::complete_lattice_with_dual downset) \<Rightarrow> ('a \<Rightarrow> 'b))"
  by (metis map_ds_map_SSup_iff surjI)

text \<open>There is of course a dual result for upsets with the reverse inclusion ordering. Once again, it seems impossible to capture
the "real" duality that uses the inverse image functor.\<close>

typedef (overloaded) 'a upset = "range (\<up>::'a::ord \<Rightarrow> 'a set)"
  by fastforce

setup_lifting type_definition_upset

definition us :: "'a::ord \<Rightarrow> 'a upset" where
  "us = Abs_upset \<circ> \<up>"

definition IInf :: "'a::complete_lattice upset \<Rightarrow> 'a" where
  "IInf = Inf \<circ> Rep_upset"

lemma us_ds: "us = Abs_upset \<circ> (`) \<partial> \<circ> Rep_downset \<circ> ds \<circ> (\<partial>::'a::ord_with_dual \<Rightarrow> 'a)"
  unfolding us_def ds_def fun_eq_iff comp_def by (simp add: Abs_downset_inverse upset_to_downset2)

lemma IInf_SSup: "IInf = \<partial> \<circ> SSup \<circ> Abs_downset \<circ> (`) (\<partial>::'a::complete_lattice_with_dual \<Rightarrow> 'a) \<circ> Rep_upset"
  unfolding IInf_def SSup_def fun_eq_iff comp_def
  by (metis (no_types, hide_lams) Abs_downset_inverse Rep_upset Sup_dual_def_var image_iff rangeI subset_dual upset_to_downset3)

lemma us_IInf_inv: "us \<circ> IInf = (id::'a::complete_lattice_with_dual upset \<Rightarrow> 'a upset)"
  unfolding us_def IInf_def fun_eq_iff id_def comp_def
  by (metis (no_types, lifting) Inf_upset_id Rep_upset Rep_upset_inverse f_the_inv_into_f pointfree_idE upset_inj)

lemma IInf_us_inv: "IInf \<circ> us = (id::'a::complete_lattice_with_dual \<Rightarrow> 'a)"
  unfolding us_def IInf_def fun_eq_iff id_def comp_def
  by (metis Abs_upset_inverse Sup_Inf_var Sup_atLeastAtMost Sup_dual_upset_var order_refl rangeI)

instantiation upset :: (ord) order
begin

lift_definition less_eq_upset :: "'a upset \<Rightarrow> 'a upset \<Rightarrow> bool" is "(\<lambda>X Y. Rep_upset X \<supseteq> Rep_upset Y)" .

lift_definition less_upset :: "'a upset \<Rightarrow> 'a upset \<Rightarrow> bool" is "(\<lambda>X Y. Rep_upset X \<supset> Rep_upset Y)" .

instance
  by (intro_classes, transfer, simp_all add: less_le_not_le less_eq_upset.rep_eq Rep_upset_inject)

end

lemma us_iso: "x \<le> y \<Longrightarrow> us x \<le> us (y::'a::order_with_dual)"
  by (simp add: Abs_upset_inverse less_eq_upset.rep_eq upset_anti_iff us_def)

lemma us_faithful: "us x \<le> us y \<Longrightarrow> x \<le> (y::'a::order_with_dual)"
  by (simp add: Abs_upset_inverse upset_faithful us_def less_eq_upset.rep_eq)

lemma us_inj: "inj (us::'a::order_with_dual \<Rightarrow> 'a upset)"
  unfolding inj_def by (simp add: us_faithful dual_order.antisym)

lemma us_surj: "surj (us::'a::order_with_dual \<Rightarrow> 'a upset)"
  unfolding surj_def by (metis Rep_upset Rep_upset_inverse comp_def image_iff us_def)

lemma us_bij: "bij (us::'a::order_with_dual \<Rightarrow> 'a upset)"
  by (simp add: bij_def us_surj us_inj)

lemma us_ord_iso: "ord_iso (us::'a::order_with_dual \<Rightarrow> 'a upset)"
  unfolding ord_iso_def
  by (simp, metis (no_types, lifting) UNIV_I f_the_inv_into_f monoI us_iso us_bij us_faithful us_inj us_surj)

definition map_us :: "('a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<Rightarrow> ('a upset \<Rightarrow> 'b upset)" where
  "map_us f = us \<circ> f \<circ> IInf"

lemma map_us_prop: "map_us f \<circ> (us::'a::complete_lattice_with_dual \<Rightarrow> 'a upset) = us \<circ> id f"
  unfolding map_us_def by (simp add: IInf_us_inv comp_assoc)

definition map_IInf :: "('a upset \<Rightarrow> 'b upset) \<Rightarrow> ('a::complete_lattice \<Rightarrow> 'b::complete_lattice)" where
  "map_IInf F = IInf \<circ> F \<circ> us"

lemma map_IInf_prop: "(us::'a::complete_lattice_with_dual \<Rightarrow> 'a upset) \<circ> map_IInf F = id F \<circ> us"
proof-
  have "us \<circ> map_IInf F = (us \<circ> IInf) \<circ> F \<circ> us"
    by (simp add: fun.map_comp map_IInf_def)
  thus ?thesis
    by (simp add: us_IInf_inv)
qed

lemma map_us_func1: "map_us id = (id::'a::complete_lattice_with_dual upset \<Rightarrow> 'a upset)"
  unfolding map_us_def fun_eq_iff comp_def us_def id_def IInf_def
  by (metis (no_types, lifting) Inf_upset_id Rep_upset Rep_upset_inverse image_iff pointfree_idE)

lemma map_us_func2:
  fixes f :: "'c::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  and g :: "'a::complete_lattice_with_dual \<Rightarrow> 'c"
  shows "map_us (f \<circ> g) = map_us f \<circ> map_us g"
  unfolding map_us_def fun_eq_iff comp_def us_def IInf_def
  by (metis Abs_upset_inverse Sup_Inf_var Sup_atLeastAtMost Sup_dual_upset_var order_refl rangeI)

lemma map_IInf_func1: "map_IInf id = (id::'a::complete_lattice_with_dual \<Rightarrow> 'a)"
  unfolding map_IInf_def fun_eq_iff comp_def id_def us_def IInf_def by (simp add: Abs_upset_inverse pointfree_idE)

lemma map_IInf_func2:
  fixes F :: "'c::complete_lattice_with_dual upset \<Rightarrow> 'b::complete_lattice_with_dual upset"
  and G :: "'a::complete_lattice_with_dual upset \<Rightarrow> 'c upset"
  shows "map_IInf (F \<circ> G) = map_IInf F \<circ> map_IInf G"
  unfolding map_IInf_def fun_eq_iff comp_def id_def us_def
  by (metis comp_apply id_apply us_IInf_inv us_def)

lemma map_IInf_map_us_inv: "map_IInf \<circ> map_us = (id::('a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual) \<Rightarrow> ('a \<Rightarrow> 'b))"
  unfolding map_IInf_def map_us_def IInf_def us_def id_def comp_def fun_eq_iff by (simp add: Abs_upset_inverse pointfree_idE)

lemma map_us_map_IInf_inv: "map_us \<circ> map_IInf = (id::('a::complete_lattice_with_dual upset \<Rightarrow> 'b::complete_lattice_with_dual upset) \<Rightarrow> ('a upset \<Rightarrow> 'b upset))"
  unfolding map_IInf_def map_us_def IInf_def us_def id_def comp_def fun_eq_iff
  by (metis (no_types, lifting) Inf_upset_id Rep_upset Rep_upset_inverse image_iff pointfree_idE)

lemma inj_map_us: "inj (map_us::('a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual) \<Rightarrow> ('a upset \<Rightarrow> 'b upset))"
  unfolding map_us_def us_def IInf_def inj_def comp_def fun_eq_iff
  by (metis (no_types, hide_lams) Abs_upset_inverse Inf_upset_id pointfree_idE rangeI)

lemma inj_map_IInf: "inj (map_IInf::('a::complete_lattice_with_dual upset \<Rightarrow> 'b::complete_lattice_with_dual upset) \<Rightarrow> ('a \<Rightarrow> 'b))"
  unfolding map_IInf_def fun_eq_iff inj_def comp_def IInf_def us_def
  by (metis (no_types, hide_lams) Inf_upset_id Rep_upset Rep_upset_inverse image_iff pointfree_idE)

lemma map_us_map_IInf_iff:
  fixes g :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  shows "(f = map_us g) = (map_IInf f = g)"
  by (metis inj_eq inj_map_us map_us_map_IInf_inv pointfree_idE)

lemma map_us_mono_pres:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  shows "mono f \<Longrightarrow> mono (map_us f)"
  unfolding mono_def map_us_def comp_def us_def IInf_def
  by (metis Abs_upset_inverse Inf_superset_mono less_eq_upset.rep_eq rangeI upset_anti_iff)

lemma map_IInf_mono_pres:
  fixes F :: "'a::complete_lattice_with_dual upset \<Rightarrow> 'b::complete_lattice_with_dual upset"
  shows "mono F \<Longrightarrow> mono (map_IInf F)"
  unfolding mono_def map_IInf_def comp_def us_def IInf_def
  oops

lemma surj_map_us: "surj (map_us::('a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual) \<Rightarrow> ('a upset \<Rightarrow> 'b upset))"
  by (simp add: map_us_map_IInf_iff surj_def)

lemma surj_map_IInf: "surj (map_IInf::('a::complete_lattice_with_dual upset \<Rightarrow> 'b::complete_lattice_with_dual upset) \<Rightarrow> ('a \<Rightarrow> 'b))"
  by (metis map_us_map_IInf_iff surjI)

text \<open>Hence we have again an isomorphism --- or rather equivalence --- between categories. Here, however, duality is not consistently picked up.\<close>

subsection \<open>Stone's Theorem in the Presence of Atoms\<close>

text \<open>Atom-map is a boolean algebra morphism.\<close>

context boolean_algebra
begin

lemma atom_map_compl_pres: "atom_map (-x) = Collect atom - atom_map x"
proof-
  {fix y
  have "(y \<in> atom_map (-x)) = (atom y \<and> y \<le> -x)"
    by (simp add: atom_map_def)
  also have "... = (atom y \<and> \<not>(y \<le> x))"
    by (metis atom_sup_iff inf.orderE meet_shunt sup_compl_top top.ordering_top_axioms ordering_top.extremum)
   also have "... = (y \<in> Collect atom - atom_map x)"
     using atom_map_def by auto
   finally have "(y \<in> atom_map (-x)) = (y \<in> Collect atom - atom_map x)".}
  thus ?thesis
    by blast
qed

lemma atom_map_sup_pres: "atom_map (x \<squnion> y) = atom_map x \<union> atom_map y"
proof-
  {fix z
  have "(z \<in> atom_map (x \<squnion> y)) = (atom z \<and> z \<le> x \<squnion> y)"
    by (simp add: atom_map_def)
  also have "... = (atom z \<and> (z \<le> x \<or> z \<le> y))"
    using atom_sup_iff by auto
  also have "... = (z \<in> atom_map x \<union> atom_map y)"
    using atom_map_def by auto
  finally have "(z \<in> atom_map (x \<squnion> y)) = (z \<in> atom_map x \<union> atom_map y)"
    by blast}
  thus ?thesis
    by blast
qed

lemma atom_map_inf_pres: "atom_map (x \<sqinter> y) = atom_map x \<inter> atom_map y"
  by (smt Diff_Un atom_map_compl_pres atom_map_sup_pres compl_inf double_compl)

lemma atom_map_minus_pres: "atom_map (x - y) = atom_map x - atom_map y"
  using atom_map_compl_pres atom_map_def diff_eq by auto

end

text \<open>The homomorphic images of boolean algebras under atom-map are boolean algebras
--- in fact powerset boolean algebras.\<close>

instantiation atoms :: (boolean_algebra) boolean_algebra
begin

lift_definition minus_atoms :: "'a atoms \<Rightarrow> 'a atoms \<Rightarrow> 'a atoms" is "\<lambda>x y. Abs_atoms (Rep_atoms x - Rep_atoms y)".

lift_definition uminus_atoms :: "'a atoms \<Rightarrow> 'a atoms" is  "\<lambda>x. Abs_atoms (Collect atom - Rep_atoms x)".

lift_definition bot_atoms :: "'a atoms" is "Abs_atoms {}".

lift_definition sup_atoms ::  "'a atoms \<Rightarrow> 'a atoms \<Rightarrow> 'a atoms" is "\<lambda>x y. Abs_atoms (Rep_atoms x \<union> Rep_atoms y)".

lift_definition top_atoms :: "'a atoms" is "Abs_atoms (Collect atom)".

lift_definition inf_atoms ::  "'a atoms \<Rightarrow> 'a atoms \<Rightarrow> 'a atoms" is "\<lambda>x y. Abs_atoms (Rep_atoms x \<inter> Rep_atoms y)".

lift_definition less_eq_atoms :: "'a atoms \<Rightarrow> 'a atoms \<Rightarrow> bool" is "(\<lambda>x y. Rep_atoms x \<subseteq> Rep_atoms y)".

lift_definition less_atoms :: "'a atoms \<Rightarrow> 'a atoms \<Rightarrow> bool" is "(\<lambda>x y. Rep_atoms x \<subset> Rep_atoms y)".

instance
  apply intro_classes
                 apply (transfer, simp add: less_le_not_le)
                apply (transfer, simp)
               apply (transfer, blast)
              apply (simp add: Rep_atoms_inject less_eq_atoms.abs_eq)
             apply (transfer, smt Abs_atoms_inverse Rep_atoms atom_map_inf_pres image_iff inf_le1 rangeI)
            apply (transfer, smt Abs_atoms_inverse Rep_atoms atom_map_inf_pres image_iff inf_le2 rangeI)
           apply (transfer, smt Abs_atoms_inverse Rep_atoms atom_map_inf_pres image_iff le_iff_sup rangeI sup_inf_distrib1)
          apply (transfer, smt Abs_atoms_inverse Rep_atoms atom_map_sup_pres image_iff image_iff inf.orderE inf_sup_aci(6) le_iff_sup order_refl rangeI rangeI)
         apply (transfer, smt Abs_atoms_inverse Rep_atoms atom_map_sup_pres image_iff inf_sup_aci(6) le_iff_sup rangeI sup.left_commute sup.right_idem)
        apply (transfer, subst Abs_atoms_inverse, metis (no_types, lifting) Rep_atoms atom_map_sup_pres image_iff rangeI, simp)
       apply transfer using Abs_atoms_inverse atom_map_bot_pres apply blast
      apply (transfer, metis Abs_atoms_inverse Rep_atoms atom_map_compl_pres atom_map_top_pres diff_eq double_compl inf_le1 rangeE rangeI)
     apply (transfer, smt Abs_atoms_inverse Rep_atoms atom_map_inf_pres atom_map_sup_pres image_iff rangeI sup_inf_distrib1)
    apply (transfer, metis (no_types, hide_lams) Abs_atoms_inverse Diff_disjoint Rep_atoms atom_map_compl_pres rangeE rangeI)
   apply (transfer, smt Abs_atoms_inverse uminus_atoms.abs_eq Rep_atoms Un_Diff_cancel atom_map_compl_pres atom_map_inf_pres atom_map_minus_pres atom_map_sup_pres atom_map_top_pres diff_eq double_compl inf_compl_bot_right rangeE rangeI sup_commute sup_compl_top)
  by transfer (smt Abs_atoms_inverse Rep_atoms atom_map_compl_pres atom_map_inf_pres atom_map_minus_pres diff_eq rangeE rangeI)

end

text \<open>The homomorphism atom-map can then be restricted in its output type to the powerset boolean algebra.\<close>

lemma at_map_bot_pres: "at_map \<bottom> = \<bottom>"
  by (simp add: at_map_def atom_map_bot_pres bot_atoms.transfer)

lemma at_map_top_pres: "at_map \<top> = \<top>"
  by (simp add: at_map_def atom_map_top_pres top_atoms.transfer)

lemma at_map_compl_pres: "at_map \<circ> uminus = uminus \<circ> at_map"
  unfolding fun_eq_iff by (simp add: Abs_atoms_inverse at_map_def atom_map_compl_pres uminus_atoms.abs_eq)

lemma at_map_sup_pres: "at_map (x \<squnion> y) = at_map x \<squnion> at_map y"
  unfolding at_map_def comp_def by (metis (mono_tags, lifting) Abs_atoms_inverse atom_map_sup_pres rangeI sup_atoms.transfer)

lemma at_map_inf_pres: "at_map (x \<sqinter> y) = at_map x \<sqinter> at_map y"
  unfolding at_map_def comp_def by (metis (mono_tags, lifting) Abs_atoms_inverse atom_map_inf_pres inf_atoms.transfer rangeI)

lemma at_map_minus_pres: "at_map (x - y) = at_map x - at_map y"
  unfolding at_map_def comp_def by (simp add: Abs_atoms_inverse atom_map_minus_pres minus_atoms.abs_eq)

context atomic_boolean_algebra
begin

text \<open>In atomic boolean algebras, atom-map is an embedding that maps atoms of the boolean algebra to
those of the powerset boolean algebra. Analogous properties hold for at-map.\<close>

lemma inj_atom_map: "inj atom_map"
proof-
  {fix x y ::'a
    assume "x \<noteq> y"
  hence "x \<sqinter> -y \<noteq> \<bottom> \<or> -x \<sqinter> y \<noteq> \<bottom>"
    by (auto simp: meet_shunt)
  hence "\<exists>z. atom z \<and> (z \<le> x \<sqinter> -y \<or> z \<le> -x \<sqinter> y)"
    using atomicity by blast
  hence "\<exists>z. atom z \<and> ((z \<in> atom_map x \<and> \<not>(z \<in> atom_map y)) \<or> (\<not>(z \<in> atom_map x) \<and> z \<in> atom_map y))"
    unfolding atom_def atom_map_def by (clarsimp, metis diff_eq inf.orderE meet_shunt_var)
  hence "atom_map x \<noteq> atom_map y"
    by blast}
  thus ?thesis
    by (meson injI)
qed

lemma atom_map_atom_pres: "atom x \<Longrightarrow> atom_map x = {x}"
  unfolding atom_def atom_map_def by (auto simp: bot_less dual_order.order_iff_strict)

lemma atom_map_atom_pres2: "atom x \<Longrightarrow> atom (atom_map x)"
proof-
  assume "atom x"
  hence "atom_map x = {x}"
    by (simp add: atom_map_atom_pres)
  thus "atom (atom_map x)"
    using bounded_lattice_class.atom_def by auto
qed

end

lemma inj_at_map: "inj (at_map::'a::atomic_boolean_algebra \<Rightarrow> 'a atoms)"
  unfolding at_map_def comp_def by (metis (no_types, lifting) Abs_atoms_inverse inj_atom_map inj_def rangeI)

text \<open>Homomorphic images of atomic boolean algebras under atom-map are therefore atomic (rather obviously).\<close>

instance atoms :: (atomic_boolean_algebra) atomic_boolean_algebra
proof intro_classes
  fix x::"'a atoms"
  assume "x \<noteq> \<bottom>"
  hence "\<exists>y. x = at_map y \<and> x \<noteq> \<bottom>"
    unfolding at_map_def comp_def by (metis Abs_atoms_cases rangeE)
  hence "\<exists>y. x = at_map y \<and> (\<exists>z. atom z \<and> z \<le> y)"
    using at_map_bot_pres atomicity by force
  hence "\<exists>y. x = at_map y \<and> (\<exists>z. atom (at_map z) \<and> at_map z \<le> at_map y)"
    by (metis at_map_atom_pres2 at_map_sup_pres sup.orderE sup_ge2)
  thus "\<exists>y. atom y \<and> y \<le> x"
    by fastforce
qed

context complete_boolean_algebra_alt
begin

text \<open>In complete boolean algebras, atom-map is surjective; more precisely it is the left inverse
of Sup, at least for sets of atoms. Below, this statement is made more explicit for at-map.\<close>

lemma surj_atom_map: "Y \<subseteq> Collect atom \<Longrightarrow> Y = atom_map (\<Squnion>Y)"
proof
  assume "Y \<subseteq> Collect atom"
  thus "Y \<subseteq> atom_map (\<Squnion>Y)"
    using Sup_upper atom_map_def by force
next
  assume "Y \<subseteq> Collect atom"
  hence a: "\<forall>y. y \<in> Y \<longrightarrow> atom y"
    by blast
  {fix z
  assume h: "z \<in> Collect atom - Y"
  hence "\<forall>y \<in> Y. y \<sqinter> z = \<bottom>"
    by (metis DiffE a h atom_def dual_order.not_eq_order_implies_strict inf.absorb_iff2 inf_le2 meet_shunt mem_Collect_eq)
  hence "\<Squnion>Y \<sqinter> z = \<bottom>"
    using Sup_least meet_shunt by simp
  hence "z \<notin> atom_map (\<Squnion>Y)"
    using atom_map_bot_pres atom_map_def by force}
  thus  "atom_map (\<Squnion>Y) \<subseteq> Y"
    using atom_map_def by force
qed

text \<open>In this setting, atom-map is a complete boolean algebra morphism.\<close>

lemma atom_map_Sup_pres: "atom_map (\<Squnion>X) = (\<Union>x \<in> X. atom_map x)"
proof-
  {fix z
  have "(z \<in> atom_map (\<Squnion>X)) = (atom z \<and> z \<le> \<Squnion>X)"
    by (simp add: atom_map_def)
  also have "... = (atom z \<and> (\<exists>x \<in> X. z \<le> x))"
    using atom_Sup_iff by auto
  also have "... = (z \<in> (\<Union>x \<in> X. atom_map x))"
    using atom_map_def by auto
  finally have "(z \<in> atom_map (\<Squnion>X)) = (z \<in> (\<Union>x \<in> X. atom_map x))"
    by blast}
  thus ?thesis
    by blast
qed

lemma atom_map_Sup_pres_var: "atom_map \<circ> Sup = Sup \<circ> (`) atom_map"
  unfolding fun_eq_iff comp_def by (simp add: atom_map_Sup_pres)

text \<open>For Inf-preservation, it is important that Infs are restricted to homomorphic images;
hence they need to be pushed into the set of all atoms.\<close>

lemma atom_map_Inf_pres: "atom_map (\<Sqinter>X) = Collect atom \<inter> (\<Inter>x \<in> X. atom_map x)"
proof-
  have "atom_map (\<Sqinter>X) = atom_map (-(\<Squnion>x \<in> X. -x))"
    by (smt Collect_cong SUP_le_iff atom_map_def compl_le_compl_iff compl_le_swap1 le_Inf_iff)
  also have "... = Collect atom - atom_map (\<Squnion>x \<in> X. -x)"
    using atom_map_compl_pres by blast
  also have "... = Collect atom - (\<Union>x \<in> X. atom_map (-x))"
    by (simp add: atom_map_Sup_pres)
  also have "... = Collect atom - (\<Union>x \<in> X. Collect atom - atom_map (x))"
    using atom_map_compl_pres by blast
  also have "... = Collect atom \<inter> (\<Inter>x \<in> X. atom_map x)"
    by blast
  finally show ?thesis.
qed

end

text \<open>It follows that homomorphic images of complete boolean algebras under atom-map form
complete boolean algebras.\<close>

instantiation atoms :: (complete_boolean_algebra_alt) complete_boolean_algebra_alt
begin

lift_definition Inf_atoms :: "'a::complete_boolean_algebra_alt atoms set \<Rightarrow> 'a::complete_boolean_algebra_alt atoms" is "\<lambda>X. Abs_atoms (Collect atom \<inter> Inter ((`) Rep_atoms X))".

lift_definition  Sup_atoms :: "'a::complete_boolean_algebra_alt atoms set \<Rightarrow> 'a::complete_boolean_algebra_alt atoms" is "\<lambda>X. Abs_atoms (Union ((`) Rep_atoms X))".

instance
  apply (intro_classes; transfer)
       apply (metis (no_types, hide_lams) Abs_atoms_inverse image_iff inf_le1 le_Inf_iff le_infI2 order_refl rangeI surj_atom_map)
      apply (metis (no_types, lifting) Abs_atoms_inverse Int_subset_iff Rep_atoms Sup_upper atom_map_atoms inf_le1 le_INF_iff rangeI surj_atom_map)
     apply (metis Abs_atoms_inverse Rep_atoms SUP_least SUP_upper Sup_upper atom_map_atoms rangeI surj_atom_map)
    apply (metis Abs_atoms_inverse Rep_atoms SUP_least Sup_upper atom_map_atoms rangeI surj_atom_map)
  by simp_all

end

text \<open>Once more, properties proved above can now be restricted to at-map.\<close>

lemma  surj_at_map_var: "at_map \<circ> Sup \<circ> Rep_atoms = (id::'a::complete_boolean_algebra_alt atoms \<Rightarrow> 'a atoms)"
  unfolding at_map_def comp_def fun_eq_iff id_def by (metis Rep_atoms Rep_atoms_inverse Sup_upper atom_map_atoms surj_atom_map)

lemma surj_at_map: "surj (at_map::'a::complete_boolean_algebra_alt \<Rightarrow> 'a atoms)"
  unfolding surj_def at_map_def comp_def by (metis Rep_atoms Rep_atoms_inverse image_iff)

lemma at_map_Sup_pres_var: "at_map (\<Squnion>X) = (\<Squnion>(x::'a::complete_boolean_algebra_alt) \<in> X. (at_map x))"
  using at_map_Sup_pres comp_eq_elim by blast

lemma at_map_Inf_pres: "at_map (\<Sqinter>X) = Abs_atoms (Collect atom \<sqinter> (\<Sqinter>x \<in> X. (Rep_atoms (at_map (x::'a::complete_boolean_algebra_alt)))))"
  unfolding at_map_def comp_def by (metis (no_types, lifting) Abs_atoms_inverse Sup.SUP_cong atom_map_Inf_pres rangeI)

lemma at_map_Inf_pres_var: "at_map \<circ> Inf = Inf \<circ> (`) (at_map::'a::complete_boolean_algebra_alt \<Rightarrow> 'a atoms)"
  unfolding fun_eq_iff comp_def by (metis Inf_atoms.abs_eq at_map_Inf_pres image_image)

text \<open>Finally, on complete atomic boolean algebras (CABAs), at-map is an isomorphism, that is, a bijection
that preserves the complete boolean algebra operations. Thus every CABA is isomorphic to a powerset boolean algebra
and every powerset boolean algebra is a CABA. The bijective pair is given by at-map and Sup (defined on the powerset algebra).
This theorem is a little version of Stone's theorem. In the general case, ultrafilters play the role of atoms.\<close>

lemma "Sup \<circ> atom_map = (id::'a::complete_atomic_boolean_algebra \<Rightarrow> 'a)"
  unfolding fun_eq_iff comp_def id_def
  by (metis Union_upper atom_map_atoms inj_atom_map inj_def rangeI surj_atom_map)

lemma inj_at_map_var: "Sup \<circ> Rep_atoms \<circ> at_map  = (id ::'a::complete_atomic_boolean_algebra \<Rightarrow> 'a)"

  unfolding at_map_def comp_def fun_eq_iff id_def
  by (metis Abs_atoms_inverse Union_upper atom_map_atoms inj_atom_map inj_def rangeI surj_atom_map)

lemma bij_at_map: "bij (at_map::'a::complete_atomic_boolean_algebra \<Rightarrow> 'a atoms)"
  unfolding bij_def by (simp add: inj_at_map surj_at_map)

instance atoms :: (complete_atomic_boolean_algebra) complete_atomic_boolean_algebra..

text \<open>A full consideration of Stone duality is left for future work.\<close>

(* Failed attempt to prove Tarski's fixpoint theorem: The problem is that we want to use mono, but this has two type parameters. It doesn't work inside of the one-type-parameter typedef.
Yet isotonicity is needed to prove inhabitance of the type. I could develop a theory of isotone endos and prove the existence of
lfps and gfps, duplicating the more general facts for mono. But that's not the point. Because of this I see no direct way of proving
Tarski's fixpoint theorem. Any way out?

class complete_lattice_with_iso = complete_lattice +
  fixes f :: "'a \<Rightarrow> 'a"
(*  assumes isof: "x \<le> y \<Longrightarrow> f x \<le> f y"*)

typedef (overloaded) 'a Fix = "Fix (f::'a::complete_lattice_with_iso \<Rightarrow> 'a)"

setup_lifting type_definition_Fix

*)

end