(*  Title:       Binary Search Trees, Isar-Style
    Author:      Viktor Kuncak, MIT CSAIL, November 2003
    Maintainer:  Larry Paulson <Larry.Paulson at cl.cam.ac.uk>
    License:     LGPL
*)

header {* Isar-style Reasoning for Binary Tree Operations *}
theory BinaryTree imports Main begin

text {* We prove correctness of operations on
 binary search tree implementing a set.

 This document is LGPL.

 Author: Viktor Kuncak, MIT CSAIL, November 2003 *}

(*============================================================*)
section {* Tree Definition *}
(*============================================================*)

datatype 'a Tree = Tip | T "'a Tree" 'a "'a Tree"

primrec
  setOf :: "'a Tree => 'a set"
  -- {* set abstraction of a tree *}
where
  "setOf Tip = {}"
| "setOf (T t1 x t2) = (setOf t1) Un (setOf t2) Un {x}"

type_synonym
  -- {* we require index to have an irreflexive total order < *}
  -- {* apart from that, we do not rely on index being int *}
  index = int

type_synonym -- {* hash function type *}
  'a hash = "'a => index"

definition eqs :: "'a hash => 'a => 'a set" where
  -- {* equivalence class of elements with the same hash code *}
  "eqs h x == {y. h y = h x}"

primrec
  sortedTree :: "'a hash => 'a Tree => bool"
  -- {* check if a tree is sorted *}
where
  "sortedTree h Tip = True"
| "sortedTree h (T t1 x t2) =
    (sortedTree h t1 &
     (ALL l: setOf t1. h l < h x) &
     (ALL r: setOf t2. h x < h r) &
     sortedTree h t2)"

lemma sortLemmaL:
  "sortedTree h (T t1 x t2) ==> sortedTree h t1" by simp
lemma sortLemmaR:
  "sortedTree h (T t1 x t2) ==> sortedTree h t2" by simp

(*============================================================*)
section {* Tree Lookup *}
(*============================================================*)

primrec
  tlookup :: "'a hash => index => 'a Tree => 'a option"
where
  "tlookup h k Tip = None"
| "tlookup h k (T t1 x t2) =
   (if k < h x then tlookup h k t1
    else if h x < k then tlookup h k t2
    else Some x)"

lemma tlookup_some:
     "sortedTree h t & (tlookup h k t = Some x) --> x:setOf t & h x = k"
apply (induct t)
  --{*Just auto will do it, but very slowly*}
apply (simp)
apply (clarify, auto)
apply (simp_all split: split_if_asm)
done

definition sorted_distinct_pred :: "'a hash => 'a => 'a => 'a Tree => bool" where
  -- {* No two elements have the same hash code *}
  "sorted_distinct_pred h a b t == sortedTree h t &
      a:setOf t & b:setOf t & h a = h b -->
      a = b"

declare sorted_distinct_pred_def [simp]

-- {* for case analysis on three cases *}
lemma cases3: "[| C1 ==> G; C2 ==> G; C3 ==> G;
                  C1 | C2 | C3 |] ==> G"
by auto

text {* @{term sorted_distinct_pred} holds for out trees: *}

lemma sorted_distinct: "sorted_distinct_pred h a b t" (is "?P t")
proof (induct t)
  show "?P Tip" by simp
  fix t1 :: "'a Tree" assume h1: "?P t1"
  fix t2 :: "'a Tree" assume h2: "?P t2"
  fix x :: 'a
  show "?P (T t1 x t2)"
  proof (unfold sorted_distinct_pred_def, safe)
    assume s: "sortedTree h (T t1 x t2)"
    assume adef: "a : setOf (T t1 x t2)"
    assume bdef: "b : setOf (T t1 x t2)"
    assume hahb: "h a = h b"
    from s have s1: "sortedTree h t1" by auto
    from s have s2: "sortedTree h t2" by auto
    show "a = b"
    -- {* We consider 9 cases for the position of a and b are in the tree *}
    proof -
    -- {* three cases for a *}
    from adef have "a : setOf t1 | a = x | a : setOf t2" by auto
    moreover { assume adef1: "a : setOf t1"
      have ?thesis
      proof -
      -- {* three cases for b *}
      from bdef have "b : setOf t1 | b = x | b : setOf t2" by auto
      moreover { assume bdef1: "b : setOf t1"
        from s1 adef1 bdef1 hahb h1 have ?thesis by simp }
      moreover { assume bdef1: "b = x"
        from adef1 bdef1 s have "h a < h b" by auto
        from this hahb have ?thesis by simp }
      moreover { assume bdef1: "b : setOf t2"
        from adef1 s have o1: "h a < h x" by auto
        from bdef1 s have o2: "h x < h b" by auto
        from o1 o2 have "h a < h b" by simp
        from this hahb have ?thesis by simp } -- {* case impossible *}
      ultimately show ?thesis by blast
      qed
    }
    moreover { assume adef1: "a = x"
      have ?thesis
      proof -
      -- {* three cases for b *}
      from bdef have "b : setOf t1 | b = x | b : setOf t2" by auto
      moreover { assume bdef1: "b : setOf t1"
        from this s have "h b < h x" by auto
        from this adef1 have "h b < h a" by auto
        from hahb this have ?thesis by simp } -- {* case impossible *}
      moreover { assume bdef1: "b = x"
        from adef1 bdef1 have ?thesis by simp }
      moreover { assume bdef1: "b : setOf t2"
        from this s have "h x < h b" by auto
        from this adef1 have "h a < h b" by simp
        from hahb this have ?thesis by simp } -- {* case impossible *}
      ultimately show ?thesis by blast
      qed
    }
    moreover { assume adef1: "a : setOf t2"
      have ?thesis
      proof -
      -- {* three cases for b *}
      from bdef have "b : setOf t1 | b = x | b : setOf t2" by auto
      moreover { assume bdef1: "b : setOf t1"
        from bdef1 s have o1: "h b < h x" by auto
        from adef1 s have o2: "h x < h a" by auto
        from o1 o2 have "h b < h a" by simp
        from this hahb have ?thesis by simp } -- {* case impossible *}
      moreover { assume bdef1: "b = x"
        from adef1 bdef1 s have "h b < h a" by auto
        from this hahb have ?thesis by simp } -- {* case impossible *}
      moreover { assume bdef1: "b : setOf t2"
        from s2 adef1 bdef1 hahb h2 have ?thesis by simp }
      ultimately show ?thesis by blast
      qed
    }
    ultimately show ?thesis by blast
    qed
  qed
qed

lemma tlookup_finds: -- {* if a node is in the tree, lookup finds it *}
"sortedTree h t & y:setOf t -->
 tlookup h (h y) t = Some y"
proof safe
  assume s: "sortedTree h t"
  assume yint: "y : setOf t"
  show "tlookup h (h y) t = Some y"
  proof (cases "tlookup h (h y) t")
  case None note res = this
    from s res have "sortedTree h t & (tlookup h (h y) t = None)" by simp
    from this have o1: "ALL x:setOf t. h x ~= h y" by (simp add: tlookup_none)
    from o1 yint have "h y ~= h y" by fastforce (* auto does not work *)
    from this show ?thesis by simp
  next case (Some z) note res = this
    have ls: "sortedTree h t & (tlookup h (h y) t = Some z) -->
              z:setOf t & h z = h y" by (simp add: tlookup_some)
    have sd: "sorted_distinct_pred h y z t"
    by (insert sorted_distinct [of h y z t], simp)
       (* for some reason simplifier would never guess this substitution *)
    from s res ls have o1: "z:setOf t & h z = h y" by simp
    from s yint o1 sd have "y = z" by auto
    from this res show "tlookup h (h y) t = Some y" by simp
  qed
qed

subsection {* Tree membership as a special case of lookup *}

definition memb :: "'a hash => 'a => 'a Tree => bool" where
  "memb h x t ==
   (case (tlookup h (h x) t) of
      None => False
    | Some z => (x=z))"

lemma assumes s: "sortedTree h t"
      shows memb_spec: "memb h x t = (x : setOf t)"
proof (cases "tlookup h (h x) t")
case None note tNone = this
  from tNone have res: "memb h x t = False" by (simp add: memb_def)
  from s tNone tlookup_none have o1: "ALL y:setOf t. h y ~= h x" by fastforce
  have notIn: "x ~: setOf t"
  proof
    assume h: "x : setOf t"
    from h o1 have "h x ~= h x" by fastforce
    from this show False by simp
  qed
  from res notIn show ?thesis by simp
next case (Some z) note tSome = this
  from s tSome tlookup_some have zin: "z : setOf t" by fastforce
  show ?thesis
  proof (cases "x=z")
  case True note xez = this
    from tSome xez have res: "memb h x t" by (simp add: memb_def)
    from res zin xez show ?thesis by simp
  next case False note xnez = this
    from tSome xnez have res: "~ memb h x t" by (simp add: memb_def)
    have "x ~: setOf t"
    proof
      assume xin: "x : setOf t"
      from s tSome tlookup_some have hzhx: "h x = h z" by fastforce
      have o1: "sorted_distinct_pred h x z t"
      by (insert sorted_distinct [of h x z t], simp)
      from s xin zin hzhx o1 have "x = z" by fastforce
      from this xnez show False by simp
    qed
    from this res show ?thesis by simp
  qed
qed

declare sorted_distinct_pred_def [simp del]

(*============================================================*)
section {* Insertion into a Tree *}
(*============================================================*)

primrec
  binsert :: "'a hash => 'a => 'a Tree => 'a Tree"
where
  "binsert h e Tip = (T Tip e Tip)"
| "binsert h e (T t1 x t2) = (if h e < h x then
                             (T (binsert h e t1) x t2)
                            else
                             (if h x < h e then
                               (T t1 x (binsert h e t2))
                              else (T t1 e t2)))"

text {* A technique for proving disjointness of sets. *}
lemma disjCond: "[| !! x. [| x:A; x:B |] ==> False |] ==> A Int B = {}"
by fastforce

text {* The following is a proof that insertion correctly implements
        the set interface.
        Compared to @{text BinaryTree_TacticStyle}, the claim is more
        difficult, and this time we need to assume as a hypothesis
        that the tree is sorted. *}

text {* Using the correctness of set implementation,
        preserving sortedness is still simple. *}
lemma binsert_sorted: "sortedTree h t --> sortedTree h (binsert h x t)"
by (induct t) (auto simp add: binsert_set)

text {* We summarize the specification of binsert as follows. *}
corollary binsert_spec: "sortedTree h t -->
                     sortedTree h (binsert h x t) &
                     setOf (binsert h e t) = (setOf t) - (eqs h e) Un {e}"
by (simp add: binsert_set binsert_sorted)

(*============================================================*)
section {* Removing an element from a tree *}
(*============================================================*)

text {* These proofs are influenced by those in @{text BinaryTree_Tactic} *}

primrec
  rm :: "'a hash => 'a Tree => 'a"
  -- {* rightmost element of a tree *}
where
"rm h (T t1 x t2) =
  (if t2=Tip then x else rm h t2)"

primrec
  wrm :: "'a hash => 'a Tree => 'a Tree"
  -- {* tree without the rightmost element *}
where
"wrm h (T t1 x t2) =
  (if t2=Tip then t1 else (T t1 x (wrm h t2)))"

primrec
  wrmrm :: "'a hash => 'a Tree => 'a Tree * 'a"
  -- {* computing rightmost and removal in one pass *}
where
"wrmrm h (T t1 x t2) =
  (if t2=Tip then (t1,x)
   else (T t1 x (fst (wrmrm h t2)),
         snd (wrmrm h t2)))"

primrec
  remove :: "'a hash => 'a => 'a Tree => 'a Tree"
   -- {* removal of an element from the tree *}
where
  "remove h e Tip = Tip"
| "remove h e (T t1 x t2) =
    (if h e < h x then (T (remove h e t1) x t2)
     else if h x < h e then (T t1 x (remove h e t2))
     else (if t1=Tip then t2
           else let (t1p,r) = wrmrm h t1
                in (T t1p r t2)))"

theorem wrmrm_decomp: "t ~= Tip --> wrmrm h t = (wrm h t, rm h t)"
apply (induct_tac t)
apply simp_all
done

