           (*-------------------------------------------*
            |  The Dining Mathematicians in CSP-Prover  |
            |               August 2004                 |
            |             December 2004 (modified)      |
            |             November 2005 (modified)      |
            |                March 2007  (modified)     |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory DM2_para
imports DM1_Imp_def
begin

(*****************************************************************

         1. expands parallel operators in Imp
         2.
         3.
         4.

 *****************************************************************)

(*** TH0 VAR step 1 ***)

lemma TH0_VAR:
  "(($TH0) |[CH0]| ($(VAR n)))
   =F (? x:insert (RD0 n) (insert (RD1 n) (range WR1))
          -> IF (x : (range RD0) | x : (range WR0))
                THEN IF EVEN (getInt x)
                     THEN (Eat0  -> ($(EAT0 n)) |[CH0]| ($(VAR n)))
                     ELSE (Back0 -> ($TH0) |[CH0]| ($(VAR n)))
                ELSE (($TH0) |[CH0]| ($(VAR (getInt x)))))"
apply (cspF_simp unfold_Imp_rules3)+
apply (cspF_step_left)+
apply (case_tac "EVEN n")
apply (auto)
apply (cspF_simp fold_Imp_rules3)+
done

lemmas TH0_VAR_simp = TH0_VAR[simplified]
lemmas unfold_Imp_rules4 = unfold_Imp_rules3 TH0_VAR_simp
lemmas fold_Imp_rules4 = fold_Imp_rules3 TH0_VAR_simp[THEN cspF_sym]

(*** TH0 VAR TH1 step 1 ***)

lemma TH0_VAR_TH1:
  "(($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
   =F
    ? x:{(RD0 n), (RD1 n)}
      -> IF (x = RD0 n)
            THEN IF EVEN n
                 THEN (Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n))
                                                 |[CH1]| ($TH1))
                 ELSE (Back0 -> ($TH0)   |[CH0]| ($(VAR n))
                                               |[CH1]| ($TH1))
            ELSE IF ODD n
                 THEN (($TH0) |[CH0]| ($(VAR n))
                                    |[CH1]| Eat1 -> ($(EAT1 n)))
                 ELSE (($TH0) |[CH0]| ($(VAR n))
                                    |[CH1]| Back1 -> ($TH1))"
apply (cspF_simp unfold_Imp_rules4)
apply (cspF_step_left)
apply (case_tac "EVEN n")
apply (auto)
apply (cspF_simp fold_Imp_rules4)+
done

lemmas TH0_VAR_TH1_simp = TH0_VAR_TH1[simplified]
lemmas unfold_Imp_rules5 = unfold_Imp_rules4 TH0_VAR_TH1_simp
lemmas fold_Imp_rules5 = fold_Imp_rules4 TH0_VAR_TH1_simp[THEN cspF_sym]

(*** Eat0 VAR step 2 ***)

lemma Eat0_VAR:
  " (Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n)))
   =F
    ? x:insert Eat0 (insert (RD1 n) (range WR1))
        -> IF (x = Eat0)
              THEN (($(EAT0 n)) |[CH0]| ($(VAR n)))
              ELSE IF (x = RD1 n)
                   THEN (Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n)))
                   ELSE (Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR (getInt x))))"
apply (cspF_simp unfold_Imp_rules5)
apply (cspF_step_left)+
apply (auto)
apply (cspF_simp fold_Imp_rules5)+
done

lemmas Eat0_VAR_simp = Eat0_VAR[simplified]
lemmas unfold_Imp_rules6 = unfold_Imp_rules5 Eat0_VAR_simp
lemmas fold_Imp_rules6 = fold_Imp_rules5 Eat0_VAR_simp[THEN cspF_sym]

(*** Back0 VAR step 2 ***)

lemma Back0_VAR:
  " (Back0 -> ($TH0) |[CH0]| ($(VAR n)))
   =F
    ? x:insert Back0 (insert (RD1 n) (range WR1))
        -> IF (x = Back0)
              THEN (($TH0) |[CH0]| ($(VAR n)))
              ELSE IF (x = RD1 n)
                   THEN (Back0 -> ($TH0) |[CH0]| ($(VAR n)))
                   ELSE (Back0 -> ($TH0) |[CH0]| ($(VAR (getInt x))))"
apply (cspF_simp unfold_Imp_rules6)
apply (cspF_step_left)+
apply (auto)
apply (cspF_simp fold_Imp_rules6)+
done

lemmas Back0_VAR_simp = Back0_VAR[simplified]
lemmas unfold_Imp_rules7 = unfold_Imp_rules6 Back0_VAR_simp
lemmas fold_Imp_rules7 = fold_Imp_rules6 Back0_VAR_simp[THEN cspF_sym]

(*** Eat0 VAR TH1 step 2 ***)

lemma Eat0_VAR_TH1:
  "EVEN n ==>
    (Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
   =F
    ? x:{Eat0, (RD1 n)}
      -> IF (x = Eat0)
            THEN (($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
            ELSE (Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n))
                                            |[CH1]| Back1 -> ($TH1))"
apply (cspF_simp unfold_Imp_rules7)
apply (cspF_step_left)
apply (auto)
apply (cspF_simp fold_Imp_rules7)+
done

lemmas Eat0_VAR_TH1_simp = Eat0_VAR_TH1[simplified]
lemmas unfold_Imp_rules8 = unfold_Imp_rules7 Eat0_VAR_TH1_simp
lemmas fold_Imp_rules8 = fold_Imp_rules7 Eat0_VAR_TH1_simp[THEN cspF_sym]

(****************************)
(*** Back0 VAR TH1 step 2 ***)

lemma Back0_VAR_TH1:
  " (Back0 -> ($TH0) |[CH0]| ($(VAR n))
                           |[CH1]| ($TH1))
   =F
    ? x:{Back0, (RD1 n)}
      -> IF (x = Back0)
            THEN (($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
            ELSE IF ODD n
                 THEN (Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                             |[CH1]| Eat1 -> ($(EAT1 n)))
                 ELSE (Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                             |[CH1]| Back1 -> ($TH1))"
apply (cspF_simp unfold_Imp_rules8)
apply (cspF_step_left)
apply (case_tac "EVEN n")
apply (auto)
apply (cspF_simp fold_Imp_rules8)+
done

lemmas Back0_VAR_TH1_simp = Back0_VAR_TH1[simplified]
lemmas unfold_Imp_rules9 = unfold_Imp_rules8 Back0_VAR_TH1_simp
lemmas fold_Imp_rules9 = fold_Imp_rules8 Back0_VAR_TH1_simp[THEN cspF_sym]

(*** TH0 VAR Eat1 step 2 ***)

lemma TH0_VAR_Eat1:
  "ODD n ==>
    (($TH0) |[CH0]| ($(VAR n))
                  |[CH1]| Eat1 -> ($(EAT1 n)))
   =F
    ? x:{Eat1, (RD0 n)}
      -> IF (x = Eat1)
            THEN (($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($(EAT1 n)))
            ELSE (Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                        |[CH1]| Eat1 -> ($(EAT1 n)))"
apply (cspF_simp unfold_Imp_rules9)
apply (cspF_step_left)+
apply (auto)
apply (cspF_simp fold_Imp_rules9)+
done

lemmas TH0_VAR_Eat1_simp = TH0_VAR_Eat1[simplified]
lemmas unfold_Imp_rules10 = unfold_Imp_rules9 TH0_VAR_Eat1_simp
lemmas fold_Imp_rules10 = fold_Imp_rules9 TH0_VAR_Eat1_simp[THEN cspF_sym]

(****************************)
(*** TH0 VAR Back1 step 2 ***)

lemma TH0_VAR_Back1:
  " (($TH0) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
   =F
    ? x:{Back1, (RD0 n)}
      -> IF (x = Back1)
            THEN (($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
            ELSE IF EVEN n
                 THEN (Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n))
                                                 |[CH1]| Back1 -> ($TH1))
                 ELSE (Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                             |[CH1]| Back1 -> ($TH1))"
apply (cspF_simp unfold_Imp_rules10)
apply (cspF_step_left)+
apply (case_tac "EVEN n")
apply (auto)
apply (cspF_simp fold_Imp_rules10)+
done

lemmas TH0_VAR_Back1_simp = TH0_VAR_Back1[simplified]
lemmas unfold_Imp_rules11 = unfold_Imp_rules10 TH0_VAR_Back1_simp
lemmas fold_Imp_rules11 = fold_Imp_rules10 TH0_VAR_Back1_simp[THEN cspF_sym]

(*** EAT0 VAR step 3 ***)

lemma EAT0_VAR:
  " (($(EAT0 n)) |[CH0]| ($(VAR n)))
   =F
    ? x:insert End0 (insert (RD1 n) (range WR1))
     -> IF (x = End0)
           THEN (WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n)))
           ELSE IF (x = RD1 n)
                THEN (($(EAT0 n)) |[CH0]| ($(VAR n)))
                ELSE (($(EAT0 n)) |[CH0]| ($(VAR (getInt x))))"
apply (cspF_simp unfold_Imp_rules11)
apply (cspF_step_left)+
apply (case_tac "EVEN n")
apply (auto)
apply (cspF_simp fold_Imp_rules11)+
done

lemmas EAT0_VAR_simp = EAT0_VAR[simplified]
lemmas unfold_Imp_rules12 = unfold_Imp_rules11 EAT0_VAR_simp
lemmas fold_Imp_rules12 = fold_Imp_rules11 EAT0_VAR_simp[THEN cspF_sym]

(*** EAT0 VAR TH1 step 3 ***)

lemma EAT0_VAR_TH1:
  "EVEN n ==>
    (($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
   =F
    ? x:{End0, (RD1 n)}
      -> IF (x = End0)
            THEN (WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n))
                                                |[CH1]| ($TH1))
            ELSE (($(EAT0 n)) |[CH0]| ($(VAR n))
                                    |[CH1]| Back1 -> ($TH1))"
apply (cspF_simp unfold_Imp_rules12)
apply (cspF_step_left)+
apply (auto)
apply (cspF_simp fold_Imp_rules12)+
done

lemmas EAT0_VAR_TH1_simp = EAT0_VAR_TH1[simplified]
lemmas unfold_Imp_rules13 = unfold_Imp_rules12 EAT0_VAR_TH1_simp
lemmas fold_Imp_rules13 = fold_Imp_rules12 EAT0_VAR_TH1_simp[THEN cspF_sym]

(*** Eat0 VAR Back1 step 3 ***)

lemma Eat0_VAR_Back1:
  "EVEN n ==>
        (Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n))
                                   |[CH1]| Back1 -> ($TH1))
   =F
    ? x:{Eat0, Back1}
      -> IF (x = Eat0)
            THEN (($(EAT0 n)) |[CH0]| ($(VAR n))
                                    |[CH1]| Back1 -> ($TH1))
            ELSE (Eat0 -> ($(EAT0 n)) |[CH0]| ($(VAR n))
                                            |[CH1]| ($TH1))"
apply (cspF_simp unfold_Imp_rules13)
apply (cspF_step_left)+
apply (auto)
apply (cspF_simp fold_Imp_rules13)+
done

lemmas Eat0_VAR_Back1_simp = Eat0_VAR_Back1[simplified]
lemmas unfold_Imp_rules14 = unfold_Imp_rules13 Eat0_VAR_Back1_simp
lemmas fold_Imp_rules14 = fold_Imp_rules13 Eat0_VAR_Back1_simp[THEN cspF_sym]

(*** TH0 VAR EAT1 step 3 ***)

lemma TH0_VAR_EAT1:
  "ODD n ==>
    (($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($(EAT1 n)))
   =F
    ? x:{End1, (RD0 n)}
   -> IF (x = End1)
         THEN (($TH0) |[CH0]| ($(VAR n))
                            |[CH1]| WR1 (3 * n + 1) -> ($TH1))
         ELSE (Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                     |[CH1]| ($(EAT1 n)))"
apply (cspF_simp unfold_Imp_rules14)
apply (cspF_step_left)+
apply (auto)
apply (cspF_simp fold_Imp_rules14)+
done

lemmas TH0_VAR_EAT1_simp = TH0_VAR_EAT1[simplified]
lemmas unfold_Imp_rules15 = unfold_Imp_rules14 TH0_VAR_EAT1_simp
lemmas fold_Imp_rules15 = fold_Imp_rules14 TH0_VAR_EAT1_simp[THEN cspF_sym]

(*** Back0 VAR Eat1 step 3 ***)

lemma Back0_VAR_Eat1:
  "ODD n ==>
    (Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| Eat1 -> ($(EAT1 n)))
   =F
    ? x:{Eat1, Back0}
   -> IF (x = Eat1)
         THEN (Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                     |[CH1]| ($(EAT1 n)))
         ELSE (($TH0) |[CH0]| ($(VAR n))
                            |[CH1]| Eat1 -> ($(EAT1 n)))"
apply (cspF_simp unfold_Imp_rules15)
apply (cspF_step_left)+
apply (auto)
apply (cspF_simp fold_Imp_rules15)+
done

lemmas Back0_VAR_Eat1_simp = Back0_VAR_Eat1[simplified]
lemmas unfold_Imp_rules16 = unfold_Imp_rules15 Back0_VAR_Eat1_simp
lemmas fold_Imp_rules16 = fold_Imp_rules15 Back0_VAR_Eat1_simp[THEN cspF_sym]

(*** Back0 VAR Back1 step 3 ***)

lemma Back0_VAR_Back1:
  " (Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
   =F
    ? x:{Back0, Back1}
      -> IF (x = Back0)
            THEN (($TH0) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
            ELSE (Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))"
apply (cspF_simp unfold_Imp_rules16)
apply (cspF_step_left)+
apply (auto)
apply (cspF_simp fold_Imp_rules16)+
done

lemmas Back0_VAR_Back1_simp = Back0_VAR_Back1[simplified]
lemmas unfold_Imp_rules17 = unfold_Imp_rules16 Back0_VAR_Back1_simp
lemmas fold_Imp_rules17 = fold_Imp_rules16 Back0_VAR_Back1_simp[THEN cspF_sym]

(*** WR0 VAR step 4 ***)

lemma WR0_VAR:
  " (WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n)))
   =F
    ? x:insert (WR0 (n div 2)) (insert (RD1 n) (range WR1))
     -> IF (x = WR0 (n div 2))
           THEN (($TH0) |[CH0]| ($(VAR (n div 2))))
           ELSE IF (x = RD1 n)
                THEN (WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n)))
                ELSE (WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR (getInt x))))"
apply (cspF_simp unfold_Imp_rules17)
apply (cspF_step_left)+
apply (auto)
apply (cspF_simp fold_Imp_rules17)+
done

lemmas WR0_VAR_simp = WR0_VAR[simplified]
lemmas unfold_Imp_rules18 = unfold_Imp_rules17 WR0_VAR_simp
lemmas fold_Imp_rules18 = fold_Imp_rules17 WR0_VAR_simp[THEN cspF_sym]

(*** WR0 VAR TH1 step 4 ***)

lemma WR0_VAR_TH1:
  "EVEN n ==>
    (WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))
   =F
    ? x:{(WR0 (n div 2)), (RD1 n)}
      -> IF (x = WR0 (n div 2))
            THEN (($TH0)  |[CH0]| ($(VAR (n div 2))) |[CH1]| ($TH1))
            ELSE (WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n))
                                                |[CH1]| Back1 -> ($TH1))"
apply (cspF_simp unfold_Imp_rules18)
apply (cspF_step_left)+
apply (auto)
apply (cspF_simp fold_Imp_rules18)+
done

lemmas WR0_VAR_TH1_simp = WR0_VAR_TH1[simplified]
lemmas unfold_Imp_rules19 = unfold_Imp_rules18 WR0_VAR_TH1_simp
lemmas fold_Imp_rules19 = fold_Imp_rules18 WR0_VAR_TH1_simp[THEN cspF_sym]

(*** EAT0 VAR Back1 step 4 ***)

lemma EAT0_VAR_Back1:
  "EVEN n ==>
    (($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
   =F
    ? x:{End0, Back1}
      -> IF (x = End0)
            THEN (WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n))
                                                |[CH1]| Back1 -> ($TH1))
            ELSE (($(EAT0 n)) |[CH0]| ($(VAR n)) |[CH1]| ($TH1))"
apply (cspF_simp unfold_Imp_rules19)
apply (cspF_step_left)+
apply (auto)
apply (cspF_simp fold_Imp_rules19)+
done

lemmas EAT0_VAR_Back1_simp = EAT0_VAR_Back1[simplified]
lemmas unfold_Imp_rules20 = unfold_Imp_rules19 EAT0_VAR_Back1_simp
lemmas fold_Imp_rules20 = fold_Imp_rules19 EAT0_VAR_Back1_simp[THEN cspF_sym]

(*** TH0 VAR EAT1 step 4 ***)

lemma TH0_VAR_WR1:
  "ODD n ==>
    (($TH0) |[CH0]| ($(VAR n)) |[CH1]| WR1 (3 * n + 1) -> ($TH1))
   =F
    ? x:{(WR1 (3 * n + 1)), (RD0 n)}
   -> IF (x = WR1 (3 * n + 1))
         THEN (($TH0) |[CH0]| ($(VAR (3 * n + 1))) |[CH1]| ($TH1))
         ELSE (Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                     |[CH1]| WR1 (3 * n + 1) -> ($TH1))"
apply (cspF_simp unfold_Imp_rules20)
apply (cspF_step_left)+
apply (auto)
apply (cspF_simp fold_Imp_rules20)+
done

lemmas TH0_VAR_WR1_simp = TH0_VAR_WR1[simplified]
lemmas unfold_Imp_rules21 = unfold_Imp_rules20 TH0_VAR_WR1_simp
lemmas fold_Imp_rules21 = fold_Imp_rules20 TH0_VAR_WR1_simp[THEN cspF_sym]

(*** Back0 VAR EAT1 step 4 ***)

lemma Back0_VAR_EAT1:
  "ODD n ==>
    (Back0 -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($(EAT1 n)))
   =F
    ? x:{End1, Back0}
   -> IF (x = End1)
         THEN (Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                     |[CH1]| WR1 (3 * n + 1) -> ($TH1))
         ELSE (($TH0) |[CH0]| ($(VAR n)) |[CH1]| ($(EAT1 n)))"
apply (cspF_simp unfold_Imp_rules21)
apply (cspF_step_left)+
apply (auto)
apply (cspF_simp fold_Imp_rules21)+
done

lemmas Back0_VAR_EAT1_simp = Back0_VAR_EAT1[simplified]
lemmas unfold_Imp_rules22 = unfold_Imp_rules21 Back0_VAR_EAT1_simp
lemmas fold_Imp_rules22 = fold_Imp_rules21 Back0_VAR_EAT1_simp[THEN cspF_sym]

(*** WR0 VAR Back1 step 5 ***)

lemma WR0_VAR_Back1:
  "EVEN n ==>
    (WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n)) |[CH1]| Back1 -> ($TH1))
   =F
    ? x:{(WR0 (n div 2)), Back1}
      -> IF (x = WR0 (n div 2))
            THEN (($TH0)  |[CH0]| ($(VAR (n div 2)))
                                |[CH1]| Back1 -> ($TH1))
            ELSE (WR0 (n div 2) -> ($TH0) |[CH0]| ($(VAR n))
                                                |[CH1]| ($TH1))"
apply (cspF_simp unfold_Imp_rules22)
apply (cspF_step_left)+
apply (auto)
apply (cspF_simp fold_Imp_rules22)+
done

lemmas WR0_VAR_Back1_simp = WR0_VAR_Back1[simplified]
lemmas unfold_Imp_rules23 = unfold_Imp_rules22 WR0_VAR_Back1_simp
lemmas fold_Imp_rules23 = fold_Imp_rules22 WR0_VAR_Back1_simp[THEN cspF_sym]

(*** Back0 VAR WR1 step 5 ***)

lemma Back0_VAR_WR1:
  "ODD n ==>
    (Back0 -> ($TH0) |[CH0]| ($(VAR n))
                                 |[CH1]| WR1 (3 * n + 1) -> ($TH1))
   =F
    ? x:{(WR1 (3 * n + 1)), Back0}
   -> IF (x = WR1 (3 * n + 1))
         THEN (Back0 -> ($TH0) |[CH0]| ($(VAR (3 * n + 1)))
                                     |[CH1]| ($TH1))
         ELSE (($TH0) |[CH0]| ($(VAR n))
                            |[CH1]| WR1 (3 * n + 1) -> ($TH1))"
apply (cspF_simp unfold_Imp_rules23)
apply (cspF_step_left)+
apply (auto)
apply (cspF_simp fold_Imp_rules23)+
done

lemmas Back0_VAR_WR1_simp = Back0_VAR_WR1[simplified]
lemmas unfold_Imp_rules24 = unfold_Imp_rules23 Back0_VAR_WR1_simp
lemmas fold_Imp_rules24 = fold_Imp_rules23 Back0_VAR_WR1_simp[THEN cspF_sym]

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Cones and cocones\<close>
theory CZH_ECAT_Cone
  imports
    CZH_ECAT_NTCF
    CZH_ECAT_Hom
    CZH_ECAT_FUNCT
begin

subsection\<open>Cone and cocone\<close>

subsubsection\<open>Definition and elementary properties\<close>

text\<open>
In the context of this work, the concept of a cone corresponds to that of a cone
to the base of a functor from a vertex, as defined in Chapter III-4 in
\<^cite>\<open>"mac_lane_categories_2010"\<close>; the concept of a cocone corresponds to that
of a cone from the base of a functor to a vertex, as defined in Chapter III-3
in \<^cite>\<open>"mac_lane_categories_2010"\<close>.
\<close>

locale is_cat_cone = is_ntcf \<alpha> \<JJ> \<CC> \<open>cf_const \<JJ> \<CC> c\<close> \<FF> \<NN> for \<alpha> c \<JJ> \<CC> \<FF> \<NN> +
  assumes cat_cone_obj[cat_cs_intros]: "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"

syntax "_is_cat_cone" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e _ :/ _ \<mapsto>\<mapsto>\<^sub>C\<index> _)\<close> [51, 51, 51, 51, 51] 51)
translations "\<NN> : c <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<FF> : \<JJ> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" \<rightleftharpoons>
  "CONST is_cat_cone \<alpha> c \<JJ> \<CC> \<FF> \<NN>"

locale is_cat_cocone = is_ntcf \<alpha> \<JJ> \<CC> \<FF> \<open>cf_const \<JJ> \<CC> c\<close> \<NN> for \<alpha> c \<JJ> \<CC> \<FF> \<NN> +
  assumes cat_cocone_obj[cat_cs_intros]: "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"

syntax "_is_cat_cocone" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e _ :/ _ \<mapsto>\<mapsto>\<^sub>C\<index> _)\<close> [51, 51, 51, 51, 51] 51)
translations "\<NN> : \<FF> >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e c : \<JJ> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" \<rightleftharpoons>
  "CONST is_cat_cocone \<alpha> c \<JJ> \<CC> \<FF> \<NN>"

text\<open>Rules.\<close>

lemma (in is_cat_cone) is_cat_cone_axioms'[cat_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "c' = c" and "\<JJ>' = \<JJ>" and "\<CC>' = \<CC>" and "\<FF>' = \<FF>"
  shows "\<NN> : c' <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<FF>' : \<JJ>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>'\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_cone_axioms)

mk_ide rf is_cat_cone_def[unfolded is_cat_cone_axioms_def]
  |intro is_cat_coneI|
  |dest is_cat_coneD[dest!]|
  |elim is_cat_coneE[elim!]|

lemma (in is_cat_cone) is_cat_coneD'[cat_cs_intros]:
  assumes "c' = cf_const \<JJ> \<CC> c"
  shows "\<NN> : c' \<mapsto>\<^sub>C\<^sub>F \<FF> : \<JJ> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  unfolding assms by (cs_concl cs_shallow cs_intro: cat_cs_intros)

lemma (in is_cat_cocone) is_cat_cocone_axioms'[cat_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "c' = c" and "\<JJ>' = \<JJ>" and "\<CC>' = \<CC>" and "\<FF>' = \<FF>"
  shows "\<NN> : \<FF>' >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e c' : \<JJ>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>'\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_cocone_axioms)

mk_ide rf is_cat_cocone_def[unfolded is_cat_cocone_axioms_def]
  |intro is_cat_coconeI|
  |dest is_cat_coconeD[dest!]|
  |elim is_cat_coconeE[elim!]|

lemma (in is_cat_cocone) is_cat_coconeD'[cat_cs_intros]:
  assumes "c' = cf_const \<JJ> \<CC> c"
  shows "\<NN> : \<FF> \<mapsto>\<^sub>C\<^sub>F c' : \<JJ> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  unfolding assms by (cs_concl cs_shallow cs_intro: cat_cs_intros)

text\<open>Duality.\<close>

lemma (in is_cat_cone) is_cat_cocone_op:
  "op_ntcf \<NN> : op_cf \<FF> >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e c : op_cat \<JJ> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> op_cat \<CC>"
  by (intro is_cat_coconeI)
    (
      cs_concl cs_shallow
        cs_simp: cat_op_simps cs_intro: cat_cs_intros cat_op_intros
    )+

lemma (in is_cat_cone) is_cat_cocone_op'[cat_op_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<JJ>' = op_cat \<JJ>" and "\<CC>' = op_cat \<CC>" and "\<FF>' = op_cf \<FF>"
  shows "op_ntcf \<NN> : \<FF>' >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e c : \<JJ>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>'\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_cocone_op)

lemmas [cat_op_intros] = is_cat_cone.is_cat_cocone_op'

lemma (in is_cat_cocone) is_cat_cone_op:
  "op_ntcf \<NN> : c <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e op_cf \<FF> : op_cat \<JJ> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> op_cat \<CC>"
  by (intro is_cat_coneI)
    (
      cs_concl cs_shallow
        cs_simp: cat_op_simps cs_intro: cat_cs_intros cat_op_intros
    )

lemma (in is_cat_cocone) is_cat_cone_op'[cat_op_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<JJ>' = op_cat \<JJ>" and "\<CC>' = op_cat \<CC>" and "\<FF>' = op_cf \<FF>"
  shows "op_ntcf \<NN> : c <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<FF>' : \<JJ>' \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>'\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_cone_op)