lemma rm_set: "t ~= Tip & sortedTree h t --> rm h t : setOf t"
apply (induct_tac t)
apply simp_all
done

lemma wrm_set: "t ~= Tip & sortedTree h t -->
                setOf (wrm h t) = setOf t - {rm h t}" (is "?P t")
proof (induct t)
  show "?P Tip" by simp
  fix t1 :: "'a Tree" assume h1: "?P t1"
  fix t2 :: "'a Tree" assume h2: "?P t2"
  fix x :: 'a
  show "?P (T t1 x t2)"
  proof (rule impI, erule conjE)
    assume s: "sortedTree h (T t1 x t2)"
    show "setOf (wrm h (T t1 x t2)) =
          setOf (T t1 x t2) - {rm h (T t1 x t2)}"
    proof (cases "t2 = Tip")
    case True note t2tip = this
      from t2tip have rm_res: "rm h (T t1 x t2) = x" by simp
      from t2tip have wrm_res: "wrm h (T t1 x t2) = t1" by simp
      from s have "x ~: setOf t1" by auto
      from this rm_res wrm_res t2tip show ?thesis by simp
    next case False note t2nTip = this
      from t2nTip have rm_res: "rm h (T t1 x t2) = rm h t2" by simp
      from t2nTip have wrm_res: "wrm h (T t1 x t2) = T t1 x (wrm h t2)" by simp
      from s have s2: "sortedTree h t2" by simp
      from h2 t2nTip s2
      have o1: "setOf (wrm h t2) = setOf t2 - {rm h t2}" by simp
      show ?thesis
      proof (simp add: rm_res wrm_res t2nTip h2 o1)
        show "insert x (setOf t1 Un (setOf t2 - {rm h t2})) =
              insert x (setOf t1 Un setOf t2) - {rm h t2}"
        proof -
          from s rm_set t2nTip have xOk: "h x < h (rm h t2)" by auto
          have t1Ok: "ALL l:setOf t1. h l < h (rm h t2)"
          proof safe
            fix l :: 'a  assume ldef: "l : setOf t1"
            from ldef s have lx: "h l < h x" by auto
            from lx xOk show "h l < h (rm h t2)" by auto
          qed
          from xOk t1Ok show ?thesis by auto
        qed
      qed
    qed
  qed
qed

lemma wrm_set1: "t ~= Tip & sortedTree h t --> setOf (wrm h t) <= setOf t"
by (auto simp add: wrm_set)

lemma wrm_sort: "t ~= Tip & sortedTree h t --> sortedTree h (wrm h t)" (is "?P t")
proof (induct t)
  show "?P Tip" by simp
  fix t1 :: "'a Tree" assume h1: "?P t1"
  fix t2 :: "'a Tree" assume h2: "?P t2"
  fix x :: 'a
  show "?P (T t1 x t2)"
  proof safe
    assume s: "sortedTree h (T t1 x t2)"
    show "sortedTree h (wrm h (T t1 x t2))"
    proof (cases "t2 = Tip")
    case True note t2tip = this
      from t2tip have res: "wrm h (T t1 x t2) = t1" by simp
      from res s show ?thesis by simp
    next case False note t2nTip = this
      from t2nTip have res: "wrm h (T t1 x t2) = T t1 x (wrm h t2)" by simp
      from s have s1: "sortedTree h t1" by simp
      from s have s2: "sortedTree h t2" by simp
      from s2 h2 t2nTip have o1: "sortedTree h (wrm h t2)" by simp
      from s2 t2nTip wrm_set1 have o2: "setOf (wrm h t2) <= setOf t2" by auto
      from s o2 have o3: "ALL r: setOf (wrm h t2). h x < h r" by auto
      from s1 o1 o3 res s show "sortedTree h (wrm h (T t1 x t2))" by simp
    qed
  qed
qed

lemma wrm_less_rm:
  "t ~= Tip & sortedTree h t -->
   (ALL l:setOf (wrm h t). h l < h (rm h t))" (is "?P t")
proof (induct t)
  show "?P Tip" by simp
  fix t1 :: "'a Tree" assume h1: "?P t1"
  fix t2 :: "'a Tree" assume h2: "?P t2"
  fix x :: 'a
  show "?P (T t1 x t2)"
  proof safe
    fix l :: "'a" assume ldef: "l : setOf (wrm h (T t1 x t2))"
    assume s: "sortedTree h (T t1 x t2)"
    from s have s1: "sortedTree h t1" by simp
    from s have s2: "sortedTree h t2" by simp
    show "h l < h (rm h (T t1 x t2))"
    proof (cases "t2 = Tip")
    case True note t2tip = this
      from t2tip have rm_res: "rm h (T t1 x t2) = x" by simp
      from t2tip have wrm_res: "wrm h (T t1 x t2) = t1" by simp
      from ldef wrm_res have o1: "l : setOf t1" by simp
      from rm_res o1 s show ?thesis by simp
    next case False note t2nTip = this
      from t2nTip have rm_res: "rm h (T t1 x t2) = rm h t2" by simp
      from t2nTip have wrm_res: "wrm h (T t1 x t2) = T t1 x (wrm h t2)" by simp
      from ldef wrm_res
      have l_scope: "l : {x} Un setOf t1 Un setOf (wrm h t2)" by simp
      have hLess: "h l < h (rm h t2)"
      proof (cases "l = x")
      case True note lx = this
        from s t2nTip rm_set s2 have o1: "h x < h (rm h t2)" by auto
        from lx o1 show ?thesis by simp
      next case False note lnx = this
        show ?thesis
        proof (cases "l : setOf t1")
        case True note l_in_t1 = this
          from s t2nTip rm_set s2 have o1: "h x < h (rm h t2)" by auto
          from l_in_t1 s have o2: "h l < h x" by auto
          from o1 o2 show ?thesis by simp
        next case False note l_notin_t1 = this
          from l_scope lnx l_notin_t1
          have l_in_res: "l : setOf (wrm h t2)" by auto
          from l_in_res h2 t2nTip s2 show ?thesis by auto
        qed
      qed
      from rm_res hLess show ?thesis by simp
    qed
  qed
qed

lemma remove_set: "sortedTree h t -->
  setOf (remove h e t) = setOf t - eqs h e" (is "?P t")
proof (induct t)
  show "?P Tip" by auto
  fix t1 :: "'a Tree" assume h1: "?P t1"
  fix t2 :: "'a Tree" assume h2: "?P t2"
  fix x :: 'a
  show "?P (T t1 x t2)"
  proof
    assume s: "sortedTree h (T t1 x t2)"
    show "setOf (remove h e (T t1 x t2)) = setOf (T t1 x t2) - eqs h e"
    proof (cases "h e < h x")
    case True note elx = this
      from elx have res: "remove h e (T t1 x t2) = T (remove h e t1) x t2"
      by simp
      from s have s1: "sortedTree h t1" by simp
      from s1 h1 have o1: "setOf (remove h e t1) = setOf t1 - eqs h e" by simp
      show ?thesis
      proof (simp add: o1 elx)
        show "insert x (setOf t1 - eqs h e Un setOf t2) =
              insert x (setOf t1 Un setOf t2) - eqs h e"
        proof -
          have xOk: "x ~: eqs h e"
          proof
            assume h: "x : eqs h e"
            from h have o1: "~ (h e < h x)" by (simp add: eqs_def)
            from elx o1 show "False" by contradiction
          qed
          have t2Ok: "(setOf t2) Int (eqs h e) = {}"
          proof (rule disjCond)
            fix y :: 'a
            assume y_in_t2: "y : setOf t2"
            assume y_in_eq: "y : eqs h e"
            from y_in_t2 s have xly: "h x < h y" by auto
            from y_in_eq have eey: "h y = h e" by (simp add: eqs_def) (* must "add:" not "from" *)
            from xly eey have nelx: "~ (h e < h x)" by simp
            from nelx elx show False by contradiction
          qed
          from xOk t2Ok show ?thesis by auto
        qed
      qed
    next case False note nelx = this
      show ?thesis
      proof (cases "h x < h e")
      case True note xle = this
        from xle have res: "remove h e (T t1 x t2) = T t1 x (remove h e t2)" by simp
        from s have s2: "sortedTree h t2" by simp
        from s2 h2 have o1: "setOf (remove h e t2) = setOf t2 - eqs h e" by simp
        show ?thesis
        proof (simp add: o1 xle nelx)
          show "insert x (setOf t1 Un (setOf t2 - eqs h e)) =
                insert x (setOf t1 Un setOf t2) - eqs h e"
          proof -
            have xOk: "x ~: eqs h e"
            proof
              assume h: "x : eqs h e"
              from h have o1: "~ (h x < h e)" by (simp add: eqs_def)
              from xle o1 show "False" by contradiction
            qed
            have t1Ok: "(setOf t1) Int (eqs h e) = {}"
            proof (rule disjCond)
              fix y :: 'a
              assume y_in_t1: "y : setOf t1"
              assume y_in_eq: "y : eqs h e"
              from y_in_t1 s have ylx: "h y < h x" by auto
              from y_in_eq have eey: "h y = h e" by (simp add: eqs_def)
              from ylx eey have nxle: "~ (h x < h e)" by simp
              from nxle xle show False by contradiction
            qed
            from xOk t1Ok show ?thesis by auto
          qed
        qed
      next case False note nxle = this
        from nelx nxle have ex: "h e = h x" by simp
        have t2Ok: "(setOf t2) Int (eqs h e) = {}"
        proof (rule disjCond)
          fix y :: 'a
          assume y_in_t2: "y : setOf t2"
          assume y_in_eq: "y : eqs h e"
          from y_in_t2 s have xly: "h x < h y" by auto
          from y_in_eq have eey: "h y = h e" by (simp add: eqs_def)
          from y_in_eq ex eey have nxly: "~ (h x < h y)" by simp
          from nxly xly show False by contradiction
        qed
        show ?thesis
        proof (cases "t1 = Tip")
        case True note t1tip = this
          from ex t1tip have res: "remove h e (T t1 x t2) = t2" by simp
          show ?thesis
          proof (simp add: res t1tip ex)
            show "setOf t2 = insert x (setOf t2) - eqs h e"
            proof -
              from ex have x_in_eqs: "x : eqs h e" by (simp add: eqs_def)
              from x_in_eqs t2Ok show ?thesis by auto
           qed
          qed
        next case False note t1nTip = this
          from nelx nxle ex t1nTip
          have res: "remove h e (T t1 x t2) =
                     T (wrm h t1) (rm h t1) t2"
          by (simp add: Let_def wrmrm_decomp)
          from res show ?thesis
          proof simp
            from s have s1: "sortedTree h t1" by simp
            show "insert (rm h t1) (setOf (wrm h t1) Un setOf t2) =
                  insert x (setOf t1 Un setOf t2) - eqs h e"
            proof (simp add: t1nTip s1 rm_set wrm_set)
              show "insert (rm h t1) (setOf t1 - {rm h t1} Un setOf t2) =
                    insert x (setOf t1 Un setOf t2) - eqs h e"
              proof -
                from t1nTip s1 rm_set
                have o1: "insert (rm h t1) (setOf t1 - {rm h t1} Un setOf t2) =
                          setOf t1 Un setOf t2" by auto
                have o2: "insert x (setOf t1 Un setOf t2) - eqs h e =
                          setOf t1 Un setOf t2"
                proof -
                  from ex have xOk: "x : eqs h e" by (simp add: eqs_def)
                  have t1Ok: "(setOf t1) Int (eqs h e) = {}"
                  proof (rule disjCond)
                    fix y :: 'a
                    assume y_in_t1: "y : setOf t1"
                    assume y_in_eq: "y : eqs h e"
                    from y_in_t1 s ex have o1: "h y < h e" by auto
                    from y_in_eq have o2: "~ (h y < h e)" by (simp add: eqs_def)
                    from o1 o2 show False by contradiction
                  qed
                  from xOk t1Ok t2Ok show ?thesis by auto
                qed
                from o1 o2 show ?thesis by simp
              qed
            qed
          qed
        qed
      qed
    qed
  qed