lemmas [cat_op_intros] = is_cat_cocone.is_cat_cone_op'

text\<open>Elementary properties.\<close>

lemma (in is_cat_cone) cat_cone_LArr_app_is_arr:
  assumes "j \<in>\<^sub>\<circ> \<JJ>\<lparr>Obj\<rparr>"
  shows "\<NN>\<lparr>NTMap\<rparr>\<lparr>j\<rparr> : c \<mapsto>\<^bsub>\<CC>\<^esub> \<FF>\<lparr>ObjMap\<rparr>\<lparr>j\<rparr>"
proof-
  from assms have [simp]: "cf_const \<JJ> \<CC> c\<lparr>ObjMap\<rparr>\<lparr>j\<rparr> = c"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps)
  from ntcf_NTMap_is_arr[OF assms] show ?thesis by simp
qed

lemma (in is_cat_cone) cat_cone_LArr_app_is_arr'[cat_cs_intros]:
  assumes "j \<in>\<^sub>\<circ> \<JJ>\<lparr>Obj\<rparr>" and "\<FF>j = \<FF>\<lparr>ObjMap\<rparr>\<lparr>j\<rparr>"
  shows "\<NN>\<lparr>NTMap\<rparr>\<lparr>j\<rparr> : c \<mapsto>\<^bsub>\<CC>\<^esub> \<FF>j"
  using assms(1) unfolding assms(2) by (rule cat_cone_LArr_app_is_arr)

lemmas [cat_cs_intros] = is_cat_cone.cat_cone_LArr_app_is_arr'

lemma (in is_cat_cocone) cat_cocone_LArr_app_is_arr:
  assumes "j \<in>\<^sub>\<circ> \<JJ>\<lparr>Obj\<rparr>"
  shows "\<NN>\<lparr>NTMap\<rparr>\<lparr>j\<rparr> : \<FF>\<lparr>ObjMap\<rparr>\<lparr>j\<rparr> \<mapsto>\<^bsub>\<CC>\<^esub> c"
proof-
  from assms have [simp]: "cf_const \<JJ> \<CC> c\<lparr>ObjMap\<rparr>\<lparr>j\<rparr> = c"
    by (cs_concl cs_shallow cs_simp: cat_cs_simps)
  from ntcf_NTMap_is_arr[OF assms] show ?thesis by simp
qed

lemma (in is_cat_cocone) cat_cocone_LArr_app_is_arr'[cat_cs_intros]:
  assumes "j \<in>\<^sub>\<circ> \<JJ>\<lparr>Obj\<rparr>" and "\<FF>j = \<FF>\<lparr>ObjMap\<rparr>\<lparr>j\<rparr>"
  shows "\<NN>\<lparr>NTMap\<rparr>\<lparr>j\<rparr> : \<FF>j \<mapsto>\<^bsub>\<CC>\<^esub> c"
  using assms(1) unfolding assms(2) by (rule cat_cocone_LArr_app_is_arr)

lemmas [cat_cs_intros] = is_cat_cocone.cat_cocone_LArr_app_is_arr'

lemma (in is_cat_cone) cat_cone_Comp_commute[cat_cs_simps]:
  assumes "f : a \<mapsto>\<^bsub>\<JJ>\<^esub> b"
  shows "\<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<NN>\<lparr>NTMap\<rparr>\<lparr>a\<rparr> = \<NN>\<lparr>NTMap\<rparr>\<lparr>b\<rparr>"
  using ntcf_Comp_commute[symmetric, OF assms] assms
  by (cs_prems cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

thm (*not ca_cs_simps*) is_cat_cone.cat_cone_Comp_commute

lemma (in is_cat_cocone) cat_cocone_Comp_commute[cat_cs_simps]:
  assumes "f : a \<mapsto>\<^bsub>\<JJ>\<^esub> b"
  shows "\<NN>\<lparr>NTMap\<rparr>\<lparr>b\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> = \<NN>\<lparr>NTMap\<rparr>\<lparr>a\<rparr>"
  using ntcf_Comp_commute[OF assms] assms
  by
    (
      cs_prems
        cs_simp: cat_cs_simps dghm_const_ArrMap_app cs_intro: cat_cs_intros
    )

thm (*not ca_cs_simps*) is_cat_cocone.cat_cocone_Comp_commute

text\<open>Utilities/helper lemmas.\<close>

lemma (in is_cat_cone) helper_cat_cone_ntcf_vcomp_Comp:
  assumes "\<NN>' : c' <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<FF> : \<JJ> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
    and "f' : c' \<mapsto>\<^bsub>\<CC>\<^esub> c"
    and "\<NN>' = \<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<JJ> \<CC> f'"
    and "j \<in>\<^sub>\<circ> \<JJ>\<lparr>Obj\<rparr>"
  shows "\<NN>'\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = \<NN>\<lparr>NTMap\<rparr>\<lparr>j\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f'"
proof-
  from assms(3) have "\<NN>'\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = (\<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<JJ> \<CC> f')\<lparr>NTMap\<rparr>\<lparr>j\<rparr>"
    by simp
  from this assms(1,2,4) show "\<NN>'\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = \<NN>\<lparr>NTMap\<rparr>\<lparr>j\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f'"
    by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
qed

lemma (in is_cat_cone) helper_cat_cone_Comp_ntcf_vcomp:
  assumes "\<NN>' : c' <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<FF> : \<JJ> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
    and "f' : c' \<mapsto>\<^bsub>\<CC>\<^esub> c"
    and "\<And>j. j \<in>\<^sub>\<circ> \<JJ>\<lparr>Obj\<rparr> \<Longrightarrow> \<NN>'\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = \<NN>\<lparr>NTMap\<rparr>\<lparr>j\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f'"
  shows "\<NN>' = \<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<JJ> \<CC> f'"
proof-
  interpret \<NN>': is_cat_cone \<alpha> c' \<JJ> \<CC> \<FF> \<NN>' by (rule assms(1))
  show ?thesis
  proof(rule ntcf_eqI[OF \<NN>'.is_ntcf_axioms])
    from assms(2) show
      "\<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<JJ> \<CC> f' : cf_const \<JJ> \<CC> c' \<mapsto>\<^sub>C\<^sub>F \<FF> : \<JJ> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    show "\<NN>'\<lparr>NTMap\<rparr> = (\<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<JJ> \<CC> f')\<lparr>NTMap\<rparr>"
    proof(rule vsv_eqI, unfold cat_cs_simps)
      show "vsv ((\<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<JJ> \<CC> f')\<lparr>NTMap\<rparr>)"
        by (cs_concl cs_intro: cat_cs_intros)
      from assms show "\<JJ>\<lparr>Obj\<rparr> = \<D>\<^sub>\<circ> ((\<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<JJ> \<CC> f')\<lparr>NTMap\<rparr>)"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      fix j assume prems': "j \<in>\<^sub>\<circ> \<JJ>\<lparr>Obj\<rparr>"
      with assms(1,2) show "\<NN>'\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = (\<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<JJ> \<CC> f')\<lparr>NTMap\<rparr>\<lparr>j\<rparr>"
        by (cs_concl cs_simp: cat_cs_simps assms(3) cs_intro: cat_cs_intros)
    qed auto
  qed simp_all
qed

lemma (in is_cat_cone) helper_cat_cone_Comp_ntcf_vcomp_iff:
  assumes "\<NN>' : c' <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<FF> : \<JJ> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "f' : c' \<mapsto>\<^bsub>\<CC>\<^esub> c \<and> \<NN>' = \<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<JJ> \<CC> f' \<longleftrightarrow>
    f' : c' \<mapsto>\<^bsub>\<CC>\<^esub> c \<and> (\<forall>j\<in>\<^sub>\<circ>\<JJ>\<lparr>Obj\<rparr>. \<NN>'\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = \<NN>\<lparr>NTMap\<rparr>\<lparr>j\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f')"
  using
    helper_cat_cone_ntcf_vcomp_Comp[OF assms]
    helper_cat_cone_Comp_ntcf_vcomp[OF assms]
  by (intro iffI; elim conjE; intro conjI) metis+

lemma (in is_cat_cocone) helper_cat_cocone_ntcf_vcomp_Comp:
  assumes "\<NN>' : \<FF> >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e c' : \<JJ> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
    and "f' : c \<mapsto>\<^bsub>\<CC>\<^esub> c'"
    and "\<NN>' = ntcf_const \<JJ> \<CC> f' \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F \<NN>"
    and "j \<in>\<^sub>\<circ> \<JJ>\<lparr>Obj\<rparr>"
  shows "\<NN>'\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = f' \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<NN>\<lparr>NTMap\<rparr>\<lparr>j\<rparr>"
proof-
  interpret \<NN>': is_cat_cocone \<alpha> c' \<JJ> \<CC> \<FF> \<NN>' by (rule assms(1))
  from assms(3) have "op_ntcf \<NN>' = op_ntcf (ntcf_const \<JJ> \<CC> f' \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F \<NN>)" by simp
  from this assms(2) have op_\<NN>':
    "op_ntcf \<NN>' = op_ntcf \<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const (op_cat \<JJ>) (op_cat \<CC>) f'"
    by (cs_prems cs_simp: cat_op_simps cs_intro: cat_cs_intros cat_op_intros)
  have "\<NN>'\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = \<NN>\<lparr>NTMap\<rparr>\<lparr>j\<rparr> \<circ>\<^sub>A\<^bsub>op_cat \<CC>\<^esub> f'"
    by
      (
        rule is_cat_cone.helper_cat_cone_ntcf_vcomp_Comp[
          OF is_cat_cone_op \<NN>'.is_cat_cone_op,
          unfolded cat_op_simps,
          OF assms(2) op_\<NN>' assms(4)
          ]
      )
  from this assms(2,4) show "\<NN>'\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = f' \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<NN>\<lparr>NTMap\<rparr>\<lparr>j\<rparr>"
    by
      (
        cs_prems cs_shallow
          cs_simp: cat_cs_simps cat_op_simps cs_intro: cat_cs_intros
      )
qed

lemma (in is_cat_cocone) helper_cat_cocone_Comp_ntcf_vcomp:
  assumes "\<NN>' : \<FF> >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e c' : \<JJ> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
    and "f' : c \<mapsto>\<^bsub>\<CC>\<^esub> c'"
    and "\<And>j. j \<in>\<^sub>\<circ> \<JJ>\<lparr>Obj\<rparr> \<Longrightarrow> \<NN>'\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = f' \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<NN>\<lparr>NTMap\<rparr>\<lparr>j\<rparr>"
  shows "\<NN>' = ntcf_const \<JJ> \<CC> f' \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F \<NN>"
proof-
  interpret \<NN>': is_cat_cocone \<alpha> c' \<JJ> \<CC> \<FF> \<NN>' by (rule assms(1))
  from assms(2) have \<NN>'j: "\<NN>'\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = \<NN>\<lparr>NTMap\<rparr>\<lparr>j\<rparr> \<circ>\<^sub>A\<^bsub>op_cat \<CC>\<^esub> f'"
    if "j \<in>\<^sub>\<circ> \<JJ>\<lparr>Obj\<rparr>" for j
    using that
    unfolding assms(3)[OF that]
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_op_simps cat_cs_simps cs_intro: cat_cs_intros
      )
  have op_\<NN>':
    "op_ntcf \<NN>' = op_ntcf \<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const (op_cat \<JJ>) (op_cat \<CC>) f'"
    by
      (
        rule is_cat_cone.helper_cat_cone_Comp_ntcf_vcomp[
          OF is_cat_cone_op \<NN>'.is_cat_cone_op,
          unfolded cat_op_simps,
          OF assms(2) \<NN>'j,
          simplified
          ]
      )
  from assms(2) show "\<NN>' = (ntcf_const \<JJ> \<CC> f' \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F \<NN>)"
    by
      (
        cs_concl
          cs_simp:
            cat_op_simps op_\<NN>' eq_op_ntcf_iff[symmetric, OF \<NN>'.is_ntcf_axioms]
          cs_intro: cat_cs_intros
      )
qed

lemma (in is_cat_cocone) helper_cat_cocone_Comp_ntcf_vcomp_iff:
  assumes "\<NN>' : \<FF> >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e c' : \<JJ> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "f' : c \<mapsto>\<^bsub>\<CC>\<^esub> c' \<and> \<NN>' = ntcf_const \<JJ> \<CC> f' \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F \<NN> \<longleftrightarrow>
    f' : c \<mapsto>\<^bsub>\<CC>\<^esub> c' \<and> (\<forall>j\<in>\<^sub>\<circ>\<JJ>\<lparr>Obj\<rparr>. \<NN>'\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = f' \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<NN>\<lparr>NTMap\<rparr>\<lparr>j\<rparr>)"
  using
    helper_cat_cocone_ntcf_vcomp_Comp[OF assms]
    helper_cat_cocone_Comp_ntcf_vcomp[OF assms]
  by (intro iffI; elim conjE; intro conjI) metis+

subsubsection\<open>Vertical composition of a natural transformation and a cone\<close>

lemma ntcf_vcomp_is_cat_cone[cat_cs_intros]:
  assumes "\<MM> : \<GG> \<mapsto>\<^sub>C\<^sub>F \<HH> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
    and "\<NN> : a <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
  shows "\<MM> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F \<NN> : a <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<HH> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
  by
    (
      intro is_cat_coneI ntcf_vcomp_is_ntcf, rule assms(1);
      rule is_cat_coneD[OF assms(2)]
    )

subsubsection\<open>
Composition of a functor and a cone, composition of a functor and a cocone
\<close>

lemma cf_ntcf_comp_cf_cat_cone:
  assumes "\<NN> : c <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>" and "\<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "\<GG> \<circ>\<^sub>C\<^sub>F\<^sub>-\<^sub>N\<^sub>T\<^sub>C\<^sub>F \<NN> : \<GG>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr> <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<GG> \<circ>\<^sub>C\<^sub>F \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
proof-
  interpret \<NN>: is_cat_cone \<alpha> c \<AA> \<BB> \<FF> \<NN> by (rule assms(1))
  interpret \<GG>: is_functor \<alpha> \<BB> \<CC> \<GG> by (rule assms(2))
  show ?thesis
    by (intro is_cat_coneI)
      (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros )+
qed

lemma cf_ntcf_comp_cf_cat_cone'[cat_cs_intros]:
  assumes "\<NN> : c <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
    and "\<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
    and "c' = \<GG>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>"
    and "\<GG>\<FF> = \<GG> \<circ>\<^sub>C\<^sub>F \<FF>"
  shows "\<GG> \<circ>\<^sub>C\<^sub>F\<^sub>-\<^sub>N\<^sub>T\<^sub>C\<^sub>F \<NN> : c' <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<GG>\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  using assms(1,2) unfolding assms(3,4) by (rule cf_ntcf_comp_cf_cat_cone)

lemma cf_ntcf_comp_cf_cat_cocone:
  assumes "\<NN> : \<FF> >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e c : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>" and "\<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "\<GG> \<circ>\<^sub>C\<^sub>F\<^sub>-\<^sub>N\<^sub>T\<^sub>C\<^sub>F \<NN> : \<GG> \<circ>\<^sub>C\<^sub>F \<FF> >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<GG>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
proof-
  interpret \<NN>: is_cat_cocone \<alpha> c \<AA> \<BB> \<FF> \<NN> by (rule assms(1))
  interpret \<GG>: is_functor \<alpha> \<BB> \<CC> \<GG> by (rule assms(2))
  show ?thesis
    by
      (
        rule is_cat_cone.is_cat_cocone_op
          [
            OF cf_ntcf_comp_cf_cat_cone[
              OF \<NN>.is_cat_cone_op \<GG>.is_functor_op, unfolded cat_op_simps
              ],
            unfolded cat_op_simps
          ]
      )
qed

lemma cf_ntcf_comp_cf_cat_cocone'[cat_cs_intros]:
  assumes "\<NN> : \<FF> >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e c : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
    and "\<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
    and "c' = \<GG>\<lparr>ObjMap\<rparr>\<lparr>c\<rparr>"
    and "\<GG>\<FF> = \<GG> \<circ>\<^sub>C\<^sub>F \<FF>"
  shows "\<GG> \<circ>\<^sub>C\<^sub>F\<^sub>-\<^sub>N\<^sub>T\<^sub>C\<^sub>F \<NN> : \<GG>\<FF> >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e c' : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  using assms(1,2) unfolding assms(3,4) by (rule cf_ntcf_comp_cf_cat_cocone)

subsubsection\<open>Cones, cocones and constant natural transformations\<close>

lemma ntcf_vcomp_ntcf_const_is_cat_cone:
  assumes "\<NN> : b <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>" and "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b"
  shows "\<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<AA> \<BB> f : a <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
proof-
  interpret \<NN>: is_cat_cone \<alpha> b \<AA> \<BB> \<FF> \<NN> by (rule assms(1))
  from assms(2) show ?thesis
    by (intro is_cat_coneI) (cs_concl cs_intro: cat_cs_intros)
qed

lemma ntcf_vcomp_ntcf_const_is_cat_cone'[cat_cs_intros]:
  assumes "\<NN> : b <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
    and "\<MM> = ntcf_const \<AA> \<BB> f"
    and "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b"
  shows "\<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F \<MM> : a <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
  using assms(1,3) unfolding assms(2) by (rule ntcf_vcomp_ntcf_const_is_cat_cone)

lemma ntcf_vcomp_ntcf_const_is_cat_cocone:
  assumes "\<NN> : \<FF> >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e a : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>" and "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b"
  shows "ntcf_const \<AA> \<BB> f \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F \<NN> : \<FF> >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e b : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
proof-
  interpret \<NN>: is_cat_cocone \<alpha> a \<AA> \<BB> \<FF> \<NN> by (rule assms(1))
  from is_cat_cone.is_cat_cocone_op
    [
      OF ntcf_vcomp_ntcf_const_is_cat_cone[
        OF \<NN>.is_cat_cone_op, unfolded cat_op_simps, OF assms(2)
        ],
      unfolded cat_op_simps,
      folded op_ntcf_ntcf_const
    ]
    assms(2)
  show ?thesis
    by (cs_prems cs_simp: cat_op_simps cs_intro: cat_cs_intros cat_op_intros)
qed

lemma ntcf_vcomp_ntcf_const_is_cat_cocone'[cat_cs_intros]:
  assumes "\<NN> : \<FF> >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e a : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
    and "\<MM> = ntcf_const \<AA> \<BB> f"
    and "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b"
  shows "\<MM> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F \<NN> : \<FF> >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e b : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
  using assms(1,3)
  unfolding assms(2)
  by (rule ntcf_vcomp_ntcf_const_is_cat_cocone)

lemma ntcf_vcomp_ntcf_const_CId:
  assumes "\<NN> : b <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
  shows "\<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<AA> \<BB> (\<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>) = \<NN>"
proof-

  interpret \<NN>: is_cat_cone \<alpha> b \<AA> \<BB> \<FF> \<NN> by (rule assms)

  show ?thesis
  proof(rule ntcf_eqI)

    from \<NN>.cat_cone_obj show lhs_is_ntcf:
      "\<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<AA> \<BB> (\<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>) :
        cf_const \<AA> \<BB> b \<mapsto>\<^sub>C\<^sub>F \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    then have dom_lhs:
      "\<D>\<^sub>\<circ> ((\<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<AA> \<BB> (\<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>))\<lparr>NTMap\<rparr>) = \<AA>\<lparr>Obj\<rparr>"
      by (simp add: cat_cs_simps)

    from \<NN>.cat_cone_obj show "\<NN> : cf_const \<AA> \<BB> b \<mapsto>\<^sub>C\<^sub>F \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    then have dom_rhs: "\<D>\<^sub>\<circ> (\<NN>\<lparr>NTMap\<rparr>) = \<AA>\<lparr>Obj\<rparr>"
      by (simp add: cat_cs_simps)

    show "(\<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<AA> \<BB> (\<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>))\<lparr>NTMap\<rparr> = \<NN>\<lparr>NTMap\<rparr>"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
      fix a assume prems: "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
      from prems \<NN>.cat_cone_obj show
        "(\<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<AA> \<BB> (\<BB>\<lparr>CId\<rparr>\<lparr>b\<rparr>))\<lparr>NTMap\<rparr>\<lparr>a\<rparr> = \<NN>\<lparr>NTMap\<rparr>\<lparr>a\<rparr>"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    qed (use lhs_is_ntcf in \<open>cs_concl cs_intro: cat_cs_intros\<close>)+

  qed simp_all

qed

lemma ntcf_vcomp_ntcf_const_CId'[cat_cs_simps]:
  assumes "\<NN> : b <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>" and "\<BB>' = \<BB>"
  shows "\<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<AA> \<BB> (\<BB>'\<lparr>CId\<rparr>\<lparr>b\<rparr>) = \<NN>"
  using assms(1) unfolding assms(2) by (rule ntcf_vcomp_ntcf_const_CId)

subsection\<open>Cone and cocone functors\<close>

subsubsection\<open>Definition and elementary properties\<close>

text\<open>See Chapter V-1 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.\<close>

definition cf_Cone :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
  where "cf_Cone \<alpha> \<beta> \<FF> =
    Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<beta>\<^esub>cat_FUNCT \<alpha> (\<FF>\<lparr>HomDom\<rparr>) (\<FF>\<lparr>HomCod\<rparr>)(-,cf_map \<FF>) \<circ>\<^sub>C\<^sub>F
    op_cf (\<Delta>\<^sub>C\<^sub>F \<alpha> (\<FF>\<lparr>HomDom\<rparr>) (\<FF>\<lparr>HomCod\<rparr>))"

definition cf_Cocone :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
  where "cf_Cocone \<alpha> \<beta> \<FF> =
    Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<beta>\<^esub>cat_FUNCT \<alpha> (\<FF>\<lparr>HomDom\<rparr>) (\<FF>\<lparr>HomCod\<rparr>)(cf_map \<FF>,-) \<circ>\<^sub>C\<^sub>F
    (\<Delta>\<^sub>C\<^sub>F \<alpha> (\<FF>\<lparr>HomDom\<rparr>) (\<FF>\<lparr>HomCod\<rparr>))"

text\<open>An alternative form of the definition.\<close>

context is_functor
begin

lemma cf_Cone_def':
  "cf_Cone \<alpha> \<beta> \<FF> = Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<beta>\<^esub>cat_FUNCT \<alpha> \<AA> \<BB>(-,cf_map \<FF>) \<circ>\<^sub>C\<^sub>F op_cf (\<Delta>\<^sub>C\<^sub>F \<alpha> \<AA> \<BB>)"
  unfolding cf_Cone_def cat_cs_simps by simp

lemma cf_Cocone_def':
  "cf_Cocone \<alpha> \<beta> \<FF> = Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<beta>\<^esub>cat_FUNCT \<alpha> \<AA> \<BB>(cf_map \<FF>,-) \<circ>\<^sub>C\<^sub>F (\<Delta>\<^sub>C\<^sub>F \<alpha> \<AA> \<BB>)"
  unfolding cf_Cocone_def cat_cs_simps by simp

end

subsubsection\<open>Object map\<close>

lemma (in is_functor) cf_Cone_ObjMap_vsv[cat_cs_intros]:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "vsv (cf_Cone \<alpha> \<beta> \<FF>\<lparr>ObjMap\<rparr>)"
proof-
  from assms interpret \<beta>: \<Z> \<beta> by simp
  from assms interpret \<Delta>: is_functor \<beta> \<BB> \<open>cat_FUNCT \<alpha> \<AA> \<BB>\<close> \<open>\<Delta>\<^sub>C\<^sub>F \<alpha> \<AA> \<BB>\<close>
    by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_op_intros)+
  from assms(2) show ?thesis
    unfolding cf_Cone_def'
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps cat_FUNCT_components(1) cat_op_simps
          cs_intro: cat_cs_intros cat_FUNCT_cs_intros cat_op_intros
      )
qed

lemmas [cat_cs_intros] = is_functor.cf_Cone_ObjMap_vsv

lemma (in is_functor) cf_Cocone_ObjMap_vsv[cat_cs_intros]:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "vsv (cf_Cocone \<alpha> \<beta> \<FF>\<lparr>ObjMap\<rparr>)"
proof-
  from assms interpret \<beta>: \<Z> \<beta> by simp
  from assms interpret \<Delta>: is_functor \<beta> \<BB> \<open>cat_FUNCT \<alpha> \<AA> \<BB>\<close> \<open>\<Delta>\<^sub>C\<^sub>F \<alpha> \<AA> \<BB>\<close>
    by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_op_intros)+
  from assms(2) show ?thesis
    unfolding cf_Cocone_def'
    by
      (
        cs_concl
          cs_simp: cat_cs_simps cat_FUNCT_cs_simps cat_op_simps
          cs_intro: cat_cs_intros cat_FUNCT_cs_intros cat_op_intros
      )
qed

lemmas [cat_cs_intros] = is_functor.cf_Cocone_ObjMap_vsv

lemma (in is_functor) cf_Cone_ObjMap_vdomain[cat_cs_simps]:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>" and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
  shows "\<D>\<^sub>\<circ> (cf_Cone \<alpha> \<beta> \<FF>\<lparr>ObjMap\<rparr>) = \<BB>\<lparr>Obj\<rparr>"
proof-
  from assms interpret \<beta>: \<Z> \<beta> by simp
  from assms interpret \<Delta>: is_functor \<beta> \<BB> \<open>cat_FUNCT \<alpha> \<AA> \<BB>\<close> \<open>\<Delta>\<^sub>C\<^sub>F \<alpha> \<AA> \<BB>\<close>
    by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_op_intros)+
  from assms show ?thesis
    unfolding cf_Cone_def'
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps cat_FUNCT_components(1) cat_op_simps
          cs_intro: cat_cs_intros cat_FUNCT_cs_intros cat_op_intros
      )
qed

lemmas [cat_cs_simps] = is_functor.cf_Cone_ObjMap_vdomain

lemma (in is_functor) cf_Cocone_ObjMap_vdomain[cat_cs_simps]:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>" and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
  shows "\<D>\<^sub>\<circ> (cf_Cocone \<alpha> \<beta> \<FF>\<lparr>ObjMap\<rparr>) = \<BB>\<lparr>Obj\<rparr>"