qed

lemma remove_sort: "sortedTree h t -->
                    sortedTree h (remove h e t)" (is "?P t")
proof (induct t)
  show "?P Tip" by auto
  fix t1 :: "'a Tree" assume h1: "?P t1"
  fix t2 :: "'a Tree" assume h2: "?P t2"
  fix x :: 'a
  show "?P (T t1 x t2)"
  proof
    assume s: "sortedTree h (T t1 x t2)"
    from s have s1: "sortedTree h t1" by simp
    from s have s2: "sortedTree h t2" by simp
    from h1 s1 have sr1: "sortedTree h (remove h e t1)" by simp
    from h2 s2 have sr2: "sortedTree h (remove h e t2)" by simp
    show "sortedTree h (remove h e (T t1 x t2))"
    proof (cases "h e < h x")
    case True note elx = this
      from elx have res: "remove h e (T t1 x t2) = T (remove h e t1) x t2"
      by simp
      show ?thesis
      proof (simp add: s sr1 s2 elx res)
        let ?C1 = "ALL l:setOf (remove h e t1). h l < h x"
        let ?C2 = "ALL r:setOf t2. h x < h r"
        have o1: "?C1"
        proof -
          from s1 have "setOf (remove h e t1) = setOf t1 - eqs h e" by (simp add: remove_set)
          from s this show ?thesis by auto
        qed
        from o1 s show "?C1 & ?C2" by auto
      qed
    next case False note nelx = this
      show ?thesis
      proof (cases "h x < h e")
      case True note xle = this
        from xle have res: "remove h e (T t1 x t2) = T t1 x (remove h e t2)" by simp
        show ?thesis
        proof (simp add: s s1 sr2 xle nelx res)
          let ?C1 = "ALL l:setOf t1. h l < h x"
          let ?C2 = "ALL r:setOf (remove h e t2). h x < h r"
          have o2: "?C2"
          proof -
            from s2 have "setOf (remove h e t2) = setOf t2 - eqs h e" by (simp add: remove_set)
            from s this show ?thesis by auto
          qed
          from o2 s show "?C1 & ?C2" by auto
        qed
      next case False note nxle = this
        from nelx nxle have ex: "h e = h x" by simp
        show ?thesis
        proof (cases "t1 = Tip")
        case True note t1tip = this
          from ex t1tip have res: "remove h e (T t1 x t2) = t2" by simp
          show ?thesis by (simp add: res t1tip ex s2)
        next case False note t1nTip = this
          from nelx nxle ex t1nTip
          have res: "remove h e (T t1 x t2) =
                     T (wrm h t1) (rm h t1) t2"
          by (simp add: Let_def wrmrm_decomp)
          from res show ?thesis
          proof simp
            let ?C1 = "sortedTree h (wrm h t1)"
            let ?C2 = "ALL l:setOf (wrm h t1). h l < h (rm h t1)"
            let ?C3 = "ALL r:setOf t2. h (rm h t1) < h r"
            let ?C4 = "sortedTree h t2"
            from s1 t1nTip have o1: ?C1 by (simp add: wrm_sort)
            from s1 t1nTip have o2: ?C2 by (simp add: wrm_less_rm)
            have o3: ?C3
            proof
              fix r :: 'a
              assume rt2: "r : setOf t2"
              from s rm_set s1 t1nTip have o1: "h (rm h t1) < h x" by auto
              from rt2 s have o2: "h x < h r" by auto
              from o1 o2 show "h (rm h t1) < h r" by simp
            qed
            from o1 o2 o3 s2 show "?C1 & ?C2 & ?C3 & ?C4" by simp
          qed
        qed
      qed
    qed
  qed
qed

text {* We summarize the specification of remove as follows. *}
corollary remove_spec: "sortedTree h t -->
     sortedTree h (remove h e t) &
     setOf (remove h e t) = setOf t - eqs h e"
by (simp add: remove_sort remove_set)

definition "test = tlookup id 4 (remove id 3 (binsert id 4 (binsert id 3 Tip)))"

export_code test
  in SML module_name BinaryTree_Code file "BinaryTree_Code.ML"

end


header {* \isaheader{Examples from ITP-2010 slides (adopted to ICF v2)} *}
theory itp_2010
imports
  "../../ICF/Collections"
  "../../Lib/Code_Target_ICF"
begin

text {*
  Illustrates the various possibilities how to use the ICF in your own
  algorithms by simple examples. The examples all use the data refinement
  scheme, and either define a generic algorithm or fix the operations.
*}

subsection "List to Set"
text {*
  In this simple example we do conversion from a list to a set.
  We define an abstract algorithm.
  This is then refined by a generic algorithm using a locale and by a generic
  algorithm fixing its operations as parameters.
*}
  subsubsection "Straightforward version"
  -- "Abstract algorithm"
  fun set_a where
    "set_a [] s = s" |
    "set_a (a#l) s = set_a l (insert a s)"

  -- "Correctness of aa"
  lemma set_a_correct: "set_a l s = set l \<union> s"
    by (induct l arbitrary: s) auto

  -- "Generic algorithm"

  setup Locale_Code.open_block -- "Required to make definitions inside locales
    executable"
  fun (in StdSetDefs) set_i where
    "set_i [] s = s" |
    "set_i (a#l) s = set_i l (ins a s)"
  setup Locale_Code.close_block

  -- "Correct implementation of ca"
  lemma (in StdSet) set_i_impl: "invar s \<Longrightarrow> invar (set_i l s) \<and> \<alpha> (set_i l s) = set_a l (\<alpha> s)"
    by (induct l arbitrary: s) (auto simp add: correct)

  -- "Instantiation"
  (* We need to declare a constant to make the code generator work *)

  definition "hs_seti == hs.set_i"
  (*declare hs.set_i.simps[folded hs_seti_def, code]*)

  lemmas hs_set_i_impl = hs.set_i_impl[folded hs_seti_def]

export_code hs_seti in SML

  -- "Code generation"
  ML {* @{code hs_seti} *}
  (*value "hs_seti [1,2,3::nat] hs_empty"*)

  subsubsection "Tail-Recursive version"
  -- "Abstract algorithm"
  fun set_a2 where
    "set_a2 [] = {}" |
    "set_a2 (a#l) = (insert a (set_a2 l))"

  -- "Correctness of aa"
  lemma set_a2_correct: "set_a2 l = set l"
    by (induct l) auto

  -- "Generic algorithm"
  setup Locale_Code.open_block
  fun (in StdSetDefs) set_i2 where
    "set_i2 [] = empty ()" |
    "set_i2 (a#l) = (ins a (set_i2 l))"
  setup Locale_Code.close_block

  -- "Correct implementation of ca"
  lemma (in StdSet) set_i2_impl: "invar s \<Longrightarrow> invar (set_i2 l) \<and> \<alpha> (set_i2 l) = set_a2 l"
    by (induct l) (auto simp add: correct)

  -- "Instantiation"
  definition "hs_seti2 == hs.set_i2"
  (*declare hsr.set_i2.simps[folded hs_seti2_def, code]*)

  lemmas hs_set_i2_impl = hs.set_i2_impl[folded hs_seti2_def]

  -- "Code generation"
  ML {* @{code hs_seti2} *}
  (*value "hs_seti [1,2,3::nat] hs_empty"*)