proof-
  from assms interpret \<beta>: \<Z> \<beta> by simp
  from assms interpret \<Delta>: is_functor \<beta> \<BB> \<open>cat_FUNCT \<alpha> \<AA> \<BB>\<close> \<open>\<Delta>\<^sub>C\<^sub>F \<alpha> \<AA> \<BB>\<close>
    by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_op_intros)+
  from assms show ?thesis
    unfolding cf_Cocone_def'
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps cat_FUNCT_components(1) cat_op_simps
          cs_intro: cat_cs_intros cat_FUNCT_cs_intros cat_op_intros
      )
qed

lemmas [cat_cs_simps] = is_functor.cf_Cocone_ObjMap_vdomain

lemma (in is_functor) cf_Cone_ObjMap_app[cat_cs_simps]:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>" and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
  shows "cf_Cone \<alpha> \<beta> \<FF>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr> =
    Hom (cat_FUNCT \<alpha> \<AA> \<BB>) (cf_map (cf_const \<AA> \<BB> b)) (cf_map \<FF>)"
proof-
  from assms interpret \<beta>: \<Z> \<beta> by simp
  from assms interpret \<Delta>: is_functor \<beta> \<BB> \<open>cat_FUNCT \<alpha> \<AA> \<BB>\<close> \<open>\<Delta>\<^sub>C\<^sub>F \<alpha> \<AA> \<BB>\<close>
    by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_op_intros)+
  from assms(2,3) show ?thesis
    unfolding cf_Cone_def'
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps cat_FUNCT_components(1) cat_op_simps
          cs_intro: cat_cs_intros cat_FUNCT_cs_intros cat_op_intros
      )
qed

lemmas [cat_cs_simps] = is_functor.cf_Cone_ObjMap_app

lemma (in is_functor) cf_Cocone_ObjMap_app[cat_cs_simps]:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>" and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
  shows "cf_Cocone \<alpha> \<beta> \<FF>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr> =
    Hom (cat_FUNCT \<alpha> \<AA> \<BB>) (cf_map \<FF>) (cf_map (cf_const \<AA> \<BB> b))"
proof-
  from assms interpret \<beta>: \<Z> \<beta> by simp
  from assms interpret \<Delta>: is_functor \<beta> \<BB> \<open>cat_FUNCT \<alpha> \<AA> \<BB>\<close> \<open>\<Delta>\<^sub>C\<^sub>F \<alpha> \<AA> \<BB>\<close>
    by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_op_intros)+
  from assms(2,3) show ?thesis
    unfolding cf_Cocone_def'
    by
      (
        cs_concl
          cs_simp: cat_cs_simps cat_FUNCT_components(1) cat_op_simps
          cs_intro: cat_cs_intros cat_FUNCT_cs_intros cat_op_intros
      )
qed

lemmas [cat_cs_simps] = is_functor.cf_Cocone_ObjMap_app

subsubsection\<open>Arrow map\<close>

lemma (in is_functor) cf_Cone_ArrMap_vsv[cat_cs_intros]:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "vsv (cf_Cone \<alpha> \<beta> \<FF>\<lparr>ArrMap\<rparr>)"
proof-
  from assms interpret \<beta>: \<Z> \<beta> by simp
  from assms interpret \<Delta>: is_functor \<beta> \<BB> \<open>cat_FUNCT \<alpha> \<AA> \<BB>\<close> \<open>\<Delta>\<^sub>C\<^sub>F \<alpha> \<AA> \<BB>\<close>
    by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_op_intros)+
  from assms(2) show ?thesis
    unfolding cf_Cone_def
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps cat_FUNCT_components(1) cat_op_simps
          cs_intro: cat_cs_intros cat_FUNCT_cs_intros cat_op_intros
      )
qed

lemmas [cat_cs_intros] = is_functor.cf_Cone_ArrMap_vsv

lemma (in is_functor) cf_Cocone_ArrMap_vsv[cat_cs_intros]:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "vsv (cf_Cocone \<alpha> \<beta> \<FF>\<lparr>ArrMap\<rparr>)"
proof-
  from assms interpret \<beta>: \<Z> \<beta> by simp
  from assms interpret \<Delta>: is_functor \<beta> \<BB> \<open>cat_FUNCT \<alpha> \<AA> \<BB>\<close> \<open>\<Delta>\<^sub>C\<^sub>F \<alpha> \<AA> \<BB>\<close>
    by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_op_intros)+
  from assms(2) show ?thesis
    unfolding cf_Cocone_def'
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps cat_FUNCT_components(1) cat_op_simps
          cs_intro: cat_cs_intros cat_FUNCT_cs_intros cat_op_intros
      )
qed

lemmas [cat_cs_intros] = is_functor.cf_Cocone_ArrMap_vsv

lemma (in is_functor) cf_Cone_ArrMap_vdomain[cat_cs_simps]:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>" and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
  shows "\<D>\<^sub>\<circ> (cf_Cone \<alpha> \<beta> \<FF>\<lparr>ArrMap\<rparr>) = \<BB>\<lparr>Arr\<rparr>"
proof-
  from assms interpret \<beta>: \<Z> \<beta> by simp
  from assms interpret \<Delta>: is_functor \<beta> \<BB> \<open>cat_FUNCT \<alpha> \<AA> \<BB>\<close> \<open>\<Delta>\<^sub>C\<^sub>F \<alpha> \<AA> \<BB>\<close>
    by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_op_intros)+
  from assms(2) show ?thesis
    unfolding cf_Cone_def'
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps cat_FUNCT_components(1) cat_op_simps
          cs_intro: cat_cs_intros cat_FUNCT_cs_intros cat_op_intros
      )
qed

lemmas [cat_cs_simps] = is_functor.cf_Cone_ArrMap_vdomain

lemma (in is_functor) cf_Cocone_ArrMap_vdomain[cat_cs_simps]:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>" and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
  shows "\<D>\<^sub>\<circ> (cf_Cocone \<alpha> \<beta> \<FF>\<lparr>ArrMap\<rparr>) = \<BB>\<lparr>Arr\<rparr>"
proof-
  from assms interpret \<beta>: \<Z> \<beta> by simp
  from assms interpret \<Delta>: is_functor \<beta> \<BB> \<open>cat_FUNCT \<alpha> \<AA> \<BB>\<close> \<open>\<Delta>\<^sub>C\<^sub>F \<alpha> \<AA> \<BB>\<close>
    by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_op_intros)+
  from assms(2) show ?thesis
    unfolding cf_Cocone_def'
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_cs_simps cat_FUNCT_components(1) cat_op_simps
          cs_intro: cat_cs_intros cat_FUNCT_cs_intros cat_op_intros
      )
qed

lemmas [cat_cs_simps] = is_functor.cf_Cocone_ArrMap_vdomain

lemma (in is_functor) cf_Cone_ArrMap_app[cat_cs_simps]:
  assumes "\<Z> \<beta>"
    and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
    and "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b"
  shows "cf_Cone \<alpha> \<beta> \<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> = cf_hom
    (cat_FUNCT \<alpha> \<AA> \<BB>)
    [ntcf_arrow (ntcf_const \<AA> \<BB> f), cat_FUNCT \<alpha> \<AA> \<BB>\<lparr>CId\<rparr>\<lparr>cf_map \<FF>\<rparr>]\<^sub>\<circ>"
proof-
  from assms interpret \<beta>: \<Z> \<beta> by simp
  from assms interpret \<Delta>: is_functor \<beta> \<BB> \<open>cat_FUNCT \<alpha> \<AA> \<BB>\<close> \<open>\<Delta>\<^sub>C\<^sub>F \<alpha> \<AA> \<BB>\<close>
    by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_op_intros)+
  from assms(2,3) show ?thesis
    unfolding cf_Cone_def
    by
      (
        cs_concl
          cs_simp: cat_cs_simps cat_FUNCT_components(1) cat_op_simps
          cs_intro: cat_cs_intros cat_FUNCT_cs_intros cat_op_intros
      )
qed

lemmas [cat_cs_simps] = is_functor.cf_Cone_ArrMap_app

lemma (in is_functor) cf_Cocone_ArrMap_app[cat_cs_simps]:
  assumes "\<Z> \<beta>"
    and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
    and "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b"
  shows "cf_Cocone \<alpha> \<beta> \<FF>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> = cf_hom
    (cat_FUNCT \<alpha> \<AA> \<BB>)
    [cat_FUNCT \<alpha> \<AA> \<BB>\<lparr>CId\<rparr>\<lparr>cf_map \<FF>\<rparr>, ntcf_arrow (ntcf_const \<AA> \<BB> f)]\<^sub>\<circ>"
proof-
  from assms interpret \<beta>: \<Z> \<beta> by simp
  from assms interpret \<Delta>: is_functor \<beta> \<BB> \<open>cat_FUNCT \<alpha> \<AA> \<BB>\<close> \<open>\<Delta>\<^sub>C\<^sub>F \<alpha> \<AA> \<BB>\<close>
    by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_op_intros)+
  from assms(2,3) show ?thesis
    unfolding cf_Cocone_def'
    by
      (
        cs_concl
          cs_simp: cat_cs_simps cat_FUNCT_components(1) cat_op_simps
          cs_intro: cat_cs_intros cat_FUNCT_cs_intros cat_op_intros
      )
qed

lemmas [cat_cs_simps] = is_functor.cf_Cocone_ArrMap_app

subsubsection\<open>The cone functor is a functor\<close>

lemma (in is_functor) tm_cf_cf_Cone_is_functor_if_ge_Limit:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "cf_Cone \<alpha> \<beta> \<FF> : op_cat \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<beta>\<^esub> cat_Set \<beta>"
proof-
  from assms interpret FUNCT: category \<beta> \<open>cat_FUNCT \<alpha> \<AA> \<BB>\<close>
    by
      (
        cs_concl cs_intro:
          cat_small_cs_intros cat_cs_intros cat_FUNCT_cs_intros
      )
  from assms interpret op_\<Delta>:
    is_functor \<beta> \<open>op_cat \<BB>\<close> \<open>op_cat (cat_FUNCT \<alpha> \<AA> \<BB>)\<close> \<open>op_cf (\<Delta>\<^sub>C\<^sub>F \<alpha> \<AA> \<BB>)\<close>
    by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_op_intros)+
  have "Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<beta>\<^esub>cat_FUNCT \<alpha> \<AA> \<BB>(-,cf_map \<FF>) :
    op_cat (cat_FUNCT \<alpha> \<AA> \<BB>) \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<beta>\<^esub> cat_Set \<beta>"
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_FUNCT_cs_simps
          cs_intro: cat_cs_intros cat_FUNCT_cs_intros
      )
  then show "cf_Cone \<alpha> \<beta> \<FF> : op_cat \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<beta>\<^esub> cat_Set \<beta>"
    unfolding cf_Cone_def' by (cs_concl cs_intro: cat_cs_intros)
qed

lemma (in is_functor) tm_cf_cf_Cocone_is_functor_if_ge_Limit:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "cf_Cocone \<alpha> \<beta> \<FF> : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<beta>\<^esub> cat_Set \<beta>"
proof-
  from assms interpret Funct: category \<beta> \<open>cat_FUNCT \<alpha> \<AA> \<BB>\<close>
    by
      (
        cs_concl cs_intro:
          cat_small_cs_intros cat_cs_intros cat_FUNCT_cs_intros
      )
  from assms interpret op_\<Delta>: is_functor \<beta> \<BB> \<open>cat_FUNCT \<alpha> \<AA> \<BB>\<close> \<open>\<Delta>\<^sub>C\<^sub>F \<alpha> \<AA> \<BB>\<close>
    by (cs_concl cs_shallow cs_intro: cat_cs_intros cat_op_intros)+
  have "Hom\<^sub>O\<^sub>.\<^sub>C\<^bsub>\<beta>\<^esub>cat_FUNCT \<alpha> \<AA> \<BB>(cf_map \<FF>,-) :
    cat_FUNCT \<alpha> \<AA> \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<beta>\<^esub> cat_Set \<beta>"
    by
      (
        cs_concl cs_shallow
          cs_simp: cat_FUNCT_cs_simps
          cs_intro: cat_cs_intros cat_FUNCT_cs_intros
      )
  then show "cf_Cocone \<alpha> \<beta>  \<FF> : \<BB> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<beta>\<^esub> cat_Set \<beta>"
    unfolding cf_Cocone_def' by (cs_concl cs_intro: cat_cs_intros)
qed

text\<open>\newpage\<close>

end


(*
Copyright 2018

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)
theory Abstract_System
  imports SE_Monad
begin

locale det_system =
  fixes step :: "(unit,'s) se"
  fixes halted :: "'s \<Rightarrow> bool"
begin

  definition "step_rel s s' \<equiv>
    case s of
      None \<Rightarrow> False
    | Some s \<Rightarrow> \<not>halted s \<and> map_option snd (step s) = s'"

  fun terminated where
    "terminated (Some s) = halted s"
  | "terminated None = True "

  lemma terminated_no_step[simp, intro]: "terminated s \<Longrightarrow> \<not>step_rel s s'"
    by (auto simp: step_rel_def split: option.splits)

  lemma terminated_no_step': "terminated s \<longleftrightarrow> (\<forall>s'. \<not>step_rel s s')"
    by (cases s; auto simp: step_rel_def split: option.splits)

  definition "is_result s s' \<equiv> step_rel\<^sup>*\<^sup>* (Some s) s' \<and> terminated s'"

  lemma is_result_1_step_eq: "\<not>halted s \<Longrightarrow> step s = Some ((),sh) \<Longrightarrow> is_result s s' \<longleftrightarrow> is_result sh s'"
    apply (rule iffI)
    subgoal
      unfolding is_result_def step_rel_def
      by (auto split: option.splits elim: converse_rtranclpE)
    subgoal
      unfolding is_result_def
      apply simp
      apply (rule converse_rtranclp_into_rtranclp)
      apply (auto simp: step_rel_def) []
      by simp
    done

  lemma result_determ: "is_result s s' \<Longrightarrow> is_result s s'' \<Longrightarrow> s'=s''"
    unfolding is_result_def
    apply safe
    apply (induction rule: converse_rtranclp_induct)
    apply (erule converse_rtranclpE; auto; fail)

    apply (erule converse_rtranclpE[of _ _ s'']; clarsimp)
    apply (auto simp: step_rel_def split: option.splits; fail)
    done

  definition "yields' s \<equiv> if \<exists>s'. is_result s s' then Some (THE s'. is_result s s') else None"

  lemma yields_eq_Some_conv: "yields' s = Some s' \<longleftrightarrow> is_result s s'"
    unfolding yields'_def using result_determ
    by (auto simp: theI2)

  lemma yields_eq_None_conv: "yields' s = None \<longleftrightarrow> (\<nexists>s'. is_result s s')"
    unfolding yields'_def by auto

  lemma halted_res[simp]: "halted s \<Longrightarrow> is_result s (Some s)"
    by (auto simp: is_result_def)

  lemma exec1_None_res[simp]: "\<lbrakk>step s = None; \<not> halted s\<rbrakk> \<Longrightarrow> is_result s None"
    by (auto simp: is_result_def step_rel_def r_into_rtranclp)

  lemma yields_unfold: "yields' s = (
    if halted s then
      Some (Some s)
    else
      case step s of
        Some (_,s') \<Rightarrow> yields' s'
      | None \<Rightarrow> Some None
    )"
    apply (clarsimp split: option.splits simp: yields_eq_Some_conv yields_eq_None_conv)
    subgoal for s'
      apply (cases "yields' s"; cases "yields' s'"; simp only:)
      apply (auto
        split: option.splits
        simp: yields_eq_Some_conv yields_eq_None_conv is_result_1_step_eq result_determ
        )+
      done
    done

  lemma yields'_simps[simp]:
    "halted s \<Longrightarrow> yields' s = Some (Some s)"
    "\<not>halted s \<Longrightarrow> step s = Some ((),s') \<Longrightarrow> yields' s = yields' s'"
    "\<not>halted s \<Longrightarrow> step s = None \<Longrightarrow> yields' s = Some None"
    by (subst yields_unfold; auto split: option.splits)+

  definition "is_invar \<phi> \<equiv> \<forall>s. \<phi> s \<and> \<not>halted s \<longrightarrow> wps step (\<lambda>_. \<phi>) s"
  definition "is_weak_invar \<phi> \<equiv> \<forall>s s'. \<phi> s \<and> \<not>halted s \<and> step s = Some ((),s') \<longrightarrow> \<phi> s'"

  lemma is_invar_step: "is_invar \<phi> \<Longrightarrow> \<phi> s \<Longrightarrow> step_rel (Some s) so' \<Longrightarrow> \<exists>s'. so'=Some s' \<and> \<phi> s'"
    by (auto simp: is_invar_def wps_def step_rel_def split: option.splits)

  lemma is_weak_invar_step: "is_weak_invar \<phi> \<Longrightarrow> \<phi> s \<Longrightarrow> step_rel (Some s) (Some s') \<Longrightarrow> \<phi> s'"
    by (auto simp: is_weak_invar_def wps_def step_rel_def split: option.splits)

  lemma is_invar_exec:
    assumes "is_invar \<phi>"
    assumes "\<phi> s"
    assumes "step_rel\<^sup>*\<^sup>* (Some s) so'"
    shows "\<exists>s'. so'=Some s' \<and> \<phi> s'"
    using assms(3,2)
    apply (induction a\<equiv>"Some s" arbitrary: s rule: converse_rtranclp_induct)
    subgoal by simp
    apply (drule (1) is_invar_step[OF \<open>is_invar \<phi>\<close>])
    by auto

  lemma step_rel_rtrancl_None_eq[simp]: "step_rel\<^sup>*\<^sup>* None s \<longleftrightarrow> s=None"
    using converse_rtranclpE by fastforce

  lemma is_weak_invar_exec:
    assumes "is_weak_invar \<phi>"
    assumes "\<phi> s"
    assumes "step_rel\<^sup>*\<^sup>* (Some s) (Some s')"
    shows "\<phi> s'"
    using assms(3,2)
    apply (induction a\<equiv>"Some s" arbitrary: s rule: converse_rtranclp_induct)
    subgoal by simp
    subgoal for z s
      apply (cases z; simp)
      apply (drule (1) is_weak_invar_step[OF \<open>is_weak_invar \<phi>\<close>])
      by auto
    done

  lemma is_invar_yields:
    assumes "is_invar \<phi>"
    assumes "\<phi> s"
    assumes "yields' s = Some so'"
    shows "\<exists>s'. so'=Some s' \<and> halted s' \<and> \<phi> s'"
    using assms
    apply (auto simp: yields_eq_Some_conv is_result_def is_invar_exec)
    using is_invar_exec terminated.simps(1) by blast

  lemma is_weak_invar_yields:
    assumes "is_weak_invar \<phi>"
    assumes "\<phi> s"
    assumes "yields' s = Some (Some s')"
    shows "\<phi> s'"
    using assms
    by (auto simp: yields_eq_Some_conv is_result_def is_weak_invar_exec)

  lemma is_invarI:
    assumes "\<And>s. \<lbrakk> \<phi> s; \<not>halted s \<rbrakk> \<Longrightarrow> wps step (\<lambda>_. \<phi>) s"
    shows "is_invar \<phi>"
    using assms
    unfolding is_invar_def by blast

  lemma is_weak_invarI:
    assumes "\<And>s s'. \<lbrakk> \<phi> s; \<not>halted s; step s = Some ((),s') \<rbrakk> \<Longrightarrow> \<phi> s'"
    shows "is_weak_invar \<phi>"
    using assms
    unfolding is_weak_invar_def by blast

  lemma app_weak_invar:
    assumes "is_weak_invar \<phi>'"
    assumes "\<not>halted s" "\<phi>' s"
    assumes "wps step (\<lambda>_ s'. \<phi>' s' \<longrightarrow> \<phi> s') s"
    shows "wps step (\<lambda>_. \<phi>) s"
    using assms unfolding is_weak_invar_def wps_def
    by (auto split: option.splits)

  lemma is_weak_invarD:
    assumes "is_weak_invar \<phi>"
    assumes "\<phi> s" "\<not>halted s"
    assumes "step s = Some ((),s')"
    shows "\<phi> s'"
    using assms
    by (auto simp: is_weak_invar_def)

end

locale std_invar_system = det_system step halted for step :: "(unit,'s) se" and halted +
  fixes stdI :: "'s \<Rightarrow> bool"
  assumes stdI: "is_weak_invar stdI"
begin
  definition "is_std_invar \<phi> \<equiv> is_invar (\<lambda>s. stdI s \<and> \<phi> s)"

  lemma is_std_invarI:
    assumes "\<And>s. \<lbrakk> \<phi> s; stdI s; \<not>halted s \<rbrakk> \<Longrightarrow> wps step (\<lambda>_ s'. stdI s' \<longrightarrow> \<phi> s') s"
    shows "is_std_invar \<phi>"
    unfolding is_std_invar_def
    apply (rule is_invarI)
    apply (rule app_weak_invar[OF stdI]; simp)
    using assms by blast

  definition "htriple P Q \<equiv> \<forall>s. stdI s \<and> P s \<longrightarrow> (case yields' s of
      None \<Rightarrow> True
    | Some None \<Rightarrow> False
    | Some (Some s') \<Rightarrow> Q s'
  )"

  lemma htripleI:
    assumes "\<And>s so'. \<lbrakk> stdI s; P s; yields' s = Some so' \<rbrakk> \<Longrightarrow> \<exists>s'. so' = Some s' \<and> (stdI s' \<longrightarrow> Q s')"
    shows "local.htriple P Q"
    using assms unfolding htriple_def
    using local.is_weak_invar_yields local.stdI
    by (fastforce split: option.split)

end

locale floyd_system = std_invar_system step halted stdI for step :: "(unit,'s) se" and halted stdI +
  fixes \<Theta> :: "'s \<rightharpoonup> bool"
begin
  definition "has_invar s \<equiv> halted s \<or> \<Theta> s \<noteq> None"

  lemma has_invar_simps[simp]:
    "\<Theta> s = Some x \<Longrightarrow> has_invar s"
    "\<Theta> s = None \<Longrightarrow> has_invar s = halted s"
    by (auto simp: has_invar_def)

  sublocale isys: det_system step has_invar .

  definition "invar s \<equiv>
    case isys.yields' s of
      None \<Rightarrow> False
    | Some so' \<Rightarrow> (case so' of None \<Rightarrow> False | Some s' \<Rightarrow> \<Theta> s' = Some True)
    "

  lemma invar_unfold:
    "invar s = (case \<Theta> s of Some b \<Rightarrow> b | None \<Rightarrow> (\<not>halted s \<and> wps (step) (\<lambda>_. invar) s))"
    unfolding invar_def wps_def
    apply (subst isys.yields_unfold)
    by (auto split: option.splits)

  lemma invar_imp_\<Theta>_true: "invar s \<Longrightarrow> has_invar s \<Longrightarrow> \<Theta> s = Some True"
    unfolding invar_def by (auto split: option.splits)

  lemma invarI:
    assumes "\<And>s. \<lbrakk> \<Theta> s = Some True; stdI s; \<not>halted s \<rbrakk> \<Longrightarrow> wps step (\<lambda>_ s'. stdI s' \<longrightarrow> invar s') s"
    shows "is_std_invar invar"
  proof (rule is_std_invarI)
    fix s
    assume "invar s" "\<not>halted s" "stdI s"

    from \<open>invar s\<close> consider (HAS_INVAR) "\<Theta> s = Some True" | (NO_INVAR) "\<Theta> s = None"
      using has_invar_def invar_imp_\<Theta>_true by blast
    then show "wps step (\<lambda>_ s'. stdI s' \<longrightarrow> invar s') s" proof cases
      case HAS_INVAR
      then show ?thesis
        using \<open>\<not> halted s\<close> \<open>stdI s\<close> assms by blast
    next
      case NO_INVAR
      hence "\<not>has_invar s" using \<open>\<not> halted s\<close> by (auto simp: has_invar_def)
      then show ?thesis
        using \<open>invar s\<close> invar_step wps_mono by fastforce
    qed
  qed

  lemma halted_invar_conv:
    assumes [simp]: "halted s"
    shows "invar s \<longleftrightarrow> \<Theta> s = Some True"
    by (subst invar_unfold) (auto split: option.split)

  lemma std_invar_yields:
    assumes "is_std_invar invar"
    assumes "stdI s" "invar s" "yields' s = Some so'"
    shows "\<exists>s'. so' = Some s' \<and> halted s' \<and> stdI s' \<and> \<Theta> s' = Some True"
  proof -
    from assms(1) have "is_invar (\<lambda>s. stdI s \<and> invar s)" by (simp add: is_std_invar_def)
    note X1 = is_invar_yields[OF this]

    from assms(2-) X1 obtain s' where X2: "so' = Some s'" "halted s'" "stdI s'" "invar s'"
      by auto
    with halted_invar_conv have "\<Theta> s' = Some True" by blast
    with X2 show ?thesis by blast
  qed

end

locale cfg_system = std_invar_system step halted stdI for step :: "(unit,'s) se" and halted stdI +
  fixes location :: "'s \<Rightarrow> 'loc"