subsubsection "With explicit operation parameters"

  -- "Alternative for few operation parameters"
  fun set_i' where
    "!!ins. set_i' ins [] s = s" |
    "!!ins. set_i' ins (a#l) s = set_i' ins l (ins a s)"

  lemma (in StdSet) set_i'_impl:
    "invar s \<Longrightarrow> invar (set_i' ins l s) \<and> \<alpha> (set_i' ins l s) = set_a l (\<alpha> s)"
    by (induct l arbitrary: s) (auto simp add: correct)

  -- "Instantiation"
  definition "hs_seti' == set_i' hs.ins"
  lemmas hs_set_i'_impl = hs.set_i'_impl[folded hs_seti'_def]

  -- "Code generation"
  ML {* @{code hs_seti'} *}
  (*value "hs_seti' [1,2,3::nat] hs_empty"*)

subsection "Filter Average"
text {*
  In this more complex example, we develop a function that filters from a set all
  numbers that are above the average of the set.

  First, we formulate this as a generic algorithm using a locale.
  This solution shows how the ICF v2 overcomes some technical problems that
  ICF v1 had:
  \begin{itemize}
    \item Iterators are now polymorphic in the type, even inside locales.
      Hence, there is no special handling of iterators, as it was required
      in ICF v1.
    \item The Locale-Code package handles code generation for the instantiated
      locale. There is no need for lengthy boilerplate code as it was required
      in ICF v1.
  \end{itemize}

  Another possibility is to fix the used
  implementations beforehand. Changing the implementation is still easy by
  changing the used operations. In this example, all used operations are
  introduced by abbbreviations, localizing the required changes to a small part
  of the theory. This approach is more powerful, as operations are now
  polymorphic also in the element type. However, it only allows as single
  instantiation at a time, which is no option for generic algorithms.
*}

  abbreviation "average S == \<Sum>S div card S"

subsubsection "Generic Algorithm"
  locale MyContext =
    StdSet ops for ops :: "(nat,'s,'more) set_ops_scheme"
  begin
    definition avg_aux :: "'s \<Rightarrow> nat\<times>nat"
      where
      "avg_aux s == iterate s (\<lambda>x (c,s). (c+1, s+x)) (0,0)"

    definition "avg s == case avg_aux s of (c,s) \<Rightarrow> s div c"

    definition "filter_le_avg s == let a=avg s in
      iterate s (\<lambda>x s. if x\<le>a then ins x s else s) (empty ())"

    lemma avg_aux_correct: "invar s \<Longrightarrow> avg_aux s = (card (\<alpha> s), \<Sum>(\<alpha> s) )"
      apply (unfold avg_aux_def)
      apply (rule_tac
        I="\<lambda>it (c,sum). c=card (\<alpha> s - it) \<and> sum=\<Sum>(\<alpha> s - it)"
        in iterate_rule_P)
      apply auto
      apply (subgoal_tac "\<alpha> s - (it - {x}) = insert x (\<alpha> s - it)")
      apply auto
      apply (subgoal_tac "\<alpha> s - (it - {x}) = insert x (\<alpha> s - it)")
      apply auto
      done

    lemma avg_correct: "invar s \<Longrightarrow> avg s = average (\<alpha> s)"
      unfolding avg_def
      using avg_aux_correct
      by auto

    lemma filter_le_avg_correct:
      "invar s \<Longrightarrow>
        invar (filter_le_avg s) \<and>
        \<alpha> (filter_le_avg s) = {x\<in>\<alpha> s. x\<le>average (\<alpha> s)}"
      unfolding filter_le_avg_def Let_def
      apply (rule_tac
        I="\<lambda>it r. invar r \<and> \<alpha> r = {x\<in>\<alpha> s - it. x\<le>average (\<alpha> s)}"
        in iterate_rule_P)
      apply (auto simp add: correct avg_correct)
      done
  end

  setup Locale_Code.open_block
  interpretation hs_ctx: MyContext hs_ops by unfold_locales
  interpretation rs_ctx: MyContext rs_ops by unfold_locales
  setup Locale_Code.close_block

  definition "hs_flt_avg_test \<equiv> hs.to_list
    o hs_ctx.filter_le_avg
    o hs.from_list"
  definition "rs_flt_avg_test \<equiv> rs.to_list
    o rs_ctx.filter_le_avg
    o rs.from_list"

  text "Code generation"
  ML_val {*
    if @{code hs_flt_avg_test} (map @{code nat_of_integer} [1,2,3,4,6,7])
    <> @{code rs_flt_avg_test} (map @{code nat_of_integer} [1,2,3,4,6,7])
    then error "Oops"
    else ()
    *}

subsubsection "Using abbreviations"

  type_synonym 'a my_set = "'a hs"
  abbreviation "my_\<alpha> == hs.\<alpha>"
  abbreviation "my_invar == hs.invar"
  abbreviation "my_empty == hs.empty"
  abbreviation "my_ins == hs.ins"
  abbreviation "my_iterate == hs.iteratei"
  lemmas my_correct = hs.correct
  lemmas my_iterate_rule_P = hs.iterate_rule_P

  definition avg_aux :: "nat my_set \<Rightarrow> nat\<times>nat"
    where
    "avg_aux s == my_iterate s (\<lambda>_. True) (\<lambda>x (c,s). (c+1, s+x)) (0,0)"

  definition "avg s == case avg_aux s of (c,s) \<Rightarrow> s div c"

  definition "filter_le_avg s == let a=avg s in
    my_iterate s (\<lambda>_. True) (\<lambda>x s. if x\<le>a then my_ins x s else s) (my_empty ())"

  lemma avg_aux_correct: "my_invar s \<Longrightarrow> avg_aux s = (card (my_\<alpha> s), \<Sum>(my_\<alpha> s) )"
    apply (unfold avg_aux_def)
    apply (rule_tac
      I="\<lambda>it (c,sum). c=card (my_\<alpha> s - it) \<and> sum=\<Sum>(my_\<alpha> s - it)"
      in my_iterate_rule_P)
    apply auto
    apply (subgoal_tac "my_\<alpha> s - (it - {x}) = insert x (my_\<alpha> s - it)")
    apply auto
    apply (subgoal_tac "my_\<alpha> s - (it - {x}) = insert x (my_\<alpha> s - it)")
    apply auto
    done

  lemma avg_correct: "my_invar s \<Longrightarrow> avg s = average (my_\<alpha> s)"
    unfolding avg_def
    using avg_aux_correct
    by auto

  lemma filter_le_avg_correct:
    "my_invar s \<Longrightarrow>
    my_invar (filter_le_avg s) \<and>
    my_\<alpha> (filter_le_avg s) = {x\<in>my_\<alpha> s. x\<le>average (my_\<alpha> s)}"
    unfolding filter_le_avg_def Let_def
    apply (rule_tac
      I="\<lambda>it r. my_invar r \<and> my_\<alpha> r = {x\<in>my_\<alpha> s - it. x\<le>average (my_\<alpha> s)}"
      in my_iterate_rule_P)
    apply (auto simp add: my_correct avg_correct)
    done

  definition "test_set == my_ins (1::nat) (my_ins 2 (my_ins 3 (my_empty ())))"

  export_code avg_aux avg filter_le_avg test_set in SML module_name Test

end


(*  Title:      HOL/Examples/Cantor.thy
    Author:     Makarius
*)

section \<open>Cantor's Theorem\<close>

theory Cantor
  imports Main
begin

subsection \<open>Mathematical statement and proof\<close>

text \<open>
  Cantor's Theorem states that there is no surjection from
  a set to its powerset.  The proof works by diagonalization.  E.g.\ see
  \<^item> \<^url>\<open>http://mathworld.wolfram.com/CantorDiagonalMethod.html\<close>
  \<^item> \<^url>\<open>https://en.wikipedia.org/wiki/Cantor's_diagonal_argument\<close>
\<close>

theorem Cantor: "\<nexists>f :: 'a \<Rightarrow> 'a set. \<forall>A. \<exists>x. A = f x"
proof
  assume "\<exists>f :: 'a \<Rightarrow> 'a set. \<forall>A. \<exists>x. A = f x"
  then obtain f :: "'a \<Rightarrow> 'a set" where *: "\<forall>A. \<exists>x. A = f x" ..
  let ?D = "{x. x \<notin> f x}"
  from * obtain a where "?D = f a" by blast
  moreover have "a \<in> ?D \<longleftrightarrow> a \<notin> f a" by blast
  ultimately show False by blast
qed

subsection \<open>Automated proofs\<close>

text \<open>
  These automated proofs are much shorter, but lack information why and how it
  works.
\<close>

theorem "\<nexists>f :: 'a \<Rightarrow> 'a set. \<forall>A. \<exists>x. f x = A"
  by best

theorem "\<nexists>f :: 'a \<Rightarrow> 'a set. \<forall>A. \<exists>x. f x = A"
  by force

subsection \<open>Elementary version in higher-order predicate logic\<close>

text \<open>
  The subsequent formulation bypasses set notation of HOL; it uses elementary
  \<open>\<lambda>\<close>-calculus and predicate logic, with standard introduction and elimination
  rules. This also shows that the proof does not require classical reasoning.
\<close>

lemma iff_contradiction:
  assumes *: "\<not> A \<longleftrightarrow> A"
  shows False
proof (rule notE)
  show "\<not> A"
  proof
    assume A
    with * have "\<not> A" ..
    from this and \<open>A\<close> show False ..
  qed
  with * show A ..
qed

theorem Cantor': "\<nexists>f :: 'a \<Rightarrow> 'a \<Rightarrow> bool. \<forall>A. \<exists>x. A = f x"
proof
  assume "\<exists>f :: 'a \<Rightarrow> 'a \<Rightarrow> bool. \<forall>A. \<exists>x. A = f x"
  then obtain f :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where *: "\<forall>A. \<exists>x. A = f x" ..
  let ?D = "\<lambda>x. \<not> f x x"
  from * have "\<exists>x. ?D = f x" ..
  then obtain a where "?D = f a" ..
  then have "?D a \<longleftrightarrow> f a a" by (rule arg_cong)
  then have "\<not> f a a \<longleftrightarrow> f a a" .
  then show False by (rule iff_contradiction)
qed

subsection \<open>Classic Isabelle/HOL example\<close>

text \<open>
  The following treatment of Cantor's Theorem follows the classic example from
  the early 1990s, e.g.\ see the file \<^verbatim>\<open>92/HOL/ex/set.ML\<close> in
  Isabelle92 or \<^cite>\<open>\<open>\S18.7\<close> in "paulson-isa-book"\<close>. The old tactic scripts
  synthesize key information of the proof by refinement of schematic goal
  states. In contrast, the Isar proof needs to say explicitly what is proven.

  \<^bigskip>
  Cantor's Theorem states that every set has more subsets than it has
  elements. It has become a favourite basic example in pure higher-order logic
  since it is so easily expressed:

  @{text [display]
  \<open>\<forall>f::\<alpha> \<Rightarrow> \<alpha> \<Rightarrow> bool. \<exists>S::\<alpha> \<Rightarrow> bool. \<forall>x::\<alpha>. f x \<noteq> S\<close>}

  Viewing types as sets, \<open>\<alpha> \<Rightarrow> bool\<close> represents the powerset of \<open>\<alpha>\<close>. This
  version of the theorem states that for every function from \<open>\<alpha>\<close> to its
  powerset, some subset is outside its range. The Isabelle/Isar proofs below
  uses HOL's set theory, with the type \<open>\<alpha> set\<close> and the operator \<open>range :: (\<alpha> \<Rightarrow>
  \<beta>) \<Rightarrow> \<beta> set\<close>.
\<close>

theorem "\<exists>S. S \<notin> range (f :: 'a \<Rightarrow> 'a set)"
proof
  let ?S = "{x. x \<notin> f x}"
  show "?S \<notin> range f"
  proof
    assume "?S \<in> range f"
    then obtain y where "?S = f y" ..
    then show False
    proof (rule equalityCE)
      assume "y \<in> f y"
      assume "y \<in> ?S"
      then have "y \<notin> f y" ..
      with \<open>y \<in> f y\<close> show ?thesis by contradiction
    next
      assume "y \<notin> ?S"
      assume "y \<notin> f y"
      then have "y \<in> ?S" ..
      with \<open>y \<notin> ?S\<close> show ?thesis by contradiction
    qed
  qed
qed

text \<open>
  How much creativity is required? As it happens, Isabelle can prove this
  theorem automatically using best-first search. Depth-first search would
  diverge, but best-first search successfully navigates through the large
  search space. The context of Isabelle's classical prover contains rules for
  the relevant constructs of HOL's set theory.
\<close>

theorem "\<exists>S. S \<notin> range (f :: 'a \<Rightarrow> 'a set)"
  by best

end


(*  Author:      Christian Sternagel <c.sternagel@gmail.com>
    Maintainer:  Christian Sternagel <c.sternagel@gmail.com>
*)
theory Mergesort_Complexity
  imports
    Efficient_Sort
    Complex_Main
begin

(*TODO: move?*)
lemma log2_mono:
  "x > 0 \<Longrightarrow> x \<le> y \<Longrightarrow> log 2 x \<le> log 2 y"
  by auto

section \<open>Counting the Number of Comparisons\<close>

context
  fixes key :: "'a \<Rightarrow> 'k::linorder"
begin

fun c_merge :: "'a list \<Rightarrow> 'a list \<Rightarrow> nat"
  where
    "c_merge (x # xs) (y # ys) =
      1 + (if key y < key x then c_merge (x # xs) ys else c_merge xs (y # ys))"
  | "c_merge [] ys = 0"
  | "c_merge xs [] = 0"

fun c_merge_pairs :: "'a list list \<Rightarrow> nat"
  where
    "c_merge_pairs (xs # ys # zss) = c_merge xs ys + c_merge_pairs zss"
  | "c_merge_pairs [] = 0"
  | "c_merge_pairs [x] = 0"

fun c_merge_all :: "'a list list \<Rightarrow> nat"
  where
    "c_merge_all [] = 0"
  | "c_merge_all [x] = 0"
  | "c_merge_all xss = c_merge_pairs xss + c_merge_all (merge_pairs key xss)"

fun c_sequences :: "'a list \<Rightarrow> nat"
  and c_asc :: "'a \<Rightarrow> 'a list \<Rightarrow> nat"
  and c_desc :: "'a \<Rightarrow> 'a list \<Rightarrow> nat"
  where
    "c_sequences (x # y # zs) = 1 + (if key y < key x then c_desc y zs else c_asc y zs)"
  | "c_sequences [] = 0"
  | "c_sequences [x] = 0"
  | "c_asc x (y # ys) = 1 + (if \<not> key y < key x then c_asc y ys else c_sequences (y # ys))"
  | "c_asc x [] = 0"
  | "c_desc x (y # ys) = 1 + (if key y < key x then c_desc y ys else c_sequences (y # ys))"
  | "c_desc x [] = 0"

fun c_msort :: "'a list \<Rightarrow> nat"
  where
    "c_msort xs = c_sequences xs + c_merge_all (sequences key xs)"

lemma c_merge:
  "c_merge xs ys \<le> length xs + length ys"
  by (induct xs ys rule: c_merge.induct) simp_all

lemma c_merge_pairs:
  "c_merge_pairs xss \<le> length (concat xss)"
proof (induct xss rule: c_merge_pairs.induct)
  case (1 xs ys zss)
  then show ?case using c_merge [of xs ys] by simp
qed simp_all

lemma c_merge_all:
  "c_merge_all xss \<le> length (concat xss) * \<lceil>log 2 (length xss)\<rceil>"
proof (induction xss rule: c_merge_all.induct)
  case (3 xs ys zss)
  let ?clen = "\<lambda>xs. length (concat xs)"
  let ?xss = "xs # ys # zss"
  let ?xss2 = "merge_pairs key ?xss"

  have *: "\<lceil>log 2 (real n + 2)\<rceil> = \<lceil>log 2 (Suc n div 2 + 1)\<rceil> + 1" for n :: nat
    using ceiling_log2_div2 [of "n + 2"] by (simp add: algebra_simps)

  have "c_merge_all ?xss = c_merge_pairs ?xss + c_merge_all ?xss2" by simp
  also have "\<dots> \<le> ?clen ?xss + c_merge_all ?xss2"
    using c_merge [of xs ys] and c_merge_pairs [of ?xss] by auto
  also have "\<dots> \<le> ?clen ?xss + ?clen ?xss2 * \<lceil>log 2 (length ?xss2)\<rceil>"
    using "3.IH" by simp
  also have "\<dots> \<le> ?clen ?xss * \<lceil>log 2 (length ?xss)\<rceil>"
    by (auto simp: * algebra_simps)
  finally show ?case by simp
qed simp_all

lemma
  shows c_sequences: "c_sequences xs \<le> length xs - 1"
    and c_asc: "c_asc x ys \<le> length ys"
    and c_desc: "c_desc x ys \<le> length ys"
  by (induct xs and x ys and x ys rule: c_sequences_c_asc_c_desc.induct) simp_all

lemma
  shows length_concat_sequences [simp]: "length (concat (sequences key xs)) = length xs"
    and length_concat_asc: "ascP f \<Longrightarrow> length (concat (asc key a f ys)) = 1 + length (f []) + length ys"
    and length_concat_desc: "length (concat (desc key a xs ys)) = 1 + length xs + length ys"
  by (induct xs and a f ys and a xs ys rule: sequences_asc_desc.induct)
    (auto simp: ascP_f_singleton)

lemma
  shows sequences_ne: "xs \<noteq> [] \<Longrightarrow> sequences key xs \<noteq> []"
    and asc_ne: "ascP f \<Longrightarrow> asc key a f ys \<noteq> []"
    and desc_ne: "desc key a xs ys \<noteq> []"
  by (induct xs and a f ys and a xs ys taking: key rule: sequences_asc_desc.induct) simp_all

lemma c_msort:
  assumes [simp]: "length xs = n"
  shows "c_msort xs \<le> n + n * \<lceil>log 2 n\<rceil>"
proof -
  have [simp]: "xs = [] \<longleftrightarrow> length xs = 0" by blast
  have "int (c_merge_all (sequences key xs)) \<le> int n * \<lceil>log 2 (length (sequences key xs))\<rceil>"
    using c_merge_all [of "sequences key xs"] by simp
  also have "\<dots> \<le> int n * \<lceil>log 2 n\<rceil>"
    using length_sequences [of key xs]
    by (cases n) (auto intro!: sequences_ne mult_mono ceiling_mono log2_mono)
  finally have "int (c_merge_all (sequences key xs)) \<le> int n * \<lceil>log 2 n\<rceil>" .
  moreover have "c_sequences xs \<le> n" using c_sequences [of xs] by auto
  ultimately show ?thesis by (auto intro: add_mono)
qed

end

end


(*  Title:       FunctorCategory
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter FunctorCategory

theory FunctorCategory
imports ConcreteCategory BinaryFunctor
begin

  text\<open>
    The functor category \<open>[A, B]\<close> is the category whose objects are functors
    from @{term A} to @{term B} and whose arrows correspond to natural transformations
    between these functors.
\<close>

  section "Construction"

  text\<open>
    Since the arrows of a functor category cannot (in the context of the present development)
    be directly identified with natural transformations, but rather only with natural
    transformations that have been equipped with their domain and codomain functors,
    and since there is no natural value to serve as @{term null},
    we use the general-purpose construction given by @{locale concrete_category} to define
    this category.
\<close>

  locale functor_category =
    A: category A +
    B: category B
  for A :: "'a comp"     (infixr "\<cdot>\<^sub>A" 55)
  and B :: "'b comp"     (infixr "\<cdot>\<^sub>B" 55)
  begin

    notation A.in_hom    ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A _\<guillemotright>")
    notation B.in_hom    ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>B _\<guillemotright>")

    type_synonym ('aa, 'bb) arr = "('aa \<Rightarrow> 'bb, 'aa \<Rightarrow> 'bb) concrete_category.arr"

    sublocale concrete_category \<open>Collect (functor A B)\<close>
      \<open>\<lambda>F G. Collect (natural_transformation A B F G)\<close> \<open>\<lambda>F. F\<close>
      \<open>\<lambda>F G H \<tau> \<sigma>. vertical_composite.map A B \<sigma> \<tau>\<close>
      using vcomp_assoc
      apply (unfold_locales, simp_all)
    proof -
      fix F G H \<sigma> \<tau>
      assume F: "functor (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) F"
      assume G: "functor (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) G"
      assume H: "functor (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) H"
      assume \<sigma>: "natural_transformation (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) F G \<sigma>"
      assume \<tau>: "natural_transformation (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) G H \<tau>"
      interpret F: "functor" A B F using F by simp
      interpret G: "functor" A B G using G by simp
      interpret H: "functor" A B H using H by simp
      interpret \<sigma>: natural_transformation A B F G \<sigma>
        using \<sigma> by simp
      interpret \<tau>: natural_transformation A B G H \<tau>
        using \<tau> by simp
      interpret \<tau>\<sigma>: vertical_composite A B F G H \<sigma> \<tau>
        ..
      show "natural_transformation (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) F H (vertical_composite.map (\<cdot>\<^sub>A) (\<cdot>\<^sub>B) \<sigma> \<tau>)"
        using \<tau>\<sigma>.map_def \<tau>\<sigma>.is_natural_transformation by simp
    qed

    abbreviation comp      (infixr "\<cdot>" 55)
    where "comp \<equiv> COMP"
    notation in_hom        ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")

    lemma arrI [intro]:
    assumes "f \<noteq> null" and "natural_transformation A B (Dom f) (Cod f) (Map f)"
    shows "arr f"
      using assms arr_char null_char
      by (simp add: natural_transformation_def)

    lemma arrE [elim]:
    assumes "arr f"
    and "f \<noteq> null \<Longrightarrow> natural_transformation A B (Dom f) (Cod f) (Map f) \<Longrightarrow> T"
    shows T
      using assms arr_char null_char by simp

    lemma arr_MkArr [iff]:
    shows "arr (MkArr F G \<tau>) \<longleftrightarrow> natural_transformation A B F G \<tau>"
      using arr_char null_char arr_MkArr natural_transformation_def by fastforce

    lemma ide_char [iff]:
    shows "ide t \<longleftrightarrow> t \<noteq> null \<and> functor A B (Map t) \<and> Dom t = Map t \<and> Cod t = Map t"
      using ide_char null_char by fastforce

  end

  section "Additional Properties"

  text\<open>
    In this section some additional facts are proved, which make it easier to
    work with the @{term "functor_category"} locale.
\<close>

  context functor_category
  begin

    lemma Map_comp [simp]:
    assumes "seq t' t" and "A.seq a' a"
    shows "Map (t' \<cdot> t) (a' \<cdot>\<^sub>A a) = Map t' a' \<cdot>\<^sub>B Map t a"
    proof -
      interpret t: natural_transformation A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Map t\<close>
        using assms(1) arr_char seq_char by blast
      interpret t': natural_transformation A B \<open>Cod t\<close> \<open>Cod t'\<close> \<open>Map t'\<close>
        using assms(1) arr_char seq_char by force
      interpret t'ot: vertical_composite A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Cod t'\<close> \<open>Map t\<close> \<open>Map t'\<close> ..
      show ?thesis
      proof -
        have "Map (t' \<cdot> t) = t'ot.map"
          using assms(1) seq_char t'ot.natural_transformation_axioms by simp
        thus ?thesis
          using assms(2) t'ot.map_simp_2 t'.preserves_comp_2 B.comp_assoc by auto
      qed
    qed

    lemma Map_comp':
    assumes "seq t' t"
    shows "Map (t' \<cdot> t) = vertical_composite.map A B (Map t) (Map t')"
    proof -
      interpret t: natural_transformation A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Map t\<close>
        using assms(1) arr_char seq_char by blast
      interpret t': natural_transformation A B \<open>Cod t\<close> \<open>Cod t'\<close> \<open>Map t'\<close>
        using assms(1) arr_char seq_char by force
      interpret t'ot: vertical_composite A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Cod t'\<close> \<open>Map t\<close> \<open>Map t'\<close> ..
      show ?thesis
        using assms(1) seq_char t'ot.natural_transformation_axioms by simp
    qed

    lemma MkArr_eqI [intro]:
    assumes "arr (MkArr F G \<tau>)"
    and "F = F'" and "G = G'" and "\<tau> = \<tau>'"
    shows "MkArr F G \<tau> = MkArr F' G' \<tau>'"
      using assms arr_eqI by simp

    lemma MkArr_eqI' [intro]:
    assumes "arr (MkArr F G \<tau>)" and "\<tau> = \<tau>'"
    shows "MkArr F G \<tau> = MkArr F G \<tau>'"
      using assms arr_eqI by simp

    lemma iso_char [iff]:
    shows "iso t \<longleftrightarrow> t \<noteq> null \<and> natural_isomorphism A B (Dom t) (Cod t) (Map t)"
    proof
      assume t: "iso t"
      show "t \<noteq> null \<and> natural_isomorphism A B (Dom t) (Cod t) (Map t)"
      proof
        show "t \<noteq> null" using t arr_char iso_is_arr by auto
        from t obtain t' where t': "inverse_arrows t t'" by blast
        interpret \<tau>: natural_transformation A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Map t\<close>
          using t arr_char iso_is_arr by auto
        interpret \<tau>': natural_transformation A B \<open>Cod t\<close> \<open>Dom t\<close> \<open>Map t'\<close>
          using t' arr_char dom_char seq_char
          by (metis arrE ide_compE inverse_arrowsE)
        interpret \<tau>'o\<tau>: vertical_composite A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Dom t\<close> \<open>Map t\<close> \<open>Map t'\<close> ..
        interpret \<tau>o\<tau>': vertical_composite A B \<open>Cod t\<close> \<open>Dom t\<close> \<open>Cod t\<close> \<open>Map t'\<close> \<open>Map t\<close> ..
        show "natural_isomorphism A B (Dom t) (Cod t) (Map t)"
        proof
          fix a
          assume a: "A.ide a"
          show "B.iso (Map t a)"
          proof
            have 1: "\<tau>'o\<tau>.map = Dom t \<and> \<tau>o\<tau>'.map = Cod t"
              using t t'
              by (metis (no_types, lifting) Map_dom concrete_category.Map_comp
                  concrete_category_axioms ide_compE inverse_arrowsE seq_char)
            show "B.inverse_arrows (Map t a) (Map t' a)"
              using a 1 \<tau>o\<tau>'.map_simp_ide \<tau>'o\<tau>.map_simp_ide \<tau>.F.preserves_ide \<tau>.G.preserves_ide
              by auto
          qed
        qed
      qed
      next
      assume t: "t \<noteq> null \<and> natural_isomorphism A B (Dom t) (Cod t) (Map t)"
      show "iso t"
      proof
        interpret \<tau>: natural_isomorphism A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Map t\<close>
          using t by auto
        interpret \<tau>': inverse_transformation A B \<open>Dom t\<close> \<open>Cod t\<close> \<open>Map t\<close> ..
        have 1: "vertical_composite.map A B (Map t) \<tau>'.map = Dom t \<and>
                 vertical_composite.map A B \<tau>'.map (Map t) = Cod t"
          using \<tau>.natural_isomorphism_axioms vertical_composite_inverse_iso
                vertical_composite_iso_inverse
          by blast
        show "inverse_arrows t (MkArr (Cod t) (Dom t) (\<tau>'.map))"
        proof
          show 2: "ide (MkArr (Cod t) (Dom t) \<tau>'.map \<cdot> t)"
            using t 1
            by (metis (no_types, lifting) MkArr_Map MkIde_Dom \<tau>'.natural_transformation_axioms
                \<tau>.natural_transformation_axioms arrI arr_MkArr comp_MkArr ide_dom)
          show "ide (t \<cdot> MkArr (Cod t) (Dom t) \<tau>'.map)"
            using t 1 2
            by (metis Map.simps(1) \<tau>'.natural_transformation_axioms arr_MkArr comp_char
                dom_MkArr dom_comp ide_char' ide_compE)
        qed
      qed
    qed

  end

  section "Evaluation Functor"

  text\<open>
    This section defines the evaluation map that applies an arrow of the functor
    category \<open>[A, B]\<close> to an arrow of @{term A} to obtain an arrow of @{term B}
    and shows that it is functorial.
\<close>

  locale evaluation_functor =
    A: category A +
    B: category B +
    A_B: functor_category A B +
    A_BxA: product_category A_B.comp A
  for A :: "'a comp"          (infixr "\<cdot>\<^sub>A" 55)
  and B :: "'b comp"          (infixr "\<cdot>\<^sub>B" 55)
  begin

    notation A_B.comp         (infixr "\<cdot>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>]" 55)
    notation A_BxA.comp       (infixr "\<cdot>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>]\<^sub>x\<^sub>A" 55)
    notation A_B.in_hom       ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>] _\<guillemotright>")
    notation A_BxA.in_hom     ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>]\<^sub>x\<^sub>A _\<guillemotright>")

    definition map
    where "map Fg \<equiv> if A_BxA.arr Fg then A_B.Map (fst Fg) (snd Fg) else B.null"

    lemma map_simp:
    assumes "A_BxA.arr Fg"
    shows "map Fg = A_B.Map(fst Fg) (snd Fg)"
      using assms map_def by auto

    lemma is_functor:
    shows "functor A_BxA.comp B map"
    proof
      show "\<And>Fg. \<not> A_BxA.arr Fg \<Longrightarrow> map Fg = B.null"
        using map_def by auto
      fix Fg
      assume Fg: "A_BxA.arr Fg"
      let ?F = "fst Fg" and ?g = "snd Fg"
      have F: "A_B.arr ?F" using Fg by auto
      have g: "A.arr ?g" using Fg by auto
      have DomF: "A_B.Dom ?F = A_B.Map (A_B.dom ?F)" using F by simp
      have CodF: "A_B.Cod ?F = A_B.Map (A_B.cod ?F)" using F by simp
      interpret F: natural_transformation A B \<open>A_B.Dom ?F\<close> \<open>A_B.Cod ?F\<close> \<open>A_B.Map ?F\<close>
        using Fg A_B.arr_char [of ?F] by blast
      show "B.arr (map Fg)" using Fg map_def by auto
      show "B.dom (map Fg) = map (A_BxA.dom Fg)"
        using g Fg map_def DomF
        by (metis (no_types, lifting) A_BxA.arr_dom A_BxA.dom_simp F.preserves_dom
            fst_conv snd_conv)
      show "B.cod (map Fg) = map (A_BxA.cod Fg)"
        using g Fg map_def CodF
        by (metis (no_types, lifting) A_BxA.arr_cod A_BxA.cod_simp F.preserves_cod
            fst_conv snd_conv)
      next
      fix Fg Fg'
      assume 1: "A_BxA.seq Fg' Fg"
      let ?F = "fst Fg" and ?g = "snd Fg"
      let ?F' = "fst Fg'" and ?g' = "snd Fg'"
      have F': "A_B.arr ?F'" using 1 A_BxA.seqE by blast
      have CodF: "A_B.Cod ?F = A_B.Map (A_B.cod ?F)"
        using 1 by (metis A_B.Map_cod A_B.seqE A_BxA.seqE)
      have DomF': "A_B.Dom ?F' = A_B.Map (A_B.dom ?F')"
        using F' by simp
      have seq_F'F: "A_B.seq ?F' ?F" using 1 by blast
      have seq_g'g: "A.seq ?g' ?g" using 1 by blast
      interpret F: natural_transformation A B \<open>A_B.Dom ?F\<close> \<open>A_B.Cod ?F\<close> \<open>A_B.Map ?F\<close>
        using 1 A_B.arr_char by blast
      interpret F': natural_transformation A B \<open>A_B.Cod ?F\<close> \<open>A_B.Cod ?F'\<close> \<open>A_B.Map ?F'\<close>
        using 1 A_B.arr_char seq_F'F CodF DomF' A_B.seqE
        by (metis mem_Collect_eq)
      interpret F'oF: vertical_composite A B \<open>A_B.Dom ?F\<close> \<open>A_B.Cod ?F\<close> \<open>A_B.Cod ?F'\<close>
                                             \<open>A_B.Map ?F\<close> \<open>A_B.Map ?F'\<close> ..
      show "map (Fg' \<cdot>\<^sub>[\<^sub>A\<^sub>,\<^sub>B\<^sub>]\<^sub>x\<^sub>A Fg) = map Fg' \<cdot>\<^sub>B map Fg"
        unfolding map_def
        using 1 seq_F'F seq_g'g by auto
    qed

  end

  sublocale evaluation_functor \<subseteq> "functor" A_BxA.comp B map
    using is_functor by auto
  sublocale evaluation_functor \<subseteq> binary_functor A_B.comp A B map ..

  section "Currying"

  text\<open>
    This section defines the notion of currying of a natural transformation
    between binary functors, to obtain a natural transformation between
    functors into a functor category, along with the inverse operation of uncurrying.
    We have only proved here what is needed to establish the results
    in theory \<open>Limit\<close> about limits in functor categories and have not
    attempted to fully develop the functoriality and naturality properties of
    these notions.
\<close>

  locale currying =
  A1: category A1 +
  A2: category A2 +
  B: category B
  for A1 :: "'a1 comp"           (infixr "\<cdot>\<^sub>A\<^sub>1" 55)
  and A2 :: "'a2 comp"           (infixr "\<cdot>\<^sub>A\<^sub>2" 55)
  and B :: "'b comp"             (infixr "\<cdot>\<^sub>B" 55)
  begin

    interpretation A1xA2: product_category A1 A2 ..
    interpretation A2_B: functor_category A2 B ..
    interpretation A2_BxA2: product_category A2_B.comp A2 ..
    interpretation E: evaluation_functor A2 B ..

    notation A1xA2.comp          (infixr "\<cdot>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2" 55)
    notation A2_B.comp           (infixr "\<cdot>\<^sub>[\<^sub>A\<^sub>2,\<^sub>B\<^sub>]" 55)
    notation A2_BxA2.comp        (infixr "\<cdot>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>]\<^sub>x\<^sub>A\<^sub>2" 55)
    notation A1xA2.in_hom        ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 _\<guillemotright>")
    notation A2_B.in_hom         ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>] _\<guillemotright>")
    notation A2_BxA2.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>]\<^sub>x\<^sub>A\<^sub>2 _\<guillemotright>")

    text\<open>
      A proper definition for @{term curry} requires that it be parametrized by
      binary functors @{term F} and @{term G} that are the domain and codomain
      of the natural transformations to which it is being applied.
      Similar parameters are not needed in the case of @{term uncurry}.
\<close>

    definition curry :: "('a1 \<times> 'a2 \<Rightarrow> 'b) \<Rightarrow> ('a1 \<times> 'a2 \<Rightarrow> 'b) \<Rightarrow> ('a1 \<times> 'a2 \<Rightarrow> 'b)
                           \<Rightarrow> 'a1 \<Rightarrow> ('a2, 'b) A2_B.arr"
    where "curry F G \<tau> f1 = (if A1.arr f1 then
                               A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
                                          (\<lambda>f2. \<tau> (f1, f2))
                             else A2_B.null)"

    definition uncurry :: "('a1 \<Rightarrow> ('a2, 'b) A2_B.arr) \<Rightarrow> 'a1 \<times> 'a2 \<Rightarrow> 'b"
    where "uncurry \<tau> f \<equiv> if A1xA2.arr f then E.map (\<tau> (fst f), snd f) else B.null"

    lemma curry_simp:
    assumes "A1.arr f1"
    shows "curry F G \<tau> f1 = A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
                                       (\<lambda>f2. \<tau> (f1, f2))"
      using assms curry_def by auto

    lemma uncurry_simp:
    assumes "A1xA2.arr f"
    shows "uncurry \<tau> f = E.map (\<tau> (fst f), snd f)"
      using assms uncurry_def by auto

    lemma curry_in_hom:
    assumes f1: "A1.arr f1"
    and "natural_transformation A1xA2.comp B F G \<tau>"
    shows "\<guillemotleft>curry F G \<tau> f1 : curry F F F (A1.dom f1) \<rightarrow>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>] curry G G G (A1.cod f1)\<guillemotright>"
    proof -
      interpret \<tau>: natural_transformation A1xA2.comp B F G \<tau> using assms by auto
      show ?thesis
      proof -
        interpret F_dom_f1: "functor" A2 B \<open>\<lambda>f2. F (A1.dom f1, f2)\<close>
          using f1 \<tau>.F.is_extensional apply (unfold_locales, simp_all)
          by (metis A1xA2.comp_char A1.arr_dom_iff_arr A1.comp_arr_dom A1.dom_dom
                    A1xA2.seqI \<tau>.F.preserves_comp_2 fst_conv snd_conv)
        interpret G_cod_f1: "functor" A2 B \<open>\<lambda>f2. G (A1.cod f1, f2)\<close>
          using f1 \<tau>.G.is_extensional A1.arr_cod_iff_arr
          apply (unfold_locales, simp_all)
          using A1xA2.comp_char A1.arr_cod_iff_arr A1.comp_cod_arr
          by (metis A1.cod_cod A1xA2.seqI \<tau>.G.preserves_comp_2 fst_conv snd_conv)
        have "natural_transformation A2 B (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
                                          (\<lambda>f2. \<tau> (f1, f2))"
          using f1 \<tau>.is_extensional apply (unfold_locales, simp_all)
        proof -
          fix f2
          assume f2: "A2.arr f2"
          show "G (A1.cod f1, f2) \<cdot>\<^sub>B \<tau> (f1, A2.dom f2) = \<tau> (f1, f2)"
            using f1 f2 \<tau>.preserves_comp_1 [of "(A1.cod f1, f2)" "(f1, A2.dom f2)"]
                  A1.comp_cod_arr A2.comp_arr_dom
            by simp
          show "\<tau> (f1, A2.cod f2) \<cdot>\<^sub>B F (A1.dom f1, f2) = \<tau> (f1, f2)"
            using f1 f2 \<tau>.preserves_comp_2 [of "(f1, A2.cod f2)" "(A1.dom f1, f2)"]
                  A1.comp_arr_dom A2.comp_cod_arr
            by simp
        qed
        thus ?thesis
          using f1 curry_simp by auto
      qed
    qed

    lemma curry_preserves_functors:
    assumes "functor A1xA2.comp B F"
    shows "functor A1 A2_B.comp (curry F F F)"
    proof -
      interpret F: "functor" A1xA2.comp B F using assms by auto
      interpret F: binary_functor A1 A2 B F ..
      show ?thesis
        using curry_def F.fixing_arr_gives_natural_transformation_1
              A2_B.comp_char F.preserves_comp_1 curry_simp A2_B.seq_char
        apply unfold_locales by auto
    qed

    lemma curry_preserves_transformations:
    assumes "natural_transformation A1xA2.comp B F G \<tau>"
    shows "natural_transformation A1 A2_B.comp (curry F F F) (curry G G G) (curry F G \<tau>)"
    proof -
      interpret \<tau>: natural_transformation A1xA2.comp B F G \<tau> using assms by auto
      interpret \<tau>: binary_functor_transformation A1 A2 B F G \<tau> ..
      interpret curry_F: "functor" A1 A2_B.comp \<open>curry F F F\<close>
        using curry_preserves_functors \<tau>.F.functor_axioms by simp
      interpret curry_G: "functor" A1 A2_B.comp \<open>curry G G G\<close>
        using curry_preserves_functors \<tau>.G.functor_axioms by simp
      show ?thesis
      proof
        show "\<And>f2. \<not> A1.arr f2 \<Longrightarrow> curry F G \<tau> f2 = A2_B.null"
          using curry_def by simp
        fix f1
        assume f1: "A1.arr f1"
        show "A2_B.dom (curry F G \<tau> f1) = curry F F F (A1.dom f1)"
          using assms f1 curry_in_hom by blast
        show "A2_B.cod (curry F G \<tau> f1) = curry G G G (A1.cod f1)"
          using assms f1 curry_in_hom by blast
        show "curry G G G f1 \<cdot>\<^sub>[\<^sub>A\<^sub>2,\<^sub>B\<^sub>] curry F G \<tau> (A1.dom f1) = curry F G \<tau> f1"
        proof -
          interpret \<tau>_dom_f1: natural_transformation A2 B \<open>\<lambda>f2. F (A1.dom f1, f2)\<close>
                                \<open>\<lambda>f2. G (A1.dom f1, f2)\<close> \<open>\<lambda>f2. \<tau> (A1.dom f1, f2)\<close>
            using assms f1 curry_in_hom A1.ide_dom \<tau>.fixing_ide_gives_natural_transformation_1
            by blast
          interpret G_f1: natural_transformation A2 B
                                \<open>\<lambda>f2. G (A1.dom f1, f2)\<close> \<open>\<lambda>f2. G (A1.cod f1, f2)\<close> \<open>\<lambda>f2. G (f1, f2)\<close>
            using f1 \<tau>.G.fixing_arr_gives_natural_transformation_1 by simp
          interpret G_f1o\<tau>_dom_f1: vertical_composite A2 B
                                     \<open>\<lambda>f2. F (A1.dom f1, f2)\<close> \<open>\<lambda>f2. G (A1.dom f1, f2)\<close>
                                     \<open>\<lambda>f2. G (A1.cod f1, f2)\<close>
                                     \<open>\<lambda>f2. \<tau> (A1.dom f1, f2)\<close> \<open>\<lambda>f2. G (f1, f2)\<close> ..
          have "curry G G G f1 \<cdot>\<^sub>[\<^sub>A\<^sub>2,\<^sub>B\<^sub>] curry F G \<tau> (A1.dom f1)
                  = A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2)) G_f1o\<tau>_dom_f1.map"
          proof -
            have "A2_B.seq (curry G G G f1) (curry F G \<tau> (A1.dom f1))"
              using f1 curry_in_hom [of "A1.dom f1"] \<tau>.natural_transformation_axioms by force
            thus ?thesis
              using f1 curry_simp A2_B.comp_char [of "curry G G G f1" "curry F G \<tau> (A1.dom f1)"]
              by simp
          qed
          also have "... = A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
                                      (\<lambda>f2. \<tau> (f1, f2))"
          proof (intro A2_B.MkArr_eqI)
            show "(\<lambda>f2. F (A1.dom f1, f2)) = (\<lambda>f2. F (A1.dom f1, f2))" by simp
            show "(\<lambda>f2. G (A1.cod f1, f2)) = (\<lambda>f2. G (A1.cod f1, f2))" by simp
            show "A2_B.arr (A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
                                       G_f1o\<tau>_dom_f1.map)"
              using G_f1o\<tau>_dom_f1.natural_transformation_axioms by blast
            show "G_f1o\<tau>_dom_f1.map = (\<lambda>f2. \<tau> (f1, f2))"
            proof
              fix f2
              have "\<not>A2.arr f2 \<Longrightarrow> G_f1o\<tau>_dom_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2"
                using f1 G_f1o\<tau>_dom_f1.is_extensional \<tau>.is_extensional by simp
              moreover have "A2.arr f2 \<Longrightarrow> G_f1o\<tau>_dom_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2"
              proof -
                interpret \<tau>_f1: natural_transformation A2 B \<open>\<lambda>f2. F (A1.dom f1, f2)\<close>
                                  \<open>\<lambda>f2. G (A1.cod f1, f2)\<close> \<open>\<lambda>f2. \<tau> (f1, f2)\<close>
                  using assms f1 curry_in_hom [of f1] curry_simp by auto
                fix f2
                assume f2: "A2.arr f2"
                show "G_f1o\<tau>_dom_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2"
                  using f1 f2 G_f1o\<tau>_dom_f1.map_simp_2 B.comp_assoc \<tau>.is_natural_1
                  by fastforce
              qed
              ultimately show "G_f1o\<tau>_dom_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2" by blast
            qed
          qed
          also have "... = curry F G \<tau> f1" using f1 curry_def by simp
          finally show ?thesis by blast
        qed
        show "curry F G \<tau> (A1.cod f1) \<cdot>\<^sub>[\<^sub>A\<^sub>2,\<^sub>B\<^sub>] curry F F F f1 = curry F G \<tau> f1"
        proof -
          interpret \<tau>_cod_f1: natural_transformation A2 B \<open>\<lambda>f2. F (A1.cod f1, f2)\<close>
                                \<open>\<lambda>f2. G (A1.cod f1, f2)\<close> \<open>\<lambda>f2. \<tau> (A1.cod f1, f2)\<close>
            using assms f1 curry_in_hom A1.ide_cod \<tau>.fixing_ide_gives_natural_transformation_1
            by blast
          interpret F_f1: natural_transformation A2 B
                                \<open>\<lambda>f2. F (A1.dom f1, f2)\<close> \<open>\<lambda>f2. F (A1.cod f1, f2)\<close> \<open>\<lambda>f2. F (f1, f2)\<close>
            using f1 \<tau>.F.fixing_arr_gives_natural_transformation_1 by simp
          interpret \<tau>_cod_f1oF_f1: vertical_composite A2 B
                                     \<open>\<lambda>f2. F (A1.dom f1, f2)\<close> \<open>\<lambda>f2. F (A1.cod f1, f2)\<close>
                                     \<open>\<lambda>f2. G (A1.cod f1, f2)\<close>
                                     \<open>\<lambda>f2. F (f1, f2)\<close> \<open>\<lambda>f2. \<tau> (A1.cod f1, f2)\<close> ..
          have "curry F G \<tau> (A1.cod f1) \<cdot>\<^sub>[\<^sub>A\<^sub>2,\<^sub>B\<^sub>] curry F F F f1
                  = A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2)) \<tau>_cod_f1oF_f1.map"
          proof -
            have
                 "curry F F F f1 =
                    A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. F (A1.cod f1, f2))
                               (\<lambda>f2. F (f1, f2)) \<and>
                  \<guillemotleft>curry F F F f1 : curry F F F (A1.dom f1) \<rightarrow>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>] curry F F F (A1.cod f1)\<guillemotright>"
              using f1 curry_F.preserves_hom curry_simp by blast
            moreover have
                 "curry F G \<tau> (A1.dom f1) =
                    A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.dom f1, f2))
                               (\<lambda>f2. \<tau> (A1.dom f1, f2)) \<and>
                    \<guillemotleft>curry F G \<tau> (A1.cod f1) :
                       curry F F F (A1.cod f1) \<rightarrow>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>] curry G G G (A1.cod f1)\<guillemotright>"
              using assms f1 curry_in_hom [of "A1.cod f1"] curry_def A1.arr_cod_iff_arr by simp
            ultimately show ?thesis
              using f1 curry_def by fastforce
          qed
          also have "... = A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
                                      (\<lambda>f2. \<tau> (f1, f2))"
          proof (intro A2_B.MkArr_eqI)
            show "(\<lambda>f2. F (A1.dom f1, f2)) = (\<lambda>f2. F (A1.dom f1, f2))" by simp
            show "(\<lambda>f2. G (A1.cod f1, f2)) = (\<lambda>f2. G (A1.cod f1, f2))" by simp
            show "A2_B.arr (A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. G (A1.cod f1, f2))
                                       \<tau>_cod_f1oF_f1.map)"
              using \<tau>_cod_f1oF_f1.natural_transformation_axioms by blast
            show "\<tau>_cod_f1oF_f1.map = (\<lambda>f2. \<tau> (f1, f2))"
            proof
              fix f2
              have "\<not>A2.arr f2 \<Longrightarrow> \<tau>_cod_f1oF_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2"
                using f1 by (simp add: \<tau>.is_extensional \<tau>_cod_f1oF_f1.is_extensional)
              moreover have "A2.arr f2 \<Longrightarrow> \<tau>_cod_f1oF_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2"
              proof -
                interpret \<tau>_f1: natural_transformation A2 B \<open>\<lambda>f2. F (A1.dom f1, f2)\<close>
                                  \<open>\<lambda>f2. G (A1.cod f1, f2)\<close> \<open>\<lambda>f2. \<tau> (f1, f2)\<close>
                  using assms f1 curry_in_hom [of f1] curry_simp by auto
                fix f2
                assume f2: "A2.arr f2"
                show "\<tau>_cod_f1oF_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2"
                  using f1 f2 \<tau>_cod_f1oF_f1.map_simp_1 B.comp_assoc \<tau>.is_natural_2
                  by fastforce
              qed
              ultimately show "\<tau>_cod_f1oF_f1.map f2 = (\<lambda>f2. \<tau> (f1, f2)) f2" by blast
            qed
          qed
          also have "... = curry F G \<tau> f1" using f1 curry_def by simp
          finally show ?thesis by blast
        qed
      qed
    qed

    lemma uncurry_preserves_functors:
    assumes "functor A1 A2_B.comp F"
    shows "functor A1xA2.comp B (uncurry F)"
    proof -
      interpret F: "functor" A1 A2_B.comp F using assms by auto
      show ?thesis
        using uncurry_def
        apply (unfold_locales)
            apply auto[4]
      proof -
        fix f g :: "'a1 * 'a2"
        let ?f1 = "fst f"
        let ?f2 = "snd f"
        let ?g1 = "fst g"
        let ?g2 = "snd g"
        assume fg: "A1xA2.seq g f"
        have f: "A1xA2.arr f" using fg A1xA2.seqE by blast
        have f1: "A1.arr ?f1" using f by auto
        have f2: "A2.arr ?f2" using f by auto
        have g: "\<guillemotleft>g : A1xA2.cod f \<rightarrow>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 A1xA2.cod g\<guillemotright>"
          using fg A1xA2.dom_char A1xA2.cod_char
          by (elim A1xA2.seqE, intro A1xA2.in_homI, auto)
        let ?g1 = "fst g"
        let ?g2 = "snd g"
        have g1: "\<guillemotleft>?g1 : A1.cod ?f1 \<rightarrow>\<^sub>A\<^sub>1 A1.cod ?g1\<guillemotright>"
          using f g by (intro A1.in_homI, auto)
        have g2: "\<guillemotleft>?g2 : A2.cod ?f2 \<rightarrow>\<^sub>A\<^sub>2 A2.cod ?g2\<guillemotright>"
          using f g by (intro A2.in_homI, auto)
        interpret Ff1: natural_transformation A2 B \<open>A2_B.Dom (F ?f1)\<close> \<open>A2_B.Cod (F ?f1)\<close>
                                                   \<open>A2_B.Map (F ?f1)\<close>
          using f A2_B.arr_char [of "F ?f1"] by auto
        interpret Fg1: natural_transformation A2 B \<open>A2_B.Cod (F ?f1)\<close> \<open>A2_B.Cod (F ?g1)\<close>
                                                   \<open>A2_B.Map (F ?g1)\<close>
          using f1 g1 A2_B.arr_char F.preserves_arr
                A2_B.Map_dom [of "F ?g1"] A2_B.Map_cod [of "F ?f1"]
          by fastforce
        interpret Fg1oFf1: vertical_composite A2 B
                              \<open>A2_B.Dom (F ?f1)\<close> \<open>A2_B.Cod (F ?f1)\<close> \<open>A2_B.Cod (F ?g1)\<close>
                              \<open>A2_B.Map (F ?f1)\<close> \<open>A2_B.Map (F ?g1)\<close> ..
        show "uncurry F (g \<cdot>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 f) = uncurry F g \<cdot>\<^sub>B uncurry F f"
          using f1 g1 g2 g2 f g fg E.map_simp uncurry_def by auto
      qed
    qed

    lemma uncurry_preserves_transformations:
    assumes "natural_transformation A1 A2_B.comp F G \<tau>"
    shows "natural_transformation A1xA2.comp B (uncurry F) (uncurry G) (uncurry \<tau>)"
    proof -
      interpret \<tau>: natural_transformation A1 A2_B.comp F G \<tau> using assms by auto
      interpret "functor" A1xA2.comp B \<open>uncurry F\<close>
        using \<tau>.F.functor_axioms uncurry_preserves_functors by blast
      interpret "functor" A1xA2.comp B \<open>uncurry G\<close>
        using \<tau>.G.functor_axioms uncurry_preserves_functors by blast
      show ?thesis
      proof
        fix f
        show "\<not> A1xA2.arr f \<Longrightarrow> uncurry \<tau> f = B.null"
          using uncurry_def by auto
        assume f: "A1xA2.arr f"
        let ?f1 = "fst f"
        let ?f2 = "snd f"
        show "B.dom (uncurry \<tau> f) = uncurry F (A1xA2.dom f)"
          using f uncurry_def by simp
        show "B.cod (uncurry \<tau> f) = uncurry G (A1xA2.cod f)"
          using f uncurry_def by simp
        show "uncurry G f \<cdot>\<^sub>B uncurry \<tau> (A1xA2.dom f) = uncurry \<tau> f"
          using f uncurry_def \<tau>.is_natural_1 A2_BxA2.seq_char A2.comp_arr_dom
                E.preserves_comp [of "(G (fst f), snd f)" "(\<tau> (A1.dom (fst f)), A2.dom (snd f))"]
          by auto
        show "uncurry \<tau> (A1xA2.cod f) \<cdot>\<^sub>B uncurry F f = uncurry \<tau> f"
        proof -
          have 1: "A1.arr ?f1 \<and> A1.arr (fst (A1.cod ?f1, A2.cod ?f2)) \<and>
                   A1.cod ?f1 = A1.dom (fst (A1.cod ?f1, A2.cod ?f2)) \<and>
                   A2.seq (snd (A1.cod ?f1, A2.cod ?f2)) ?f2"
            using f A1.arr_cod_iff_arr A2.arr_cod_iff_arr by auto
          hence 2:
              "?f2 = A2 (snd (\<tau> (fst (A1xA2.cod f)), snd (A1xA2.cod f))) (snd (F ?f1, ?f2))"
            using f A2.comp_cod_arr by simp
          have "A2_B.arr (\<tau> ?f1)" using 1 by force
          thus ?thesis
            unfolding uncurry_def E.map_def
            using f 1 2
            apply simp
            by (metis (no_types, lifting) A2_B.Map_comp \<open>A2_B.arr (\<tau> (fst f))\<close> \<tau>.is_natural_2)

        qed
      qed
    qed

    lemma uncurry_curry:
    assumes "natural_transformation A1xA2.comp B F G \<tau>"
    shows "uncurry (curry F G \<tau>) = \<tau>"
    proof
      interpret \<tau>: natural_transformation A1xA2.comp B F G \<tau> using assms by auto
      interpret curry_\<tau>: natural_transformation A1 A2_B.comp \<open>curry F F F\<close> \<open>curry G G G\<close>
                                                             \<open>curry F G \<tau>\<close>
        using assms curry_preserves_transformations by auto
      fix f
      have "\<not>A1xA2.arr f \<Longrightarrow> uncurry (curry F G \<tau>) f = \<tau> f"
        using curry_def uncurry_def \<tau>.is_extensional by auto
      moreover have "A1xA2.arr f \<Longrightarrow> uncurry (curry F G \<tau>) f = \<tau> f"
      proof -
        assume f: "A1xA2.arr f"
        have 1: "A2_B.Map (curry F G \<tau> (fst f)) (snd f) = \<tau> (fst f, snd f)"
          using f A1xA2.arr_char curry_def by simp
        thus "uncurry (curry F G \<tau>) f = \<tau> f"
          unfolding uncurry_def E.map_def
          using f 1 A1xA2.arr_char [of f] by simp
      qed
      ultimately show "uncurry (curry F G \<tau>) f = \<tau> f" by blast
    qed

    lemma curry_uncurry:
    assumes "functor A1 A2_B.comp F" and "functor A1 A2_B.comp G"
    and "natural_transformation A1 A2_B.comp F G \<tau>"
    shows "curry (uncurry F) (uncurry G) (uncurry \<tau>) = \<tau>"
    proof
      interpret F: "functor" A1 A2_B.comp F using assms(1) by auto
      interpret G: "functor" A1 A2_B.comp G using assms(2) by auto
      interpret \<tau>: natural_transformation A1 A2_B.comp F G \<tau> using assms(3) by auto
      interpret uncurry_F: "functor" A1xA2.comp B \<open>uncurry F\<close>
        using F.functor_axioms uncurry_preserves_functors by auto
      interpret uncurry_G: "functor" A1xA2.comp B \<open>uncurry G\<close>
        using G.functor_axioms uncurry_preserves_functors by auto
      fix f1
      have "\<not>A1.arr f1 \<Longrightarrow> curry (uncurry F) (uncurry G) (uncurry \<tau>) f1 = \<tau> f1"
        using curry_def uncurry_def \<tau>.is_extensional by simp
      moreover have "A1.arr f1 \<Longrightarrow> curry (uncurry F) (uncurry G) (uncurry \<tau>) f1 = \<tau> f1"
      proof -
        assume f1: "A1.arr f1"
        interpret uncurry_\<tau>:
            natural_transformation A1xA2.comp B \<open>uncurry F\<close> \<open>uncurry G\<close> \<open>uncurry \<tau>\<close>
          using \<tau>.natural_transformation_axioms uncurry_preserves_transformations [of F G \<tau>]
          by simp
        have "curry (uncurry F) (uncurry G) (uncurry \<tau>) f1 =
                A2_B.MkArr (\<lambda>f2. uncurry F (A1.dom f1, f2)) (\<lambda>f2. uncurry G (A1.cod f1, f2))
                           (\<lambda>f2. uncurry \<tau> (f1, f2))"
          using f1 curry_def by simp
        also have "... = A2_B.MkArr (\<lambda>f2. uncurry F (A1.dom f1, f2))
                                    (\<lambda>f2. uncurry G (A1.cod f1, f2))
                                    (\<lambda>f2. E.map (\<tau> f1, f2))"
        proof -
          have "(\<lambda>f2. uncurry \<tau> (f1, f2)) = (\<lambda>f2. E.map (\<tau> f1, f2))"
            using f1 uncurry_def E.is_extensional by auto
          thus ?thesis by simp
        qed
        also have "... = \<tau> f1"
        proof -
          have "A2_B.Dom (\<tau> f1) = (\<lambda>f2. uncurry F (A1.dom f1, f2))"
          proof -
            have "A2_B.Dom (\<tau> f1) = A2_B.Map (A2_B.dom (\<tau> f1))"
              using f1 A2_B.ide_char A2_B.Map_dom A2_B.dom_char by auto
            also have "... = A2_B.Map (F (A1.dom f1))"
              using f1 by simp
            also have "... = (\<lambda>f2. uncurry F (A1.dom f1, f2))"
            proof
              fix f2
              interpret F_dom_f1: "functor" A2 B \<open>A2_B.Map (F (A1.dom f1))\<close>
                using f1 A2_B.ide_char F.preserves_ide by simp
              show "A2_B.Map (F (A1.dom f1)) f2 = uncurry F (A1.dom f1, f2)"
                using f1 uncurry_def E.map_simp F_dom_f1.is_extensional by auto
            qed
            finally show ?thesis by auto
          qed
          moreover have "A2_B.Cod (\<tau> f1) = (\<lambda>f2. uncurry G (A1.cod f1, f2))"
          proof -
            have "A2_B.Cod (\<tau> f1) = A2_B.Map (A2_B.cod (\<tau> f1))"
              using f1 A2_B.ide_char A2_B.Map_cod A2_B.cod_char by auto
            also have "... = A2_B.Map (G (A1.cod f1))"
              using f1 by simp
            also have "... = (\<lambda>f2. uncurry G (A1.cod f1, f2))"
            proof
              fix f2
              interpret G_cod_f1: "functor" A2 B \<open>A2_B.Map (G (A1.cod f1))\<close>
                using f1 A2_B.ide_char G.preserves_ide by simp
              show "A2_B.Map (G (A1.cod f1)) f2 = uncurry G (A1.cod f1, f2)"
                using f1 uncurry_def E.map_simp G_cod_f1.is_extensional by auto
            qed
            finally show ?thesis by auto
          qed
          moreover have "A2_B.Map (\<tau> f1) = (\<lambda>f2. E.map (\<tau> f1, f2))"
          proof
            fix f2
            have "\<not>A2.arr f2 \<Longrightarrow> A2_B.Map (\<tau> f1) f2 = (\<lambda>f2. E.map (\<tau> f1, f2)) f2"
              using f1 A2_B.arrE \<tau>.preserves_reflects_arr natural_transformation.is_extensional
              by (metis (no_types, lifting) E.fixing_arr_gives_natural_transformation_1)
            moreover have "A2.arr f2 \<Longrightarrow> A2_B.Map (\<tau> f1) f2 = (\<lambda>f2. E.map (\<tau> f1, f2)) f2"
              using f1 E.map_simp by fastforce
            ultimately show "A2_B.Map (\<tau> f1) f2 = (\<lambda>f2. E.map (\<tau> f1, f2)) f2" by blast
          qed
          ultimately show ?thesis
            using f1 A2_B.MkArr_Map \<tau>.preserves_reflects_arr by metis
        qed
        finally show ?thesis by auto
      qed
      ultimately show "curry (uncurry F) (uncurry G) (uncurry \<tau>) f1 = \<tau> f1" by blast
    qed

  end

  locale curried_functor =
     currying A1 A2 B +
     A1xA2: product_category A1 A2 +
     A2_B: functor_category A2 B +
     F: binary_functor A1 A2 B F
  for A1 :: "'a1 comp"         (infixr "\<cdot>\<^sub>A\<^sub>1" 55)
  and A2 :: "'a2 comp"         (infixr "\<cdot>\<^sub>A\<^sub>2" 55)
  and B :: "'b comp"           (infixr "\<cdot>\<^sub>B" 55)
  and F :: "'a1 * 'a2 \<Rightarrow> 'b"
  begin

    notation A1xA2.comp        (infixr "\<cdot>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2" 55)
    notation A2_B.comp         (infixr "\<cdot>\<^sub>[\<^sub>A\<^sub>2,\<^sub>B\<^sub>]" 55)
    notation A1xA2.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 _\<guillemotright>")
    notation A2_B.in_hom       ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>A\<^sub>2\<^sub>,\<^sub>B\<^sub>] _\<guillemotright>")

    definition map
    where "map \<equiv> curry F F F"

    lemma map_simp [simp]:
    assumes "A1.arr f1"
    shows "map f1 =
           A2_B.MkArr (\<lambda>f2. F (A1.dom f1, f2)) (\<lambda>f2. F (A1.cod f1, f2)) (\<lambda>f2. F (f1, f2))"
      using assms map_def curry_simp by auto

    lemma is_functor:
    shows "functor A1 A2_B.comp map"
      using F.functor_axioms map_def curry_preserves_functors by simp

  end

  sublocale curried_functor \<subseteq> "functor" A1 A2_B.comp map
    using is_functor by auto

  locale curried_functor' =
     A1: category A1 +
     A2: category A2 +
     A1xA2: product_category A1 A2 +
     currying A2 A1 B +
     F: binary_functor A1 A2 B F +
     A1_B: functor_category A1 B
  for A1 :: "'a1 comp"         (infixr "\<cdot>\<^sub>A\<^sub>1" 55)
  and A2 :: "'a2 comp"         (infixr "\<cdot>\<^sub>A\<^sub>2" 55)
  and B :: "'b comp"           (infixr "\<cdot>\<^sub>B" 55)
  and F :: "'a1 * 'a2 \<Rightarrow> 'b"
  begin

    notation A1xA2.comp        (infixr "\<cdot>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2" 55)
    notation A1_B.comp         (infixr "\<cdot>\<^sub>[\<^sub>A\<^sub>1,\<^sub>B\<^sub>]" 55)
    notation A1xA2.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>A\<^sub>1\<^sub>x\<^sub>A\<^sub>2 _\<guillemotright>")
    notation A1_B.in_hom       ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>[\<^sub>A\<^sub>1\<^sub>,\<^sub>B\<^sub>] _\<guillemotright>")

    definition map
    where "map \<equiv> curry F.sym F.sym F.sym"

    lemma map_simp [simp]:
    assumes "A2.arr f2"
    shows "map f2 =
           A1_B.MkArr (\<lambda>f1. F (f1, A2.dom f2)) (\<lambda>f1. F (f1, A2.cod f2)) (\<lambda>f1. F (f1, f2))"
      using assms map_def curry_simp by simp

    lemma is_functor:
    shows "functor A2 A1_B.comp map"
    proof -
      interpret A2xA1: product_category A2 A1 ..
      interpret F': binary_functor A2 A1 B F.sym
        using F.sym_is_binary_functor by simp
      have "functor A2xA1.comp B F.sym" ..
      thus ?thesis using map_def curry_preserves_functors by simp
    qed

  end

  sublocale curried_functor' \<subseteq> "functor" A2 A1_B.comp map
    using is_functor by auto

end