begin
  definition linvar :: "('loc \<Rightarrow> ('s \<Rightarrow> bool) option) \<Rightarrow> 's \<Rightarrow> bool option" where
    "linvar \<Theta> s \<equiv>
        case \<Theta> (location s) of
          None \<Rightarrow> None
        | Some \<phi> \<Rightarrow> Some (\<phi> s)"

  sublocale floyd: floyd_system step halted stdI "linvar \<Theta>" for \<Theta> by standard

  definition "floyd_vcs \<Theta>' \<Theta> \<equiv>
    \<forall>\<phi> s. \<Theta>' (location s) = Some \<phi> \<and> \<phi> s \<and> stdI s \<and> \<not>halted s \<longrightarrow> wps step (\<lambda>_ s'. stdI s' \<longrightarrow> floyd.invar \<Theta> s') s"

  lemma floyd_vcs_emptyI:
    "floyd_vcs Map.empty \<Theta>"
    by (auto simp: floyd_vcs_def)

  lemma floyd_vcs_updI:
    assumes "floyd_vcs \<Theta>' \<Theta>"
    assumes "\<And>s. \<lbrakk> location s = l; \<phi> s; stdI s; \<not>halted s \<rbrakk> \<Longrightarrow> wps step (\<lambda>_ s'. stdI s' \<longrightarrow> floyd.invar \<Theta> s') s"
    shows "floyd_vcs (\<Theta>'(l\<mapsto>\<phi>)) \<Theta>"
    using assms
    by (auto simp: floyd_vcs_def)

  lemmas floyd_vcsI = floyd_vcs_emptyI floyd_vcs_updI

  lemma linvar_conv:
    "linvar \<Theta> s = None \<longleftrightarrow> \<Theta> (location s) = None"
    "linvar \<Theta> s = Some b \<longleftrightarrow> (\<exists>\<phi>. \<Theta> (location s) = Some \<phi> \<and> b=\<phi> s)"
    by (auto simp: linvar_def split: option.splits)

  lemma floyd_invarI: "floyd_vcs \<Theta> \<Theta> \<Longrightarrow> is_std_invar (floyd.invar \<Theta>)"
    apply (rule floyd.invarI)
    unfolding floyd_vcs_def
    by (auto simp: linvar_conv)

  lemma linvar_unfoldI:
    assumes "case \<Theta> (location s) of
        None \<Rightarrow> \<not>halted s \<and> wps step (\<lambda>_. floyd.invar \<Theta>) s
      | Some \<phi> \<Rightarrow> \<phi> s"
    shows "floyd.invar \<Theta> s"
    apply (subst floyd.invar_unfold)
    using assms
    by (auto simp: linvar_conv split: option.split)

  lemma floyd_htripleI:
    assumes "\<And>s. P s \<Longrightarrow> floyd.invar \<Theta> s" \<comment> \<open>Precondition implies invariant\<close>
    assumes "is_std_invar (floyd.invar \<Theta>)" \<comment> \<open>Invariant\<close>
    assumes "\<And>s \<phi>. \<lbrakk> halted s; stdI s; \<Theta> (location s) = Some \<phi>; \<phi> s \<rbrakk> \<Longrightarrow> Q s" \<comment> \<open>On termination, invariant implies postcondition\<close>
    shows "local.htriple P Q"
    apply (rule htripleI)
    subgoal for s so'
      using floyd.std_invar_yields[OF assms(2), of s so']
      apply (clarsimp simp: linvar_conv)
      using assms(1,3) by blast
    done

end

end


(*  Title:      HOL/Record.thy
    Author:     Wolfgang Naraschewski, TU Muenchen
    Author:     Markus Wenzel, TU Muenchen
    Author:     Norbert Schirmer, TU Muenchen
    Author:     Thomas Sewell, NICTA
    Author:     Florian Haftmann, TU Muenchen
*)

section \<open>Extensible records with structural subtyping\<close>

theory Record
imports Quickcheck_Exhaustive
keywords
  "record" :: thy_defn and
  "print_record" :: diag
begin

subsection \<open>Introduction\<close>

text \<open>
  Records are isomorphic to compound tuple types. To implement
  efficient records, we make this isomorphism explicit. Consider the
  record access/update simplification \<open>alpha (beta_update f
  rec) = alpha rec\<close> for distinct fields alpha and beta of some record
  rec with n fields. There are \<open>n ^ 2\<close> such theorems, which
  prohibits storage of all of them for large n. The rules can be
  proved on the fly by case decomposition and simplification in O(n)
  time. By creating O(n) isomorphic-tuple types while defining the
  record, however, we can prove the access/update simplification in
  \<open>O(log(n)^2)\<close> time.

  The O(n) cost of case decomposition is not because O(n) steps are
  taken, but rather because the resulting rule must contain O(n) new
  variables and an O(n) size concrete record construction. To sidestep
  this cost, we would like to avoid case decomposition in proving
  access/update theorems.

  Record types are defined as isomorphic to tuple types. For instance,
  a record type with fields \<open>'a\<close>, \<open>'b\<close>, \<open>'c\<close>
  and \<open>'d\<close> might be introduced as isomorphic to \<open>'a \<times>
  ('b \<times> ('c \<times> 'd))\<close>. If we balance the tuple tree to \<open>('a \<times>
  'b) \<times> ('c \<times> 'd)\<close> then accessors can be defined by converting to the
  underlying type then using O(log(n)) fst or snd operations.
  Updators can be defined similarly, if we introduce a \<open>fst_update\<close> and \<open>snd_update\<close> function. Furthermore, we can
  prove the access/update theorem in O(log(n)) steps by using simple
  rewrites on fst, snd, \<open>fst_update\<close> and \<open>snd_update\<close>.

  The catch is that, although O(log(n)) steps were taken, the
  underlying type we converted to is a tuple tree of size
  O(n). Processing this term type wastes performance. We avoid this
  for large n by taking each subtree of size K and defining a new type
  isomorphic to that tuple subtree. A record can now be defined as
  isomorphic to a tuple tree of these O(n/K) new types, or, if \<open>n > K*K\<close>, we can repeat the process, until the record can be
  defined in terms of a tuple tree of complexity less than the
  constant K.

  If we prove the access/update theorem on this type with the
  analogous steps to the tuple tree, we consume \<open>O(log(n)^2)\<close>
  time as the intermediate terms are \<open>O(log(n))\<close> in size and
  the types needed have size bounded by K.  To enable this analogous
  traversal, we define the functions seen below: \<open>iso_tuple_fst\<close>, \<open>iso_tuple_snd\<close>, \<open>iso_tuple_fst_update\<close>
  and \<open>iso_tuple_snd_update\<close>. These functions generalise tuple
  operations by taking a parameter that encapsulates a tuple
  isomorphism.  The rewrites needed on these functions now need an
  additional assumption which is that the isomorphism works.

  These rewrites are typically used in a structured way. They are here
  presented as the introduction rule \<open>isomorphic_tuple.intros\<close>
  rather than as a rewrite rule set. The introduction form is an
  optimisation, as net matching can be performed at one term location
  for each step rather than the simplifier searching the term for
  possible pattern matches. The rule set is used as it is viewed
  outside the locale, with the locale assumption (that the isomorphism
  is valid) left as a rule assumption. All rules are structured to aid
  net matching, using either a point-free form or an encapsulating
  predicate.
\<close>

subsection \<open>Operators and lemmas for types isomorphic to tuples\<close>

datatype (dead 'a, dead 'b, dead 'c) tuple_isomorphism =
  Tuple_Isomorphism "'a \<Rightarrow> 'b \<times> 'c" "'b \<times> 'c \<Rightarrow> 'a"

primrec
  repr :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'a \<Rightarrow> 'b \<times> 'c" where
  "repr (Tuple_Isomorphism r a) = r"

primrec
  abst :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'b \<times> 'c \<Rightarrow> 'a" where
  "abst (Tuple_Isomorphism r a) = a"

definition
  iso_tuple_fst :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'a \<Rightarrow> 'b" where
  "iso_tuple_fst isom = fst \<circ> repr isom"

definition
  iso_tuple_snd :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'a \<Rightarrow> 'c" where
  "iso_tuple_snd isom = snd \<circ> repr isom"

definition
  iso_tuple_fst_update ::
    "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a)" where
  "iso_tuple_fst_update isom f = abst isom \<circ> apfst f \<circ> repr isom"

definition
  iso_tuple_snd_update ::
    "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> ('c \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'a)" where
  "iso_tuple_snd_update isom f = abst isom \<circ> apsnd f \<circ> repr isom"

definition
  iso_tuple_cons ::
    "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'a" where
  "iso_tuple_cons isom = curry (abst isom)"

subsection \<open>Logical infrastructure for records\<close>

definition
  iso_tuple_surjective_proof_assist :: "'a \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
  "iso_tuple_surjective_proof_assist x y f \<longleftrightarrow> f x = y"

definition
  iso_tuple_update_accessor_cong_assist ::
    "(('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
  "iso_tuple_update_accessor_cong_assist upd ac \<longleftrightarrow>
     (\<forall>f v. upd (\<lambda>x. f (ac v)) v = upd f v) \<and> (\<forall>v. upd id v = v)"

definition
  iso_tuple_update_accessor_eq_assist ::
    "(('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool" where
  "iso_tuple_update_accessor_eq_assist upd ac v f v' x \<longleftrightarrow>
     upd f v = v' \<and> ac v = x \<and> iso_tuple_update_accessor_cong_assist upd ac"

lemma update_accessor_congruence_foldE:
  assumes uac: "iso_tuple_update_accessor_cong_assist upd ac"
    and r: "r = r'" and v: "ac r' = v'"
    and f: "\<And>v. v' = v \<Longrightarrow> f v = f' v"
  shows "upd f r = upd f' r'"
  using uac r v [symmetric]
  apply (subgoal_tac "upd (\<lambda>x. f (ac r')) r' = upd (\<lambda>x. f' (ac r')) r'")
   apply (simp add: iso_tuple_update_accessor_cong_assist_def)
  apply (simp add: f)
  done

lemma update_accessor_congruence_unfoldE:
  "iso_tuple_update_accessor_cong_assist upd ac \<Longrightarrow>
    r = r' \<Longrightarrow> ac r' = v' \<Longrightarrow> (\<And>v. v = v' \<Longrightarrow> f v = f' v) \<Longrightarrow>
    upd f r = upd f' r'"
  apply (erule(2) update_accessor_congruence_foldE)
  apply simp
  done

lemma iso_tuple_update_accessor_cong_assist_id:
  "iso_tuple_update_accessor_cong_assist upd ac \<Longrightarrow> upd id = id"
  by rule (simp add: iso_tuple_update_accessor_cong_assist_def)

lemma update_accessor_noopE:
  assumes uac: "iso_tuple_update_accessor_cong_assist upd ac"
    and ac: "f (ac x) = ac x"
  shows "upd f x = x"
  using uac
  by (simp add: ac iso_tuple_update_accessor_cong_assist_id [OF uac, unfolded id_def]
    cong: update_accessor_congruence_unfoldE [OF uac])

lemma update_accessor_noop_compE:
  assumes uac: "iso_tuple_update_accessor_cong_assist upd ac"
    and ac: "f (ac x) = ac x"
  shows "upd (g \<circ> f) x = upd g x"
  by (simp add: ac cong: update_accessor_congruence_unfoldE[OF uac])

lemma update_accessor_cong_assist_idI:
  "iso_tuple_update_accessor_cong_assist id id"
  by (simp add: iso_tuple_update_accessor_cong_assist_def)

lemma update_accessor_cong_assist_triv:
  "iso_tuple_update_accessor_cong_assist upd ac \<Longrightarrow>
    iso_tuple_update_accessor_cong_assist upd ac"
  by assumption

lemma update_accessor_accessor_eqE:
  "iso_tuple_update_accessor_eq_assist upd ac v f v' x \<Longrightarrow> ac v = x"
  by (simp add: iso_tuple_update_accessor_eq_assist_def)

lemma update_accessor_updator_eqE:
  "iso_tuple_update_accessor_eq_assist upd ac v f v' x \<Longrightarrow> upd f v = v'"
  by (simp add: iso_tuple_update_accessor_eq_assist_def)

lemma iso_tuple_update_accessor_eq_assist_idI:
  "v' = f v \<Longrightarrow> iso_tuple_update_accessor_eq_assist id id v f v' v"
  by (simp add: iso_tuple_update_accessor_eq_assist_def update_accessor_cong_assist_idI)

lemma iso_tuple_update_accessor_eq_assist_triv:
  "iso_tuple_update_accessor_eq_assist upd ac v f v' x \<Longrightarrow>
    iso_tuple_update_accessor_eq_assist upd ac v f v' x"
  by assumption

lemma iso_tuple_update_accessor_cong_from_eq:
  "iso_tuple_update_accessor_eq_assist upd ac v f v' x \<Longrightarrow>
    iso_tuple_update_accessor_cong_assist upd ac"
  by (simp add: iso_tuple_update_accessor_eq_assist_def)

lemma iso_tuple_surjective_proof_assistI:
  "f x = y \<Longrightarrow> iso_tuple_surjective_proof_assist x y f"
  by (simp add: iso_tuple_surjective_proof_assist_def)

lemma iso_tuple_surjective_proof_assist_idE:
  "iso_tuple_surjective_proof_assist x y id \<Longrightarrow> x = y"
  by (simp add: iso_tuple_surjective_proof_assist_def)

locale isomorphic_tuple =
  fixes isom :: "('a, 'b, 'c) tuple_isomorphism"
  assumes repr_inv: "\<And>x. abst isom (repr isom x) = x"
    and abst_inv: "\<And>y. repr isom (abst isom y) = y"
begin

lemma repr_inj: "repr isom x = repr isom y \<longleftrightarrow> x = y"
  by (auto dest: arg_cong [of "repr isom x" "repr isom y" "abst isom"]
    simp add: repr_inv)

lemma abst_inj: "abst isom x = abst isom y \<longleftrightarrow> x = y"
  by (auto dest: arg_cong [of "abst isom x" "abst isom y" "repr isom"]
    simp add: abst_inv)

lemmas simps = Let_def repr_inv abst_inv repr_inj abst_inj

lemma iso_tuple_access_update_fst_fst:
  "f \<circ> h g = j \<circ> f \<Longrightarrow>
    (f \<circ> iso_tuple_fst isom) \<circ> (iso_tuple_fst_update isom \<circ> h) g =
      j \<circ> (f \<circ> iso_tuple_fst isom)"
  by (clarsimp simp: iso_tuple_fst_update_def iso_tuple_fst_def simps
    fun_eq_iff)

lemma iso_tuple_access_update_snd_snd:
  "f \<circ> h g = j \<circ> f \<Longrightarrow>
    (f \<circ> iso_tuple_snd isom) \<circ> (iso_tuple_snd_update isom \<circ> h) g =
      j \<circ> (f \<circ> iso_tuple_snd isom)"
  by (clarsimp simp: iso_tuple_snd_update_def iso_tuple_snd_def simps
    fun_eq_iff)

lemma iso_tuple_access_update_fst_snd:
  "(f \<circ> iso_tuple_fst isom) \<circ> (iso_tuple_snd_update isom \<circ> h) g =
    id \<circ> (f \<circ> iso_tuple_fst isom)"
  by (clarsimp simp: iso_tuple_snd_update_def iso_tuple_fst_def simps
    fun_eq_iff)

lemma iso_tuple_access_update_snd_fst:
  "(f \<circ> iso_tuple_snd isom) \<circ> (iso_tuple_fst_update isom \<circ> h) g =
    id \<circ> (f \<circ> iso_tuple_snd isom)"
  by (clarsimp simp: iso_tuple_fst_update_def iso_tuple_snd_def simps
    fun_eq_iff)

lemma iso_tuple_update_swap_fst_fst:
  "h f \<circ> j g = j g \<circ> h f \<Longrightarrow>
    (iso_tuple_fst_update isom \<circ> h) f \<circ> (iso_tuple_fst_update isom \<circ> j) g =
      (iso_tuple_fst_update isom \<circ> j) g \<circ> (iso_tuple_fst_update isom \<circ> h) f"
  by (clarsimp simp: iso_tuple_fst_update_def simps apfst_compose fun_eq_iff)

lemma iso_tuple_update_swap_snd_snd:
  "h f \<circ> j g = j g \<circ> h f \<Longrightarrow>
    (iso_tuple_snd_update isom \<circ> h) f \<circ> (iso_tuple_snd_update isom \<circ> j) g =
      (iso_tuple_snd_update isom \<circ> j) g \<circ> (iso_tuple_snd_update isom \<circ> h) f"
  by (clarsimp simp: iso_tuple_snd_update_def simps apsnd_compose fun_eq_iff)

lemma iso_tuple_update_swap_fst_snd:
  "(iso_tuple_snd_update isom \<circ> h) f \<circ> (iso_tuple_fst_update isom \<circ> j) g =
    (iso_tuple_fst_update isom \<circ> j) g \<circ> (iso_tuple_snd_update isom \<circ> h) f"
  by (clarsimp simp: iso_tuple_fst_update_def iso_tuple_snd_update_def
    simps fun_eq_iff)

lemma iso_tuple_update_swap_snd_fst:
  "(iso_tuple_fst_update isom \<circ> h) f \<circ> (iso_tuple_snd_update isom \<circ> j) g =
    (iso_tuple_snd_update isom \<circ> j) g \<circ> (iso_tuple_fst_update isom \<circ> h) f"
  by (clarsimp simp: iso_tuple_fst_update_def iso_tuple_snd_update_def simps
    fun_eq_iff)

lemma iso_tuple_update_compose_fst_fst:
  "h f \<circ> j g = k (f \<circ> g) \<Longrightarrow>
    (iso_tuple_fst_update isom \<circ> h) f \<circ> (iso_tuple_fst_update isom \<circ> j) g =
      (iso_tuple_fst_update isom \<circ> k) (f \<circ> g)"
  by (clarsimp simp: iso_tuple_fst_update_def simps apfst_compose fun_eq_iff)

lemma iso_tuple_update_compose_snd_snd:
  "h f \<circ> j g = k (f \<circ> g) \<Longrightarrow>
    (iso_tuple_snd_update isom \<circ> h) f \<circ> (iso_tuple_snd_update isom \<circ> j) g =
      (iso_tuple_snd_update isom \<circ> k) (f \<circ> g)"
  by (clarsimp simp: iso_tuple_snd_update_def simps apsnd_compose fun_eq_iff)

lemma iso_tuple_surjective_proof_assist_step:
  "iso_tuple_surjective_proof_assist v a (iso_tuple_fst isom \<circ> f) \<Longrightarrow>
    iso_tuple_surjective_proof_assist v b (iso_tuple_snd isom \<circ> f) \<Longrightarrow>
    iso_tuple_surjective_proof_assist v (iso_tuple_cons isom a b) f"
  by (clarsimp simp: iso_tuple_surjective_proof_assist_def simps
    iso_tuple_fst_def iso_tuple_snd_def iso_tuple_cons_def)

lemma iso_tuple_fst_update_accessor_cong_assist:
  assumes "iso_tuple_update_accessor_cong_assist f g"
  shows "iso_tuple_update_accessor_cong_assist
    (iso_tuple_fst_update isom \<circ> f) (g \<circ> iso_tuple_fst isom)"
proof -
  from assms have "f id = id"
    by (rule iso_tuple_update_accessor_cong_assist_id)
  with assms show ?thesis
    by (clarsimp simp: iso_tuple_update_accessor_cong_assist_def simps
      iso_tuple_fst_update_def iso_tuple_fst_def)
qed

lemma iso_tuple_snd_update_accessor_cong_assist:
  assumes "iso_tuple_update_accessor_cong_assist f g"
  shows "iso_tuple_update_accessor_cong_assist
    (iso_tuple_snd_update isom \<circ> f) (g \<circ> iso_tuple_snd isom)"
proof -
  from assms have "f id = id"
    by (rule iso_tuple_update_accessor_cong_assist_id)
  with assms show ?thesis
    by (clarsimp simp: iso_tuple_update_accessor_cong_assist_def simps
      iso_tuple_snd_update_def iso_tuple_snd_def)
qed

lemma iso_tuple_fst_update_accessor_eq_assist:
  assumes "iso_tuple_update_accessor_eq_assist f g a u a' v"
  shows "iso_tuple_update_accessor_eq_assist
    (iso_tuple_fst_update isom \<circ> f) (g \<circ> iso_tuple_fst isom)
    (iso_tuple_cons isom a b) u (iso_tuple_cons isom a' b) v"
proof -
  from assms have "f id = id"
    by (auto simp add: iso_tuple_update_accessor_eq_assist_def
      intro: iso_tuple_update_accessor_cong_assist_id)
  with assms show ?thesis
    by (clarsimp simp: iso_tuple_update_accessor_eq_assist_def
      iso_tuple_fst_update_def iso_tuple_fst_def
      iso_tuple_update_accessor_cong_assist_def iso_tuple_cons_def simps)
qed

lemma iso_tuple_snd_update_accessor_eq_assist:
  assumes "iso_tuple_update_accessor_eq_assist f g b u b' v"
  shows "iso_tuple_update_accessor_eq_assist
    (iso_tuple_snd_update isom \<circ> f) (g \<circ> iso_tuple_snd isom)
    (iso_tuple_cons isom a b) u (iso_tuple_cons isom a b') v"
proof -
  from assms have "f id = id"
    by (auto simp add: iso_tuple_update_accessor_eq_assist_def
      intro: iso_tuple_update_accessor_cong_assist_id)
  with assms show ?thesis
    by (clarsimp simp: iso_tuple_update_accessor_eq_assist_def
      iso_tuple_snd_update_def iso_tuple_snd_def
      iso_tuple_update_accessor_cong_assist_def iso_tuple_cons_def simps)
qed

lemma iso_tuple_cons_conj_eqI:
  "a = c \<and> b = d \<and> P \<longleftrightarrow> Q \<Longrightarrow>
    iso_tuple_cons isom a b = iso_tuple_cons isom c d \<and> P \<longleftrightarrow> Q"
  by (clarsimp simp: iso_tuple_cons_def simps)

lemmas intros =
  iso_tuple_access_update_fst_fst
  iso_tuple_access_update_snd_snd
  iso_tuple_access_update_fst_snd
  iso_tuple_access_update_snd_fst
  iso_tuple_update_swap_fst_fst
  iso_tuple_update_swap_snd_snd
  iso_tuple_update_swap_fst_snd
  iso_tuple_update_swap_snd_fst
  iso_tuple_update_compose_fst_fst
  iso_tuple_update_compose_snd_snd
  iso_tuple_surjective_proof_assist_step
  iso_tuple_fst_update_accessor_eq_assist
  iso_tuple_snd_update_accessor_eq_assist
  iso_tuple_fst_update_accessor_cong_assist
  iso_tuple_snd_update_accessor_cong_assist
  iso_tuple_cons_conj_eqI

end

lemma isomorphic_tuple_intro:
  fixes repr abst
  assumes repr_inj: "\<And>x y. repr x = repr y \<longleftrightarrow> x = y"
    and abst_inv: "\<And>z. repr (abst z) = z"
    and v: "v \<equiv> Tuple_Isomorphism repr abst"
  shows "isomorphic_tuple v"
proof
  fix x have "repr (abst (repr x)) = repr x"
    by (simp add: abst_inv)
  then show "Record.abst v (Record.repr v x) = x"
    by (simp add: v repr_inj)
next
  fix y
  show "Record.repr v (Record.abst v y) = y"
    by (simp add: v) (fact abst_inv)
qed

definition
  "tuple_iso_tuple \<equiv> Tuple_Isomorphism id id"

lemma tuple_iso_tuple:
  "isomorphic_tuple tuple_iso_tuple"
  by (simp add: isomorphic_tuple_intro [OF _ _ reflexive] tuple_iso_tuple_def)

lemma refl_conj_eq: "Q = R \<Longrightarrow> P \<and> Q \<longleftrightarrow> P \<and> R"
  by simp

lemma iso_tuple_UNIV_I: "x \<in> UNIV \<equiv> True"
  by simp

lemma iso_tuple_True_simp: "(True \<Longrightarrow> PROP P) \<equiv> PROP P"
  by simp

lemma prop_subst: "s = t \<Longrightarrow> PROP P t \<Longrightarrow> PROP P s"
  by simp

lemma K_record_comp: "(\<lambda>x. c) \<circ> f = (\<lambda>x. c)"
  by (simp add: comp_def)

subsection \<open>Concrete record syntax\<close>

nonterminal
  ident and
  field_type and
  field_types and
  field and
  fields and
  field_update and
  field_updates

syntax
  "_constify"           :: "id => ident"                        ("_")
  "_constify"           :: "longid => ident"                    ("_")

  "_field_type"         :: "ident => type => field_type"        ("(2_ ::/ _)")
  ""                    :: "field_type => field_types"          ("_")
  "_field_types"        :: "field_type => field_types => field_types"    ("_,/ _")
  "_record_type"        :: "field_types => type"                ("(3\<lparr>_\<rparr>)")
  "_record_type_scheme" :: "field_types => type => type"        ("(3\<lparr>_,/ (2\<dots> ::/ _)\<rparr>)")

  "_field"              :: "ident => 'a => field"               ("(2_ =/ _)")
  ""                    :: "field => fields"                    ("_")
  "_fields"             :: "field => fields => fields"          ("_,/ _")
  "_record"             :: "fields => 'a"                       ("(3\<lparr>_\<rparr>)")
  "_record_scheme"      :: "fields => 'a => 'a"                 ("(3\<lparr>_,/ (2\<dots> =/ _)\<rparr>)")

  "_field_update"       :: "ident => 'a => field_update"        ("(2_ :=/ _)")
  ""                    :: "field_update => field_updates"      ("_")
  "_field_updates"      :: "field_update => field_updates => field_updates"  ("_,/ _")
  "_record_update"      :: "'a => field_updates => 'b"          ("_/(3\<lparr>_\<rparr>)" [900, 0] 900)

syntax (ASCII)
  "_record_type"        :: "field_types => type"                ("(3'(| _ |'))")
  "_record_type_scheme" :: "field_types => type => type"        ("(3'(| _,/ (2... ::/ _) |'))")
  "_record"             :: "fields => 'a"                       ("(3'(| _ |'))")
  "_record_scheme"      :: "fields => 'a => 'a"                 ("(3'(| _,/ (2... =/ _) |'))")
  "_record_update"      :: "'a => field_updates => 'b"          ("_/(3'(| _ |'))" [900, 0] 900)

subsection \<open>Record package\<close>

ML_file \<open>Tools/record.ML\<close>

hide_const (open) Tuple_Isomorphism repr abst iso_tuple_fst iso_tuple_snd
  iso_tuple_fst_update iso_tuple_snd_update iso_tuple_cons
  iso_tuple_surjective_proof_assist iso_tuple_update_accessor_cong_assist
  iso_tuple_update_accessor_eq_assist tuple_iso_tuple

end