theory RepeatCorres
  imports
    RepeatUpdate
    CorresHelper
    CogentTypingHelper
    "build/Generated_CorresSetup"
begin

context update_sem_init begin

definition crepeat
  where
"crepeat nC stopC stepC a0C o0C a1C a1U o1U d0 d1 a \<equiv>
    do r <- select UNIV;
       (i :: 64 word) <- gets (\<lambda>_. 0);
       a0 <- select UNIV;
       a0 <- gets (\<lambda>_. a1U (\<lambda>_. a0C a) a0);
       a0 <- gets (\<lambda>_. o1U (\<lambda>_. o0C a) a0);
       i <- gets (\<lambda>_. 0);
       doE a0 <-
           doE x <-
               doE _ <- liftE (guard (\<lambda>s. True));
                   whileLoopE (\<lambda>(ret, a0, i) s. i < ((nC a) :: 64 word))
                     (\<lambda>(ret, a0, i).
                         doE x <-
                             doE retval <- liftE (do ret' <- d0 ((stopC a) :: 32 signed word) a0;
                                                     gets (\<lambda>_. ret')
                                                  od);
                                 _ <- doE _ <- liftE (guard (\<lambda>s. True));
                                          condition (\<lambda>s. boolean_C retval \<noteq> 0)
                                            (doE global_exn_var <- liftE (gets (\<lambda>_. Break));
                                                 throwError (global_exn_var, ret, a0)
                                             odE)
                                            (liftE (gets (\<lambda>_. ())))
                                      odE;
                                 liftE (do retval <- do ret' <- d1 ((stepC a) :: 32 signed word) a0;
                                                        gets (\<lambda>_. ret')
                                                     od;
                                           a0 <- gets (\<lambda>_. a1U (\<lambda>_. retval) a0);
                                           i <- gets (\<lambda>_. i + 1);
                                           gets (\<lambda>_. (retval, a0, i))
                                        od)
                             odE;
                             liftE
                              (case x of
                               (ret, a0, i) \<Rightarrow>
                                 do _ <- guard (\<lambda>_. True);
                                    gets (\<lambda>_. (ret, a0, i))
                                 od)
                         odE)
                    (r, a0, i)
               odE;
               liftE (case x of (ret, a0, i) \<Rightarrow> gets (\<lambda>_. a0))
           odE <handle2>
           (\<lambda>(global_exn_var, ret, a0). doE _ <- doE _ <- liftE (guard (\<lambda>s. True));
    condition (\<lambda>s. global_exn_var = Break)
      (liftE (gets (\<lambda>_. ())))
      (throwError ret)
                                                                 odE;
                                                            liftE (gets (\<lambda>_. a0))
                                                        odE);
           ret <- liftE (gets (\<lambda>_. a1C a0));
           global_exn_var <- liftE (gets (\<lambda>_. Return));
           throwError ret
       odE <catch>
       (\<lambda>ret. do _ <- gets (\<lambda>_. ());
                 gets (\<lambda>_. ret)
              od)
    od"

definition repeat_inv
  where
"repeat_inv srel \<xi>' (i :: 64 word) fstop fstep \<sigma> \<tau>a \<tau>o acc obsv s cn cacc cobsv \<equiv>
    val_rel obsv cobsv \<and> i \<le> cn \<and>
    (\<exists>\<sigma>' y. urepeat_bod \<xi>' (unat i) (uvalfun_to_expr fstop) (uvalfun_to_expr fstep) \<sigma> \<sigma>' \<tau>a acc \<tau>o obsv y \<and>
            (\<sigma>', s) \<in> srel \<and> val_rel y cacc)"

definition repeat_measure
  where
"repeat_measure i n = unat n - unat i"

definition repeat_pre_step
  where
"repeat_pre_step srel \<xi>' i j fstop fstep \<sigma> \<tau>a \<tau>o acc obsv s cn cacc cobsv \<equiv>
    val_rel obsv cobsv \<and> i < cn \<and> i = j \<and>
    (\<exists>\<sigma>' y. urepeat_bod \<xi>' (unat i) (uvalfun_to_expr fstop) (uvalfun_to_expr fstep) \<sigma> \<sigma>' \<tau>a acc \<tau>o obsv y \<and>
            (\<sigma>', s) \<in> srel \<and> val_rel y cacc \<and>
            (\<xi>', [URecord [(y, type_repr (bang \<tau>a)), (obsv, type_repr \<tau>o)] None]
                \<turnstile> (\<sigma>', App (uvalfun_to_expr fstop) (Var 0)) \<Down>! (\<sigma>', UPrim (LBool False))))"

lemma step_wp:
  assumes \<Xi>wellformed: "proc_ctx_wellformed \<Xi>'"
  and     \<xi>'matchesu: "\<xi>' matches-u \<Xi>'"
  and     determ: "determ \<xi>'"
  and     \<tau>fdef: "\<tau>f = TRecord [(''acc'', \<tau>a, Present), (''obsv'', \<tau>o, Present)] Unboxed"
  and     fsteptype: "\<Xi>', 0, [], {}, [Some \<tau>f] \<turnstile> App (uvalfun_to_expr fstep) (Var 0) : \<tau>a"
  and     valrelc:  "\<And>x x'. val_rel x (x' :: ('c :: cogent_C_val)) \<equiv>
                              \<exists>acc obsv. x = URecord [acc, obsv] None \<and> val_rel (fst acc) (a1C x') \<and>
                                val_rel (fst obsv) (o1C x')"
  and     d1corres: "\<And>x x' \<sigma> s. val_rel x (x' :: ('c :: cogent_C_val)) \<Longrightarrow>
                                  corres state_rel (App (uvalfun_to_expr fstep) (Var 0))
                                    (do ret <- d1 (stepC v') x'; gets (\<lambda>s. ret) od)
                                    \<xi>' [x] \<Xi>' [option.Some \<tau>f] \<sigma> s"
  and     a1C_a1U: "\<And>x y. a1C (a1U (\<lambda>_. y) x) = y"
  and     o1C_a1U: "\<And>x y. o1C (a1U y x) = o1C x"
  and     srel: "(\<sigma>, s) \<in> state_rel"
  and     acctyp: "\<Xi>', \<sigma> \<turnstile> acc :u \<tau>a \<langle>ra, wa\<rangle>"
  and     obsvtyp: "\<Xi>', \<sigma> \<turnstile> obsv :u \<tau>o \<langle>ro, {}\<rangle>"
  and     disjoint: "wa \<inter> ro = {}"
  and     valrelacc: "val_rel acc (a0C v')"
  and     valrelobsv: "val_rel obsv (o0C v')"
  shows "\<And>arg j i.
          \<lbrace>\<lambda>sa. repeat_pre_step state_rel \<xi>' i j fstop fstep \<sigma> \<tau>a \<tau>o acc obsv sa (nC v') (a1C arg) (o1C arg)\<rbrace>
            d1 (stepC v') arg
          \<lbrace>\<lambda>ret sb.
               repeat_inv state_rel \<xi>' (j + 1) fstop fstep \<sigma> \<tau>a \<tau>o acc obsv sb (nC v') (a1C (a1U (\<lambda>_. ret) arg))
                (o1C (a1U (\<lambda>_. ret) arg)) \<and>
               repeat_measure (j+1) (nC v') < repeat_measure i (nC v')\<rbrace>!"
  apply (clarsimp simp: validNF_def valid_def no_fail_def)
  apply (subst all_imp_conj_distrib[symmetric]; clarsimp)
  apply (clarsimp simp: repeat_pre_step_def repeat_inv_def repeat_measure_def)
  apply (rename_tac s \<sigma>' y)
  apply (insert d1corres)
  apply (drule_tac x = "URecord [(y, type_repr \<tau>a), (obsv, type_repr \<tau>o)] None" and
                   y = arg in meta_spec2)
  apply (drule_tac x = \<sigma>' and y = s in meta_spec2)
  apply (erule meta_impE)
   apply (simp add: valrelc)
  apply (clarsimp simp: corres_def \<Xi>wellformed \<xi>'matchesu)
  apply (erule impE)
   apply (drule urepeat_bod_preservation[OF \<Xi>wellformed \<xi>'matchesu acctyp obsvtyp
                                            disjoint[simplified Int_commute] _
                                            fsteptype[simplified \<tau>fdef]])
   apply clarsimp
   apply (rename_tac r' w')
   apply (rule_tac x = "r' \<union> ro" in exI)
   apply (rule_tac x = w' in exI)
   apply (clarsimp simp: \<tau>fdef)
   apply (intro matches_ptrs_some[where r' = "{}" and w' = "{}", simplified]
                matches_ptrs_empty[where \<tau>s = "[]", simplified]
                u_t_struct
                u_t_r_cons1[where w' = "{}", simplified]
                u_t_r_cons1[where r' = "{}" and w' = "{}", simplified]
                u_t_r_empty; simp?)
     apply (erule uval_typing_frame(1); simp add: obsvtyp disjoint[simplified Int_commute])
    apply (drule frame_noalias_uval_typing'(2)[OF _ obsvtyp disjoint[simplified Int_commute]]; blast)
   apply (simp add:matches_ptrs.matches_ptrs_empty)
  apply clarsimp
  apply (rename_tac a b)
  apply (elim allE impE, assumption)
  apply (clarsimp simp: inc_le)
  apply (simp only: less_is_non_zero_p1[THEN unatSuc2] word_less_nat_alt)
  apply (frule urepeat_bod_step_determ[OF _ _ _ determ]; (simp del: urepeat_bod.simps)?)
  apply (intro conjI exI; assumption?; (simp del: urepeat_bod.simps add: o1C_a1U a1C_a1U)?)
  done

lemma stop_wp:
  assumes \<Xi>wellformed: "proc_ctx_wellformed \<Xi>'"
  and     \<xi>'matchesu: "\<xi>' matches-u \<Xi>'"
  and     determ: "determ \<xi>'"
  and     \<tau>fdef: "\<tau>f = TRecord [(''acc'', \<tau>a, Present), (''obsv'', \<tau>o, Present)] Unboxed"
  and     fstoptype: "\<Xi>', 0, [], {}, [Some (bang \<tau>f)] \<turnstile> App (uvalfun_to_expr fstop) (Var 0) : TPrim Bool"
  and     fsteptype: "\<Xi>', 0, [], {}, [Some \<tau>f] \<turnstile> App (uvalfun_to_expr fstep) (Var 0) : \<tau>a"
  and     valrelc:  "\<And>x x'. val_rel x (x' :: ('c :: cogent_C_val)) \<equiv>
                              \<exists>acc obsv. x = URecord [acc, obsv] None \<and> val_rel (fst acc) (a1C x') \<and>
                                val_rel (fst obsv) (o1C x')"
  and     d0corres: "\<And>x x' \<sigma> s. val_rel x (x' :: ('c :: cogent_C_val)) \<Longrightarrow>
                                  corres state_rel (App (uvalfun_to_expr fstop) (Var 0))
                                    (do ret <- d0 (stopC v') x'; gets (\<lambda>s. ret) od)
                                    \<xi>' [x] \<Xi>' [option.Some (bang \<tau>f)] \<sigma> s"
  and     srel: "(\<sigma>, s) \<in> state_rel"
  and     acctyp: "\<Xi>', \<sigma> \<turnstile> acc :u \<tau>a \<langle>ra, wa\<rangle>"
  and     obsvtyp: "\<Xi>', \<sigma> \<turnstile> obsv :u \<tau>o \<langle>ro, {}\<rangle>"
  and     disjoint: "wa \<inter> ro = {}"
  and     valrelacc: "val_rel acc (a0C v')"
  and     valrelobsv: "val_rel obsv (o0C v')"
  shows "\<And>j arg j'.
          \<lbrace>\<lambda>sa. (\<exists>\<sigma>' y n. (\<sigma>', sa) \<in> state_rel \<and> val_rel y (a1C arg) \<and> val_rel obsv (o1C arg) \<and>
            j = j' \<and>  j < nC v' \<and>
            urepeat_bod \<xi>' n (uvalfun_to_expr fstop) (uvalfun_to_expr fstep) \<sigma> \<sigma>'
              \<tau>a acc \<tau>o obsv y \<and>
            ((\<xi>' , [URecord [(y, type_repr (bang \<tau>a)), (obsv, type_repr \<tau>o)] None]
                \<turnstile> (\<sigma>', App (uvalfun_to_expr fstop) (Var 0)) \<Down>! (\<sigma>', UPrim (LBool True)))
              \<longrightarrow> n \<ge> unat j \<and> n < unat (nC v')) \<and>
            ((\<xi>' , [URecord [(y, type_repr (bang \<tau>a)), (obsv, type_repr \<tau>o)] None]
                \<turnstile> (\<sigma>', App (uvalfun_to_expr fstop) (Var 0)) \<Down>! (\<sigma>', UPrim (LBool False)))
              \<longrightarrow> n = unat j))\<rbrace>
            d0 (stopC v') arg
           \<lbrace>\<lambda>ret sb.
               (boolean_C ret \<noteq> 0 \<longrightarrow>
                (\<exists>\<sigma>' y.
                    urepeat_bod \<xi>' (unat (nC v')) (uvalfun_to_expr fstop) (uvalfun_to_expr fstep) \<sigma> \<sigma>' \<tau>a acc \<tau>o obsv y \<and>
                    (\<sigma>', sb) \<in> state_rel \<and> val_rel y (a1C arg))) \<and>
               (boolean_C ret = 0 \<longrightarrow>
                repeat_pre_step state_rel \<xi>' j j' fstop fstep \<sigma> \<tau>a \<tau>o acc obsv sb (nC v') (a1C arg) (o1C arg))\<rbrace>!"
  apply (clarsimp simp: validNF_def valid_def no_fail_def)
  apply (subst all_imp_conj_distrib[symmetric]; clarsimp)
  apply (clarsimp simp: repeat_pre_step_def)
  apply (rename_tac s \<sigma>' y n)
  apply (insert d0corres)
  apply (drule_tac x = "URecord [(y, type_repr (bang \<tau>a)), (obsv, type_repr \<tau>o)] None" and
                   y = arg in meta_spec2)
  apply (drule_tac x = \<sigma>' and y = s in meta_spec2)
  apply (erule meta_impE)
   apply (simp add: valrelc)
  apply (clarsimp simp: corres_def \<Xi>wellformed \<xi>'matchesu)
  apply (frule urepeat_bod_preservation[OF \<Xi>wellformed \<xi>'matchesu acctyp obsvtyp
                                           disjoint[simplified Int_commute] _
                                           fsteptype[simplified \<tau>fdef]])
  apply clarsimp
  apply (rename_tac r' w')
  apply (erule impE, rule_tac x = "(r' \<union> w') \<union> ro" in exI, rule_tac x = "{}" in exI)
   apply (clarsimp simp: \<tau>fdef)
   apply (intro matches_ptrs_some[where r' = "{}" and w' = "{}", simplified]
                matches_ptrs_empty[where \<tau>s = "[]", simplified]
                u_t_struct
                u_t_r_cons1[where w' = "{}", simplified]
                u_t_r_cons1[where r' = "{}" and w' = "{}", simplified]
                u_t_r_empty; simp?)
      apply (rule uval_typing_bang(1); simp)
     apply (rule uval_typing_bang(1)[where w = "{}" ,simplified])
     apply (erule uval_typing_frame(1); simp add: obsvtyp disjoint[simplified Int_commute])
    apply (rule wellformed_imp_bang_type_repr[OF uval_typing_to_wellformed(1)[OF obsvtyp]])
   apply (simp add:matches_ptrs.matches_ptrs_empty)
  apply clarsimp
  apply (rename_tac a b)
  apply (elim allE, erule impE, assumption)
  apply clarsimp
  apply (frule_tac r = "(r' \<union> w') \<union> ro" and w = "{}"
      in preservation(1)[where K = "[]" and \<tau>s = "[]", simplified,
                         OF subst_wellformed_nothing \<Xi>wellformed _
                            \<xi>'matchesu _ fstoptype, simplified, rotated 1])
   apply (clarsimp simp: \<tau>fdef)
   apply (intro matches_ptrs_some[where r' = "{}" and w' = "{}", simplified]
                matches_ptrs_empty[where \<tau>s = "[]", simplified]
                u_t_struct
                u_t_r_cons1[where w' = "{}", simplified]
                u_t_r_cons1[where r' = "{}" and w' = "{}", simplified]
                u_t_r_empty; simp?)
      apply (rule uval_typing_bang(1); simp)
     apply (rule uval_typing_bang(1)[where w = "{}" ,simplified])
     apply (erule uval_typing_frame(1); simp add: obsvtyp disjoint[simplified Int_commute])
    apply (rule wellformed_imp_bang_type_repr[OF uval_typing_to_wellformed(1)[OF obsvtyp]])
   apply (simp add:matches_ptrs.matches_ptrs_empty)
  apply (clarsimp simp: val_rel_bool_t_C_def)
  apply (erule u_t_primE; clarsimp)
  apply (drule frame_empty; clarsimp)
  apply (rule conjI; clarsimp)
  apply (intro exI conjI; assumption?)
   apply (erule (2) urepeat_bod_early_termination)
  apply (intro exI conjI; assumption?)
  done

lemma crepeat_corres_base:
  assumes \<gamma>len: "i < length \<gamma>"
  and     valrel: "val_rel (\<gamma> ! i) (v' :: ('a :: cogent_C_val))"
  and     \<Gamma>i: "\<Gamma> ! i = Some (fst (snd (snd (snd (\<Xi>' name)))))"
  and     \<Xi>name: "\<Xi>' name = (0, [],{}, \<tau>, \<tau>a)"
  and     \<tau>def: "\<tau> = TRecord [(''n'', TPrim (Num U64), Present),
                              (''stop'', TFun (bang \<tau>f) (TPrim Bool), Present),
                              (''step'', TFun \<tau>f \<tau>a, Present),
                              (''acc'', \<tau>a, Present), (''obsv'', \<tau>o, Present)] Unboxed"
  and     \<tau>fdef: "\<tau>f = TRecord [(''acc'', \<tau>a, Present), (''obsv'', \<tau>o, Present)] Unboxed"
  and     bang\<tau>o: "bang \<tau>o = \<tau>o"
  and     \<xi>''name: "\<xi>'' name = urepeat \<Xi>' \<xi>' \<tau>a \<tau>o"
  and     \<xi>'matchesu: "\<xi>' matches-u \<Xi>'"
  and     determ: "determ \<xi>'"
  and     \<gamma>i: "\<gamma> ! i =
               URecord [(UPrim (LU64 n), RPrim (Num U64)),
                        (fstop, RFun), (fstep, RFun),
                        (acc, type_repr \<tau>a), (obsv, type_repr \<tau>o)] None"
  and     fstoptype: "\<Xi>', 0, [], {}, [Some (bang \<tau>f)] \<turnstile> App (uvalfun_to_expr fstop) (Var 0) : TPrim Bool"
  and     fsteptype: "\<Xi>', 0, [], {}, [Some \<tau>f] \<turnstile> App (uvalfun_to_expr fstep) (Var 0) : \<tau>a"
  and     d0corres: "\<And>x x' \<sigma> s. val_rel x (x' :: ('c :: cogent_C_val)) \<Longrightarrow>
                                  corres state_rel (App (uvalfun_to_expr fstop) (Var 0))
                                    (do ret <- d0 (stopC v') x'; gets (\<lambda>s. ret) od)
                                    \<xi>' [x] \<Xi>' [option.Some (bang \<tau>f)] \<sigma> s"
  and     d1corres: "\<And>x x' \<sigma> s. val_rel x x' \<Longrightarrow>
                                  corres state_rel (App (uvalfun_to_expr fstep) (Var 0))
                                    (do ret <- d1 (stepC v') x'; gets (\<lambda>s. ret) od)
                                    \<xi>' [x] \<Xi>' [option.Some \<tau>f] \<sigma> s"
  and     valrela:  "\<And>x x'. val_rel x (x' :: 'a) \<equiv>
                              \<exists>n f g acc obsv. x = URecord [n, f, g, acc, obsv] None \<and>
                                val_rel (fst n) (nC x') \<and> val_rel (fst f) (stopC x') \<and>
                                val_rel (fst g) (stepC x') \<and> val_rel (fst acc) (a0C x') \<and>
                                val_rel (fst obsv) (o0C x')"
  and     valrelc:  "\<And>x x'. val_rel x (x' :: 'c) \<equiv>
                              \<exists>acc obsv. x = URecord [acc, obsv] None \<and> val_rel (fst acc) (a1C x') \<and>
                                val_rel (fst obsv) (o1C x')"
  and     a1C_a1U: "\<And>x y. a1C (a1U (\<lambda>_. y) x) = y"
  and     a1C_o1U: "\<And>x y. a1C (o1U y x) = a1C x"
  and     o1C_o1U: "\<And>x y. o1C (o1U (\<lambda>_. y) x) = y"
  and     o1C_a1U: "\<And>x y. o1C (a1U y x) = o1C x"
  and     cfundef: "cfun = crepeat nC stopC stepC a0C o0C a1C a1U o1U d0 d1"
shows
  "corres state_rel (App (AFun name [] []) (Var i))
    (do x <- cfun v'; gets (\<lambda>s. x) od)
     \<xi>'' \<gamma> \<Xi>' \<Gamma> \<sigma> s"
proof (rule absfun_corres[OF _ \<gamma>len valrel])
  show "abs_fun_rel \<Xi>' state_rel name \<xi>'' cfun \<sigma> s (\<gamma> ! i) v'"
    apply (subst abs_fun_rel_def')
    apply (clarsimp simp: \<Xi>name \<tau>def \<xi>''name cfundef urepeat_def bang\<tau>o \<gamma>i fsteptype[simplified \<tau>fdef])
    apply (insert fstoptype; simp add: \<tau>fdef bang\<tau>o)
    apply (thin_tac "_, _, _, _, _ \<turnstile> _ : _")
    apply (erule u_t_recE; clarsimp)
    apply (erule u_t_r_consE; simp)+
    apply (erule conjE)+
    apply (drule_tac t = "type_repr _" in sym)+
    apply clarsimp
    apply (frule tprim_no_pointers(1); clarsimp)
    apply (drule tprim_no_pointers(2); clarsimp)
    apply (frule tfun_no_pointers(1); clarsimp)
    apply (frule tfun_no_pointers(2); clarsimp)
    apply (drule uval_typing_uvalfun; simp)
    apply (frule tfun_no_pointers(1); clarsimp)
    apply (frule tfun_no_pointers(2); clarsimp)
    apply (drule uval_typing_uvalfun; simp)
    apply (erule u_t_r_emptyE; clarsimp)
    apply (rename_tac ra wa ro wo)
    apply (cut_tac \<Xi>' = \<Xi>' and \<sigma> = \<sigma> and v = obsv and \<tau> = \<tau>o and r = ro and w = wo
        in bang_not_writable(1); simp add: bang\<tau>o)
    apply (clarsimp simp: crepeat_def valrela val_rel_word val_rel_fun_tag)
    apply (wp; (clarsimp split: prod.splits)?)
     apply (rule_tac
      I = "\<lambda>(a, b, j) s. repeat_inv state_rel \<xi>' j fstop fstep \<sigma> \<tau>a \<tau>o acc obsv s (nC v') (a1C b) (o1C b)" and
      M = "\<lambda>((_,_, j), _). repeat_measure j (nC v')" in whileLoopE_add_invI)
        apply (wp; clarsimp split: prod.splits)
            using d1corres o1C_a1U a1C_a1U
            apply (wp step_wp[OF _ \<xi>'matchesu determ \<tau>fdef fsteptype valrelc]; simp?)
           apply (wp; clarsimp)
          apply (wp; clarsimp)
          using d0corres
          apply (wp stop_wp[OF _ \<xi>'matchesu determ \<tau>fdef fstoptype fsteptype valrelc]; simp?)
         apply clarsimp
         apply (clarsimp simp: repeat_inv_def)
         apply (intro exI conjI; assumption?)
          apply (clarsimp simp: unat_mono)
         apply clarsimp
        apply (clarsimp simp: repeat_inv_def)
       apply wp
      apply (rule validNF_select_UNIV)+
    apply (clarsimp simp: repeat_inv_def o1C_o1U a1C_o1U a1C_a1U)
    done
next
  show "\<Gamma> ! i = Some (fst (snd (snd (snd (\<Xi>' name)))))"
    using \<Gamma>i by simp
qed

section "Corres rules which are easier to use"

lemma crepeat_corres:
  assumes \<gamma>len: "i < length \<gamma>"
  and     valrel: "val_rel (\<gamma> ! i) (v' :: ('a :: cogent_C_val))"
  and     \<Gamma>i: "\<Gamma> ! i = Some (fst (snd (snd (snd (\<Xi>' name)))))"
  and     \<Xi>name: "\<Xi>' name = (0, [], {}, \<tau>, \<tau>a)"
  and     \<tau>def: "\<tau> = TRecord [(''n'', TPrim (Num U64), Present),
                              (''stop'', TFun (bang \<tau>f) (TPrim Bool), Present),
                              (''step'', TFun \<tau>f \<tau>a, Present),
                              (''acc'', \<tau>a, Present), (''obsv'', \<tau>o, Present)] Unboxed"
  and     \<tau>fdef: "\<tau>f = TRecord [(''acc'', \<tau>a, Present), (''obsv'', \<tau>o, Present)] Unboxed"
  and     bang\<tau>o: "bang \<tau>o = \<tau>o"
  and     \<xi>''name: "\<xi>'' name = urepeat \<Xi>' \<xi>' \<tau>a \<tau>o"
  and     \<xi>'matchesu: "\<xi>' matches-u \<Xi>'"
  and     determ: "determ \<xi>'"
  and     \<gamma>i: "\<exists>n acc obsv a b. \<gamma> ! i = URecord [n, (fstop, a), (fstep, b), acc, obsv] None"
  and     fstoptype: "\<Xi>', 0, [], {}, [Some (bang \<tau>f)] \<turnstile> App (uvalfun_to_expr fstop) (Var 0) : TPrim Bool"
  and     fsteptype: "\<Xi>', 0, [], {}, [Some \<tau>f] \<turnstile> App (uvalfun_to_expr fstep) (Var 0) : \<tau>a"
  and     d0corres: "\<And>x x' \<sigma> s. val_rel x (x' :: ('c :: cogent_C_val)) \<Longrightarrow>
                                  corres state_rel (App (uvalfun_to_expr fstop) (Var 0))
                                    (do ret <- d0 (stopC v') x'; gets (\<lambda>s. ret) od)
                                    \<xi>' [x] \<Xi>' [option.Some (bang \<tau>f)] \<sigma> s"
  and     d1corres: "\<And>x x' \<sigma> s. val_rel x x' \<Longrightarrow>
                                  corres state_rel (App (uvalfun_to_expr fstep) (Var 0))
                                    (do ret <- d1 (stepC v') x'; gets (\<lambda>s. ret) od)
                                    \<xi>' [x] \<Xi>' [option.Some \<tau>f] \<sigma> s"
  and     valrela:  "\<And>x x'. val_rel x (x' :: 'a) \<equiv>
                              \<exists>n f g acc obsv. x = URecord [n, f, g, acc, obsv] None \<and>
                                val_rel (fst n) (nC x') \<and> val_rel (fst f) (stopC x') \<and>
                                val_rel (fst g) (stepC x') \<and> val_rel (fst acc) (a0C x') \<and>
                                val_rel (fst obsv) (o0C x')"
  and     valrelc:  "\<And>x x'. val_rel x (x' :: 'c) \<equiv>
                              \<exists>acc obsv. x = URecord [acc, obsv] None \<and> val_rel (fst acc) (a1C x') \<and>
                                val_rel (fst obsv) (o1C x')"
  and     a1C_a1U: "\<And>x y. a1C (a1U (\<lambda>_. y) x) = y"
  and     a1C_o1U: "\<And>x y. a1C (o1U y x) = a1C x"
  and     o1C_o1U: "\<And>x y. o1C (o1U (\<lambda>_. y) x) = y"
  and     o1C_a1U: "\<And>x y. o1C (a1U y x) = o1C x"
  and     cfundef: "cfun = crepeat nC stopC stepC a0C o0C a1C a1U o1U d0 d1"
shows
  "corres state_rel (App (AFun name [] []) (Var i))
    (do x <- cfun v'; gets (\<lambda>s. x) od)
     \<xi>'' \<gamma> \<Xi>' \<Gamma> \<sigma> s"
  apply (insert \<gamma>i valrel; clarsimp simp: valrela val_rel_word corres_def)
  apply (frule matches_ptrs_length)
  apply (frule_tac  matches_ptrs_proj_single'[OF _ _ \<Gamma>i[simplified \<Xi>name \<tau>def]]; simp?)
   apply (cut_tac \<gamma>len; linarith)
  apply clarsimp
  apply (erule u_t_recE; clarsimp)
  apply (erule u_t_r_consE; simp)+
  apply (erule u_t_r_emptyE; simp)
  apply (elim conjE)
  apply (drule_tac t = "type_repr _" in sym)
  apply clarsimp
  apply (thin_tac "_ \<inter> _ = {}")+
  apply (thin_tac "_ \<subseteq> _")+
  apply (thin_tac "_, _ \<turnstile> _ :u _ \<langle>_, _\<rangle>")+
  apply (cut_tac state_rel = state_rel and \<sigma> = \<sigma> and s = s and \<xi>'' = \<xi>'' in
      crepeat_corres_base[OF \<gamma>len valrel _ _ \<tau>def \<tau>fdef bang\<tau>o _ \<xi>'matchesu determ _ fstoptype
                            fsteptype _ _ valrela valrelc a1C_a1U _ _ _ cfundef]; simp?)
  using \<Gamma>i apply simp
  using \<Xi>name apply simp
  using \<xi>''name apply simp
  using d0corres apply simp
  using d1corres apply simp
  using a1C_o1U apply simp
  using o1C_o1U apply simp
  using o1C_a1U apply simp
  apply (clarsimp simp: corres_def)
  done

lemma crepeat_corres_rel_leq:
  assumes \<gamma>len: "i < length \<gamma>"
  and     valrel: "val_rel (\<gamma> ! i) (v' :: ('a :: cogent_C_val))"
  and     \<Gamma>i: "\<Gamma> ! i = Some (fst (snd (snd  (snd (\<Xi>' name)))))"
  and     \<Xi>name: "\<Xi>' name = (0, [], {}, \<tau>, \<tau>a)"
  and     \<tau>def: "\<tau> = TRecord [(''n'', TPrim (Num U64), Present),
                              (''stop'', TFun (bang \<tau>f) (TPrim Bool), Present),
                              (''step'', TFun \<tau>f \<tau>a, Present),
                              (''acc'', \<tau>a, Present), (''obsv'', \<tau>o, Present)] Unboxed"
  and     \<tau>fdef: "\<tau>f = TRecord [(''acc'', \<tau>a, Present), (''obsv'', \<tau>o, Present)] Unboxed"
  and     bang\<tau>o: "bang \<tau>o = \<tau>o"
  and     \<xi>''name: "\<xi>'' name = urepeat \<Xi>' \<xi>' \<tau>a \<tau>o"
  and     leq: "rel_leq \<xi>' \<xi>''"
  and     determ: "determ \<xi>''"
  and     \<gamma>i: "\<exists>n acc obsv a b. \<gamma> ! i = URecord [n, (fstop, a), (fstep, b), acc, obsv] None"
  and     fstoptype: "\<Xi>', 0, [], {}, [Some (bang \<tau>f)] \<turnstile> App (uvalfun_to_expr fstop) (Var 0) : TPrim Bool"
  and     fsteptype: "\<Xi>', 0, [], {}, [Some \<tau>f] \<turnstile> App (uvalfun_to_expr fstep) (Var 0) : \<tau>a"
  and     d0corres: "\<And>x x' \<sigma> s. val_rel x (x' :: ('c :: cogent_C_val)) \<Longrightarrow>
                                  corres state_rel (App (uvalfun_to_expr fstop) (Var 0))
                                    (do ret <- d0 (stopC v') x'; gets (\<lambda>s. ret) od)
                                    \<xi>' [x] \<Xi>' [option.Some (bang \<tau>f)] \<sigma> s"
  and     d1corres: "\<And>x x' \<sigma> s. val_rel x x' \<Longrightarrow>
                                  corres state_rel (App (uvalfun_to_expr fstep) (Var 0))
                                    (do ret <- d1 (stepC v') x'; gets (\<lambda>s. ret) od)
                                    \<xi>' [x] \<Xi>' [option.Some \<tau>f] \<sigma> s"
  and     valrela:  "\<And>x x'. val_rel x (x' :: 'a) \<equiv>
                              \<exists>n f g acc obsv. x = URecord [n, f, g, acc, obsv] None \<and>
                                val_rel (fst n) (nC x') \<and> val_rel (fst f) (stopC x') \<and>
                                val_rel (fst g) (stepC x') \<and> val_rel (fst acc) (a0C x') \<and>
                                val_rel (fst obsv) (o0C x')"
  and     valrelc:  "\<And>x x'. val_rel x (x' :: 'c) \<equiv>
                              \<exists>acc obsv. x = URecord [acc, obsv] None \<and> val_rel (fst acc) (a1C x') \<and>
                                val_rel (fst obsv) (o1C x')"
  and     a1C_a1U: "\<And>x y. a1C (a1U (\<lambda>_. y) x) = y"
  and     a1C_o1U: "\<And>x y. a1C (o1U y x) = a1C x"
  and     o1C_o1U: "\<And>x y. o1C (o1U (\<lambda>_. y) x) = y"
  and     o1C_a1U: "\<And>x y. o1C (a1U y x) = o1C x"
  and     cfundef: "cfun = crepeat nC stopC stepC a0C o0C a1C a1U o1U d0 d1"
shows
  "corres state_rel (App (AFun name [] []) (Var i))
    (do x <- cfun v'; gets (\<lambda>s. x) od)
     \<xi>'' \<gamma> \<Xi>' \<Gamma> \<sigma> s"
  apply (clarsimp simp: corres_def)
  apply (cut_tac state_rel = state_rel and \<sigma> = \<sigma> and s = s and \<xi>'' = \<xi>'' in
      crepeat_corres[OF \<gamma>len valrel _ _ \<tau>def \<tau>fdef bang\<tau>o _ rel_leq_matchesuD[OF leq]
                       determ_rel_leqD[OF leq determ] \<gamma>i fstoptype fsteptype _ _ valrela
                       valrelc a1C_a1U _ _ _ cfundef]; simp?)
  using \<Gamma>i apply simp
  using \<Xi>name apply simp
  using \<xi>''name apply simp
  using d0corres apply simp
  using d1corres apply simp
  using a1C_o1U apply simp
  using o1C_o1U apply simp
  using o1C_a1U apply simp
  apply (clarsimp simp: corres_def)
  done

lemma crepeat_corres_bang:
  assumes \<gamma>len: "i < length \<gamma>"
  and     valrel: "val_rel (\<gamma> ! i) (v' :: ('a :: cogent_C_val))"
  and     \<Gamma>i: "\<Gamma> ! i = Some (fst (snd (snd (snd (\<Xi>' name)))))"
  and     \<Xi>name: "\<Xi>' name = (0, [], {}, \<tau>, \<tau>a)"
  and     \<tau>def: "\<tau> = TRecord [(''n'', TPrim (Num U64), Present),
                              (''stop'', TFun \<tau>f (TPrim Bool), Present),
                              (''step'', TFun \<tau>f \<tau>a, Present),
                              (''acc'', \<tau>a, Present), (''obsv'', \<tau>o, Present)] Unboxed"
  and     \<tau>fdef: "\<tau>f = TRecord [(''acc'', \<tau>a, Present), (''obsv'', \<tau>o, Present)] Unboxed"
  and     bang\<tau>a: "bang \<tau>a = \<tau>a"
  and     bang\<tau>o: "bang \<tau>o = \<tau>o"
  and     \<xi>''name: "\<xi>'' name = urepeat \<Xi>' \<xi>' \<tau>a \<tau>o"
  and     leq: "rel_leq \<xi>' \<xi>''"
  and     determ: "determ \<xi>''"
  and     \<gamma>i: "\<exists>n acc obsv a b. \<gamma> ! i = URecord [n, (fstop, a), (fstep, b), acc, obsv] None"
  and     fstoptype: "\<Xi>', 0, [], {}, [Some \<tau>f] \<turnstile> App (uvalfun_to_expr fstop) (Var 0) : TPrim Bool"
  and     fsteptype: "\<Xi>', 0, [], {}, [Some \<tau>f] \<turnstile> App (uvalfun_to_expr fstep) (Var 0) : \<tau>a"
  and     d0corres: "\<And>x x' \<sigma> s. val_rel x (x' :: ('c :: cogent_C_val)) \<Longrightarrow>
                                  corres state_rel (App (uvalfun_to_expr fstop) (Var 0))
                                    (do ret <- d0 (stopC v') x'; gets (\<lambda>s. ret) od)
                                    \<xi>' [x] \<Xi>' [option.Some (bang \<tau>f)] \<sigma> s"
  and     d1corres: "\<And>x x' \<sigma> s. val_rel x x' \<Longrightarrow>
                                  corres state_rel (App (uvalfun_to_expr fstep) (Var 0))
                                    (do ret <- d1 (stepC v') x'; gets (\<lambda>s. ret) od)
                                    \<xi>' [x] \<Xi>' [option.Some \<tau>f] \<sigma> s"
  and     valrela:  "\<And>x x'. val_rel x (x' :: 'a) \<equiv>
                              \<exists>n f g acc obsv. x = URecord [n, f, g, acc, obsv] None \<and>
                                val_rel (fst n) (nC x') \<and> val_rel (fst f) (stopC x') \<and>
                                val_rel (fst g) (stepC x') \<and> val_rel (fst acc) (a0C x') \<and>
                                val_rel (fst obsv) (o0C x')"
  and     valrelc:  "\<And>x x'. val_rel x (x' :: 'c) \<equiv>
                              \<exists>acc obsv. x = URecord [acc, obsv] None \<and> val_rel (fst acc) (a1C x') \<and>
                                val_rel (fst obsv) (o1C x')"
  and     a1C_a1U: "\<And>x y. a1C (a1U (\<lambda>_. y) x) = y"
  and     a1C_o1U: "\<And>x y. a1C (o1U y x) = a1C x"
  and     o1C_o1U: "\<And>x y. o1C (o1U (\<lambda>_. y) x) = y"
  and     o1C_a1U: "\<And>x y. o1C (a1U y x) = o1C x"
  and     cfundef: "cfun = crepeat nC stopC stepC a0C o0C a1C a1U o1U d0 d1"
shows
  "corres state_rel (App (AFun name [] []) (Var i))
    (do x <- cfun v'; gets (\<lambda>s. x) od)
     \<xi>'' \<gamma> \<Xi>' \<Gamma> \<sigma> s"
  apply (rule_tac state_rel = state_rel and \<sigma> = \<sigma> and s = s in
      crepeat_corres_rel_leq[OF \<gamma>len valrel _ _  _  \<tau>fdef bang\<tau>o _ leq
                       determ \<gamma>i _  fsteptype _ _ valrela
                       valrelc a1C_a1U _ _ _ cfundef]; simp?)
  using \<Gamma>i apply simp
  using \<Xi>name \<tau>def \<tau>fdef bang\<tau>a bang\<tau>o apply simp
  using \<xi>''name apply simp
  using \<tau>fdef bang\<tau>a bang\<tau>o fstoptype apply simp
  using d0corres apply simp
  using d1corres apply simp
  using a1C_o1U apply simp
  using o1C_o1U apply simp
  using o1C_a1U apply simp
  done

lemmas crepeat_corres_bang_fun_fun = crepeat_corres_bang
  [where fstop = "UFunction _ _ _" and fstep = "UFunction _ _ _", simplified,
   OF _ _ _ _ _ _ _ _ _ _ _ _ typing_mono_app_cogent_fun typing_mono_app_cogent_fun]
lemmas crepeat_corres_bang_fun_afun = crepeat_corres_bang
  [where fstop = "UFunction _ _ _" and fstep = "UAFunction _ _ _", simplified,
   OF _ _ _ _ _ _ _ _ _ _ _ _ typing_mono_app_cogent_fun typing_mono_app_cogent_absfun]
lemmas crepeat_corres_bang_afun_fun = crepeat_corres_bang
  [where fstop = "UAFunction _ _ _" and fstep = "UFunction _ _ _", simplified,
   OF _ _ _ _ _ _ _ _ _ _ _ _ typing_mono_app_cogent_absfun typing_mono_app_cogent_fun]
lemmas crepeat_corres_bang_afun_afun = crepeat_corres_bang
  [where fstop = "UAFunction _ _ _" and fstep = "UAFunction _ _ _", simplified,
   OF _ _ _ _ _ _ _ _ _ _ _ _ typing_mono_app_cogent_absfun typing_mono_app_cogent_absfun]

lemmas crepeat_corres_fun_fun = crepeat_corres_rel_leq
  [where fstop = "UFunction _ _ _" and fstep = "UFunction _ _ _", simplified,
   OF _ _ _ _ _ _ _ _ _ _ _  typing_mono_app_cogent_fun typing_mono_app_cogent_fun]
lemmas crepeat_corres_fun_afun = crepeat_corres_rel_leq
  [where fstop = "UFunction _ _ _" and fstep = "UAFunction _ _ _", simplified,
   OF _ _ _ _ _ _ _ _ _ _ _ typing_mono_app_cogent_fun typing_mono_app_cogent_absfun]
lemmas crepeat_corres_afun_fun = crepeat_corres_rel_leq
  [where fstop = "UAFunction _ _ _" and fstep = "UFunction _ _ _", simplified,
   OF _ _ _ _ _ _ _ _ _ _ _ typing_mono_app_cogent_absfun typing_mono_app_cogent_fun]
lemmas crepeat_corres_afun_afun = crepeat_corres_rel_leq
  [where fstop = "UAFunction _ _ _" and fstep = "UAFunction _ _ _", simplified,
   OF _ _ _ _ _ _ _ _ _ _ _ typing_mono_app_cogent_absfun typing_mono_app_cogent_absfun]

section "Alternate corres rules"

lemma crepeat_corres_base_all:
  assumes \<gamma>len: "i < length \<gamma>"
  and     valrel: "val_rel (\<gamma> ! i) (v' :: ('a :: cogent_C_val))"
  and     \<Gamma>i: "\<Gamma> ! i = Some (fst (snd (snd (snd (\<Xi>' name)))))"
  and     \<Xi>name: "\<Xi>' name = (0, [], {}, \<tau>, \<tau>a)"
  and     \<tau>def: "\<tau> = TRecord [(''n'', TPrim (Num U64), Present),
                              (''stop'', TFun (bang \<tau>f) (TPrim Bool), Present),
                              (''step'', TFun \<tau>f \<tau>a, Present),
                              (''acc'', \<tau>a, Present), (''obsv'', \<tau>o, Present)] Unboxed"
  and     \<tau>fdef: "\<tau>f = TRecord [(''acc'', \<tau>a, Present), (''obsv'', \<tau>o, Present)] Unboxed"
  and     bang\<tau>o: "bang \<tau>o = \<tau>o"
  and     \<xi>''name: "\<xi>'' name = urepeat \<Xi>' \<xi>' \<tau>a \<tau>o"
  and     \<xi>'matchesu: "\<xi>' matches-u \<Xi>'"
  and     determ: "determ \<xi>'"
  and     \<gamma>i: "\<gamma> ! i = URecord [(UPrim (LU64 n), RPrim (Num U64)), (fstop, RFun), (fstep, RFun), (acc, type_repr \<tau>a), (obsv, type_repr \<tau>o)] None"
  and     fstoptype: "\<Xi>', 0, [], {}, [Some (bang \<tau>f)] \<turnstile> App (uvalfun_to_expr fstop) (Var 0) : TPrim Bool"
  and     fsteptype: "\<Xi>', 0, [], {}, [Some \<tau>f] \<turnstile> App (uvalfun_to_expr fstep) (Var 0) : \<tau>a"
  and     valrela:  "\<forall>x (x' :: ('a :: cogent_C_val)). val_rel x x' =
                              (\<exists>n f g acc obsv. x = URecord [n, f, g, acc, obsv] None\<and>
                                val_rel (fst n) (nC x') \<and> val_rel (fst f) (stopC x') \<and>
                                val_rel (fst g) (stepC x') \<and> val_rel (fst acc) (a0C x') \<and>
                                val_rel (fst obsv) (o0C x'))"
  and     valrelc:  "\<forall>x (x' :: ('c :: cogent_C_val)). val_rel x x' =
                              (\<exists>acc obsv. x = URecord [acc, obsv] None \<and> val_rel (fst acc) (a1C x') \<and>
                                val_rel (fst obsv) (o1C x'))"
  and     d0corres: "\<forall>x x' \<sigma> s. val_rel x x' \<longrightarrow>
                                  corres state_rel (App (uvalfun_to_expr fstop) (Var 0))
                                    (do ret <- d0 (stopC v') x'; gets (\<lambda>s. ret) od)
                                    \<xi>' [x] \<Xi>' [option.Some (bang \<tau>f)] \<sigma> s"
  and     d1corres: "\<forall>x x' \<sigma> s. val_rel x x' \<longrightarrow>
                                  corres state_rel (App (uvalfun_to_expr fstep) (Var 0))
                                    (do ret <- d1 (stepC v') x'; gets (\<lambda>s. ret) od)
                                    \<xi>' [x] \<Xi>' [option.Some \<tau>f] \<sigma> s"
  and     a1C_a1U: "\<forall>x y. a1C (a1U (\<lambda>_. y) x) = y"
  and     a1C_o1U: "\<forall>x y. a1C (o1U y x) = a1C x"
  and     o1C_o1U: "\<forall>x y. o1C (o1U (\<lambda>_. y) x) = y"
  and     o1C_a1U: "\<forall>x y. o1C (a1U y x) = o1C x"
  and     cfundef: "cfun = crepeat nC stopC stepC a0C o0C a1C a1U o1U d0 d1"
shows
  "corres state_rel (App (AFun name [] []) (Var i))
    (do x <- cfun v'; gets (\<lambda>s. x) od)
     \<xi>'' \<gamma> \<Xi>' \<Gamma> \<sigma> s"
  apply (rule crepeat_corres_base[where o1C = o1C,
        OF \<gamma>len valrel _ _ \<tau>def \<tau>fdef bang\<tau>o _ \<xi>'matchesu determ \<gamma>i fstoptype fsteptype, rotated -1, OF cfundef];
        (simp add: \<Gamma>i \<Xi>name \<xi>''name valrela valrelc a1C_a1U a1C_o1U o1C_o1U o1C_a1U d0corres[simplified] d1corres[simplified])?)
  done

lemma crepeat_corres_all:
  assumes \<gamma>len: "i < length \<gamma>"
  and     valrel: "val_rel (\<gamma> ! i) (v' :: ('a :: cogent_C_val))"
  and     \<Gamma>i: "\<Gamma> ! i = Some (fst (snd (snd (snd (\<Xi>' name)))))"
  and     \<Xi>name: "\<Xi>' name = (0, [], {}, \<tau>, \<tau>a)"
  and     \<tau>def: "\<tau> = TRecord [(''n'', TPrim (Num U64), Present),
                              (''stop'', TFun (bang \<tau>f) (TPrim Bool), Present),
                              (''step'', TFun \<tau>f \<tau>a, Present),
                              (''acc'', \<tau>a, Present), (''obsv'', \<tau>o, Present)] Unboxed"
  and     \<tau>fdef: "\<tau>f = TRecord [(''acc'', \<tau>a, Present), (''obsv'', \<tau>o, Present)] Unboxed"
  and     bang\<tau>o: "bang \<tau>o = \<tau>o"
  and     \<xi>''name: "\<xi>'' name = urepeat \<Xi>' \<xi>' \<tau>a \<tau>o"
  and     \<xi>'matchesu: "\<xi>' matches-u \<Xi>'"
  and     determ: "determ \<xi>'"
  and     \<gamma>i: "\<exists>n acc obsv a b. \<gamma> ! i = URecord [n, (fstop, a), (fstep, b), acc, obsv] None"
  and     fstoptype: "\<Xi>', 0, [], {}, [Some (bang \<tau>f)] \<turnstile> App (uvalfun_to_expr fstop) (Var 0) : TPrim Bool"
  and     fsteptype: "\<Xi>', 0, [], {}, [Some \<tau>f] \<turnstile> App (uvalfun_to_expr fstep) (Var 0) : \<tau>a"
  and     valrela:  "\<forall>x (x' :: ('a :: cogent_C_val)). val_rel x x' =
                              (\<exists>n f g acc obsv. x = URecord [n, f, g, acc, obsv] None \<and>
                                val_rel (fst n) (nC x') \<and> val_rel (fst f) (stopC x') \<and>
                                val_rel (fst g) (stepC x') \<and> val_rel (fst acc) (a0C x') \<and>
                                val_rel (fst obsv) (o0C x'))"
  and     valrelc:  "\<forall>x (x' :: ('c :: cogent_C_val)). val_rel x x' =
                              (\<exists>acc obsv. x = URecord [acc, obsv] None \<and> val_rel (fst acc) (a1C x') \<and>
                                val_rel (fst obsv) (o1C x'))"
  and     d0corres: "\<forall>x x' \<sigma> s. val_rel x x' \<longrightarrow>
                                  corres state_rel (App (uvalfun_to_expr fstop) (Var 0))
                                    (do ret <- d0 (stopC v') x'; gets (\<lambda>s. ret) od)
                                    \<xi>' [x] \<Xi>' [option.Some (bang \<tau>f)] \<sigma> s"
  and     d1corres: "\<forall>x x' \<sigma> s. val_rel x x' \<longrightarrow>
                                  corres state_rel (App (uvalfun_to_expr fstep) (Var 0))
                                    (do ret <- d1 (stepC v') x'; gets (\<lambda>s. ret) od)
                                    \<xi>' [x] \<Xi>' [option.Some \<tau>f] \<sigma> s"
  and     a1C_a1U: "\<forall>x y. a1C (a1U (\<lambda>_. y) x) = y"
  and     a1C_o1U: "\<forall>x y. a1C (o1U y x) = a1C x"
  and     o1C_o1U: "\<forall>x y. o1C (o1U (\<lambda>_. y) x) = y"
  and     o1C_a1U: "\<forall>x y. o1C (a1U y x) = o1C x"
  and     cfundef: "cfun = crepeat nC stopC stepC a0C o0C a1C a1U o1U d0 d1"
shows
  "corres state_rel (App (AFun name [] []) (Var i))
    (do x <- cfun v'; gets (\<lambda>s. x) od)
     \<xi>'' \<gamma> \<Xi>' \<Gamma> \<sigma> s"
  apply (rule crepeat_corres[where o1C = o1C,
        OF \<gamma>len valrel _ _ \<tau>def \<tau>fdef bang\<tau>o _ \<xi>'matchesu determ \<gamma>i fstoptype fsteptype, rotated -1, OF cfundef];
        (simp add: \<Gamma>i \<Xi>name \<xi>''name valrela valrelc a1C_a1U a1C_o1U o1C_o1U o1C_a1U d0corres[simplified] d1corres[simplified])?)
  done

lemma crepeat_corres_rel_leq_all:
  assumes \<gamma>len: "i < length \<gamma>"
  and     valrel: "val_rel (\<gamma> ! i) (v' :: ('a :: cogent_C_val))"
  and     \<Gamma>i: "\<Gamma> ! i = Some (fst (snd (snd (snd (\<Xi>' name)))))"
  and     \<Xi>name: "\<Xi>' name = (0, [], {}, \<tau>, \<tau>a)"
  and     \<tau>def: "\<tau> = TRecord [(''n'', TPrim (Num U64), Present),
                              (''stop'', TFun (bang \<tau>f) (TPrim Bool), Present),
                              (''step'', TFun \<tau>f \<tau>a, Present),
                              (''acc'', \<tau>a, Present), (''obsv'', \<tau>o, Present)] Unboxed"
  and     \<tau>fdef: "\<tau>f = TRecord [(''acc'', \<tau>a, Present), (''obsv'', \<tau>o, Present)] Unboxed"
  and     bang\<tau>o: "bang \<tau>o = \<tau>o"
  and     \<xi>''name: "\<xi>'' name = urepeat \<Xi>' \<xi>' \<tau>a \<tau>o"
  and     leq: "rel_leq \<xi>' \<xi>''"
  and     determ: "determ \<xi>''"
  and     \<gamma>i: "\<exists>n acc obsv a b. \<gamma> ! i = URecord [n, (fstop, a), (fstep, b), acc, obsv] None"
  and     fstoptype: "\<Xi>', 0, [], {}, [Some (bang \<tau>f)] \<turnstile> App (uvalfun_to_expr fstop) (Var 0) : TPrim Bool"
  and     fsteptype: "\<Xi>', 0, [], {}, [Some \<tau>f] \<turnstile> App (uvalfun_to_expr fstep) (Var 0) : \<tau>a"
  and     valrela:  "\<forall>x (x' :: ('a :: cogent_C_val)). val_rel x x' =
                              (\<exists>n f g acc obsv. x = URecord [n, f, g, acc, obsv] None \<and>
                                val_rel (fst n) (nC x') \<and> val_rel (fst f) (stopC x') \<and>
                                val_rel (fst g) (stepC x') \<and> val_rel (fst acc) (a0C x') \<and>
                                val_rel (fst obsv) (o0C x'))"
  and     valrelc:  "\<forall>x (x' :: ('c :: cogent_C_val)). val_rel x x' =
                              (\<exists>acc obsv. x = URecord [acc, obsv] None \<and> val_rel (fst acc) (a1C x') \<and>
                                val_rel (fst obsv) (o1C x'))"
  and     d0corres: "\<forall>x x' \<sigma> s. val_rel x x' \<longrightarrow>
                                  corres state_rel (App (uvalfun_to_expr fstop) (Var 0))
                                    (do ret <- d0 (stopC v') x'; gets (\<lambda>s. ret) od)
                                    \<xi>' [x] \<Xi>' [option.Some (bang \<tau>f)] \<sigma> s"
  and     d1corres: "\<forall>x x' \<sigma> s. val_rel x x' \<longrightarrow>
                                  corres state_rel (App (uvalfun_to_expr fstep) (Var 0))
                                    (do ret <- d1 (stepC v') x'; gets (\<lambda>s. ret) od)
                                    \<xi>' [x] \<Xi>' [option.Some \<tau>f] \<sigma> s"
  and     a1C_a1U: "\<forall>x y. a1C (a1U (\<lambda>_. y) x) = y"
  and     a1C_o1U: "\<forall>x y. a1C (o1U y x) = a1C x"
  and     o1C_o1U: "\<forall>x y. o1C (o1U (\<lambda>_. y) x) = y"
  and     o1C_a1U: "\<forall>x y. o1C (a1U y x) = o1C x"
  and     cfundef: "cfun = crepeat nC stopC stepC a0C o0C a1C a1U o1U d0 d1"
shows
  "corres state_rel (App (AFun name [] []) (Var i))
    (do x <- cfun v'; gets (\<lambda>s. x) od)
     \<xi>'' \<gamma> \<Xi>' \<Gamma> \<sigma> s"
  apply (rule crepeat_corres_rel_leq[where o1C = o1C,
        OF \<gamma>len valrel _ _ \<tau>def \<tau>fdef bang\<tau>o _ leq determ \<gamma>i fstoptype fsteptype, rotated -1, OF cfundef];
        (simp add: \<Gamma>i \<Xi>name \<xi>''name valrela valrelc a1C_a1U a1C_o1U o1C_o1U o1C_a1U d0corres[simplified] d1corres[simplified])?)
  done

lemma crepeat_corres_bang_all:
  assumes \<gamma>len: "i < length \<gamma>"
  and     valrel: "val_rel (\<gamma> ! i) (v' :: ('a :: cogent_C_val))"
  and     \<Gamma>i: "\<Gamma> ! i = Some (fst (snd (snd (snd (\<Xi>' name)))))"
  and     \<Xi>name: "\<Xi>' name = (0, [], {}, \<tau>, \<tau>a)"
  and     \<tau>def: "\<tau> = TRecord [(''n'', TPrim (Num U64), Present),
                              (''stop'', TFun \<tau>f (TPrim Bool), Present),
                              (''step'', TFun \<tau>f \<tau>a, Present),
                              (''acc'', \<tau>a, Present), (''obsv'', \<tau>o, Present)] Unboxed"
  and     \<tau>fdef: "\<tau>f = TRecord [(''acc'', \<tau>a, Present), (''obsv'', \<tau>o, Present)] Unboxed"
  and     bang\<tau>a: "bang \<tau>a = \<tau>a"
  and     bang\<tau>o: "bang \<tau>o = \<tau>o"
  and     \<xi>''name: "\<xi>'' name = urepeat \<Xi>' \<xi>' \<tau>a \<tau>o"
  and     leq: "rel_leq \<xi>' \<xi>''"
  and     determ: "determ \<xi>''"
  and     \<gamma>i: "\<exists>n acc obsv a b. \<gamma> ! i = URecord [n, (fstop, a), (fstep, b), acc, obsv] None"
  and     fstoptype: "\<Xi>', 0, [], {}, [Some \<tau>f] \<turnstile> App (uvalfun_to_expr fstop) (Var 0) : TPrim Bool"
  and     fsteptype: "\<Xi>', 0, [], {}, [Some \<tau>f] \<turnstile> App (uvalfun_to_expr fstep) (Var 0) : \<tau>a"
  and     valrela:  "\<forall>x (x' :: ('a :: cogent_C_val)). val_rel x x' =
                              (\<exists>n f g acc obsv. x = URecord [n, f, g, acc, obsv] None \<and>
                                val_rel (fst n) (nC x') \<and> val_rel (fst f) (stopC x') \<and>
                                val_rel (fst g) (stepC x') \<and> val_rel (fst acc) (a0C x') \<and>
                                val_rel (fst obsv) (o0C x'))"
  and     valrelc:  "\<forall>x (x' :: ('c :: cogent_C_val)). val_rel x x' =
                              (\<exists>acc obsv. x = URecord [acc, obsv] None \<and> val_rel (fst acc) (a1C x') \<and>
                                val_rel (fst obsv) (o1C x'))"
  and     d0corres: "\<forall>x x' \<sigma> s. val_rel x x' \<longrightarrow>
                                  corres state_rel (App (uvalfun_to_expr fstop) (Var 0))
                                    (do ret <- d0 (stopC v') x'; gets (\<lambda>s. ret) od)
                                    \<xi>' [x] \<Xi>' [option.Some (bang \<tau>f)] \<sigma> s"
  and     d1corres: "\<forall>x x' \<sigma> s. val_rel x x' \<longrightarrow>
                                  corres state_rel (App (uvalfun_to_expr fstep) (Var 0))
                                    (do ret <- d1 (stepC v') x'; gets (\<lambda>s. ret) od)
                                    \<xi>' [x] \<Xi>' [option.Some \<tau>f] \<sigma> s"
  and     a1C_a1U: "\<forall>x y. a1C (a1U (\<lambda>_. y) x) = y"
  and     a1C_o1U: "\<forall>x y. a1C (o1U y x) = a1C x"
  and     o1C_o1U: "\<forall>x y. o1C (o1U (\<lambda>_. y) x) = y"
  and     o1C_a1U: "\<forall>x y. o1C (a1U y x) = o1C x"
  and     cfundef: "cfun = crepeat nC stopC stepC a0C o0C a1C a1U o1U d0 d1"
shows
  "corres state_rel (App (AFun name [] []) (Var i))
    (do x <- cfun v'; gets (\<lambda>s. x) od)
     \<xi>'' \<gamma> \<Xi>' \<Gamma> \<sigma> s"
  apply (rule crepeat_corres_bang[where o1C = o1C,
        OF \<gamma>len valrel _ _ \<tau>def \<tau>fdef bang\<tau>a bang\<tau>o _ leq determ \<gamma>i fstoptype fsteptype, rotated -1, OF cfundef];
        (simp add: \<Gamma>i \<Xi>name \<xi>''name valrela valrelc a1C_a1U a1C_o1U o1C_o1U o1C_a1U d0corres[simplified] d1corres[simplified])?)
  done

lemmas crepeat_corres_bang_fun_funall = crepeat_corres_bang_all
  [where fstop = "UFunction _ _ _" and fstep = "UFunction _ _ _", simplified,
   OF _ _ _ _ _ _ _ _ _ _ _ _ typing_mono_app_cogent_fun typing_mono_app_cogent_fun]
lemmas crepeat_corres_bang_fun_afun_all = crepeat_corres_bang_all
  [where fstop = "UFunction _ _ _" and fstep = "UAFunction _ _ _", simplified,
   OF _ _ _ _ _ _ _ _ _ _ _ _ typing_mono_app_cogent_fun typing_mono_app_cogent_absfun]
lemmas crepeat_corres_bang_afun_fun_all = crepeat_corres_bang_all
  [where fstop = "UAFunction _ _ _" and fstep = "UFunction _ _ _", simplified,
   OF _ _ _ _ _ _ _ _ _ _ _ _ typing_mono_app_cogent_absfun typing_mono_app_cogent_fun]
lemmas crepeat_corres_bang_afun_afun_all = crepeat_corres_bang_all
  [where fstop = "UAFunction _ _ _" and fstep = "UAFunction _ _ _", simplified,
   OF _ _ _ _ _ _ _ _ _ _ _ _ typing_mono_app_cogent_absfun typing_mono_app_cogent_absfun]

lemmas crepeat_corres_fun_fun_all = crepeat_corres_rel_leq_all
  [where fstop = "UFunction _ _ _" and fstep = "UFunction _ _ _", simplified,
   OF _ _ _ _ _ _ _ _ _ _ _  typing_mono_app_cogent_fun typing_mono_app_cogent_fun]
lemmas crepeat_corres_fun_afun_all = crepeat_corres_rel_leq_all
  [where fstop = "UFunction _ _ _" and fstep = "UAFunction _ _ _", simplified,
   OF _ _ _ _ _ _ _ _ _ _ _ typing_mono_app_cogent_fun typing_mono_app_cogent_absfun]
lemmas crepeat_corres_afun_fun_all = crepeat_corres_rel_leq_all
  [where fstop = "UAFunction _ _ _" and fstep = "UFunction _ _ _", simplified,
   OF _ _ _ _ _ _ _ _ _ _ _ typing_mono_app_cogent_absfun typing_mono_app_cogent_fun]
lemmas crepeat_corres_afun_afun_all = crepeat_corres_rel_leq_all
  [where fstop = "UAFunction _ _ _" and fstep = "UAFunction _ _ _", simplified,
   OF _ _ _ _ _ _ _ _ _ _ _ typing_mono_app_cogent_absfun typing_mono_app_cogent_absfun]

end (* of context *)

end


(*<*)
(*
 * Knowledge-based programs.
 * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory KBPsAuto
imports
  Extra
  KBPs
begin
(*>*)

section\<open>Automata Synthesis\<close>

text\<open>

\label{sec:kbps-automata-synthesis}

Our attention now shifts to showing how we can synthesise standard
automata that \emph{implement} a JKBP under certain conditions. We
proceed by defining \emph{incremental views} following
\<^cite>\<open>"Ron:1996"\<close>, which provide the interface between the system and
these automata. The algorithm itself is presented in
\S\ref{sec:kbps-alg}.

\<close>

subsection\<open>Incremental views\<close>

text\<open>

\label{sec:kbps-environments}

Intuitively an agent instantaneously observes the system state, and so
must maintain her view of the system \emph{incrementally}: her new
view must be a function of her current view and some new
observation. We allow this observation to be an arbitrary projection
@{term "envObs a"} of the system state for each agent @{term "a"}:

\<close>

locale Environment =
  PreEnvironment jkbp envInit envAction envTrans envVal
    for jkbp :: "('a, 'p, 'aAct) JKBP"
    and envInit :: "'s list"
    and envAction :: "'s \<Rightarrow> 'eAct list"
    and envTrans :: "'eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's"
    and envVal :: "'s \<Rightarrow> 'p \<Rightarrow> bool"
+ fixes envObs :: "'a \<Rightarrow> 's \<Rightarrow> 'obs"

text\<open>

An incremental view therefore consists of two functions with these
types:

\<close>

type_synonym ('a, 'obs, 'tv) InitialIncrJointView = "'a \<Rightarrow> 'obs \<Rightarrow> 'tv"
type_synonym ('a, 'obs,  'tv) IncrJointView = "'a \<Rightarrow> 'obs \<Rightarrow> 'tv \<Rightarrow> 'tv"

text\<open>

These functions are required to commute with their corresponding
trace-based joint view in the obvious way:

\<close>

locale IncrEnvironment =
  Environment jkbp envInit envAction envTrans envVal envObs
+ PreEnvironmentJView jkbp envInit envAction envTrans envVal jview
    for jkbp :: "('a, 'p, 'aAct) JKBP"
    and envInit :: "'s list"
    and envAction :: "'s \<Rightarrow> 'eAct list"
    and envTrans :: "'eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's"
    and envVal :: "'s \<Rightarrow> 'p \<Rightarrow> bool"
    and jview :: "('a, 's, 'tv) JointView"
    and envObs :: "'a \<Rightarrow> 's \<Rightarrow> 'obs"
+ fixes jviewInit :: "('a, 'obs, 'tv) InitialIncrJointView"
  fixes jviewIncr :: "('a, 'obs, 'tv) IncrJointView"
  assumes jviewInit: "\<forall>a s. jviewInit a (envObs a s) = jview a (tInit s)"
  assumes jviewIncr: "\<forall>a t s. jview a (t \<leadsto> s)
                             = jviewIncr a (envObs a s) (jview a t)"

text\<open>

Armed with these definitions, the following sections show that there
are automata that implement a JKBP in a given environment.

\<close>

subsection\<open>Automata\<close>

text\<open>

Our implementations of JKBPs take the form of deterministic Moore
automata, where transitions are labelled by observation and states
with the action to be performed. We will use the term \emph{protocols}
interchangeably with automata, following the KBP literature, and adopt
\emph{joint protocols} for the assignment of one such to each agent:

\<close>

record ('obs, 'aAct, 'ps) Protocol =
  pInit :: "'obs \<Rightarrow> 'ps"
  pTrans :: "'obs \<Rightarrow> 'ps \<Rightarrow> 'ps"
  pAct :: "'ps \<Rightarrow> 'aAct list"

type_synonym ('a, 'obs, 'aAct, 'ps) JointProtocol
    = "'a \<Rightarrow> ('obs, 'aAct, 'ps) Protocol"

context IncrEnvironment
begin

text\<open>

To ease composition with the system we adopt the function @{term
"pInit"} which maps the initial observation to an initial automaton
state.

\<^citet>\<open>"Ron:1996"\<close> shows that even non-deterministic JKBPs can be
implemented with deterministic transition functions; intuitively all
relevant uncertainty the agent has about the system must be encoded
into each automaton state, so there is no benefit to doing this
non-deterministically. In contrast we model the non-deterministic
choice of action by making @{term "pAct"} a relation.

Running a protocol on a trace is entirely standard, as is running a
joint protocol, and determining their actions:

\<close>

fun runJP :: "('a, 'obs, 'aAct, 'ps) JointProtocol
           \<Rightarrow> 's Trace \<Rightarrow> 'a \<Rightarrow> 'ps"
where
  "runJP jp (tInit s) a = pInit (jp a) (envObs a s)"
| "runJP jp (t \<leadsto> s) a = pTrans (jp a) (envObs a s) (runJP jp t a)"

abbreviation actJP :: "('a, 'obs, 'aAct, 'ps) JointProtocol
                    \<Rightarrow> 's Trace \<Rightarrow> 'a \<Rightarrow> 'aAct list" where
  "actJP jp \<equiv> \<lambda>t a. pAct (jp a) (runJP jp t a)"

text \<open>

Similarly to \S\ref{sec:kbps-canonical-kripke} we will reason about
the set of traces generated by a joint protocol in a fixed
environment:

\<close>

inductive_set
  jpTraces :: "('a, 'obs, 'aAct, 'ps) JointProtocol \<Rightarrow> 's Trace set"
    for jp :: "('a, 'obs, 'aAct, 'ps) JointProtocol"
where
  "s \<in> set envInit \<Longrightarrow> tInit s \<in> jpTraces jp"
| "\<lbrakk> t \<in> jpTraces jp; eact \<in> set (envAction (tLast t));
     \<And>a. aact a \<in> set (actJP jp t a); s = envTrans eact aact (tLast t) \<rbrakk>
     \<Longrightarrow> t \<leadsto> s \<in> jpTraces jp"
(*<*)

declare jpTraces.intros[intro]

lemma jpTraces_init_inv[dest]:
  "tInit s \<in> jpTraces jp \<Longrightarrow> s \<in> set envInit"
  by (cases rule: jpTraces.cases) auto

lemma jpTraces_step_inv[dest]:
  "t \<leadsto> s \<in> jpTraces jp
    \<Longrightarrow> t \<in> jpTraces jp
     \<and> (\<exists>eact \<in> set (envAction (tLast t)).
        (\<exists>aact. (\<forall>a. aact a \<in> set (actJP jp t a))
          \<and> s = envTrans eact aact (tLast t)))"
  by (cases rule: jpTraces.cases) auto

lemma jpTraces_init_length_inv:
  "t \<in> jpTraces jp \<Longrightarrow> (tLength t = 0) \<longleftrightarrow> (\<exists>s. s \<in> set envInit \<and> t = tInit s)"
  by (induct t) (auto elim: jpTraces.cases)

lemma jpTraces_step_length_inv_aux:
  "t \<in> { t \<in> jpTraces jp . tLength t = Suc n }
    \<Longrightarrow> \<exists>t' s. t = t' \<leadsto> s
            \<and> t' \<in> jpTraces jp
            \<and> tLength t' = n
            \<and> (\<exists>eact \<in> set (envAction (tLast t')).
               (\<exists>aact. (\<forall>a. aact a \<in> set (actJP jp t' a))
                 \<and> s = envTrans eact aact (tLast t')))"
  by (induct t arbitrary: n) auto

lemma jpTraces_step_length_inv:
  "{ t \<in> jpTraces jp . tLength t = Suc n }
 = { t \<leadsto> s |eact aact t s. t \<in> { t \<in> jpTraces jp . tLength t = n }
              \<and> eact \<in> set (envAction (tLast t))
              \<and> (\<forall>a. aact a \<in> set (actJP jp t a))
              \<and> s = envTrans eact aact (tLast t) }"
  apply (rule set_eqI)
  apply rule
   apply (drule jpTraces_step_length_inv_aux)
   apply auto
  done
(*>*)

end (* context IncrEnvironment *)

subsection\<open>The Implementation Relation\<close>

text\<open>

\label{sec:kbps-implementation}

With this machinery in hand, we now relate automata with JKBPs. We say
a joint protocol @{term "jp"} \emph{implements} a JKBP when they
perform the same actions on the canonical of traces. Note that the
behaviour of @{term "jp"} on other traces is arbitrary.

\<close>

context IncrEnvironment
begin

definition
  implements :: "('a, 'obs, 'aAct, 'ps) JointProtocol \<Rightarrow> bool"
where
  "implements jp \<equiv> (\<forall>t \<in> jkbpC. set \<circ> actJP jp t = set \<circ> jAction MC t)"

text\<open>

Clearly there are environments where the canonical trace set @{term
"jkbpC"} can be generated by actions that differ from those prescribed
by the JKBP. We can show that the \emph{implements} relation is a
stronger requirement than the mere trace-inclusion required by the
\emph{represents} relation of \S\ref{sec:kbps-canonical-kripke}.

\<close>
(*<*)

lemma implementsI[intro]:
  "(\<And>t. t \<in> jkbpC \<Longrightarrow> set \<circ> actJP jp t = set \<circ> jAction MC t)
  \<Longrightarrow> implements jp"
  unfolding implements_def by simp

lemma implementsE[elim]:
  assumes impl: "implements jp"
      and tC: "t \<in> jkbpC"
     shows "set \<circ> actJP jp t = set \<circ> jAction MC t"
  using assms unfolding implements_def by simp

lemma implements_actJP_jAction:
   assumes impl: "implements jp"
       and tCn: "t \<in> jkbpCn n"
  shows "set (actJP jp t a) = set (jAction (MCn n) t a)" (is "?lhs = ?rhs")
proof -
  from tCn have tC: "t \<in> jkbpC" by blast
  hence "?lhs = (set \<circ> jAction MC t) a"
    using implementsE[OF impl, symmetric] by auto
  also have "... = set (jAction (MCn n) t a)"
    by (simp add: jkbpC_jkbpCn_jAction_eq[OF tCn])
  finally show ?thesis .
qed

(*>*)
lemma implements_represents:
  assumes impl: "implements jp"
  shows "represents (jpTraces jp)"
(*<*)
proof -
  { fix n
    have "{ t \<in> jpTraces jp . tLength t = n }
        = { t \<in> jkbpC . tLength t = n }"
    proof(induct n)
      case 0 thus ?case
        by (auto dest: jpTraces_init_length_inv iff: jkbpC_traces_of_length)
    next
      case (Suc n)
      hence indhyp: "{t \<in> jpTraces jp . tLength t = n} = jkbpCn n"
        by (simp add: jkbpC_traces_of_length)

      have "{t \<in> jpTraces jp. tLength t = Suc n}
          = {t \<leadsto> s |eact aact t s. t \<in> jkbpCn n
                      \<and> eact \<in> set (envAction (tLast t))
                      \<and> (\<forall>a. aact a \<in> set (actJP jp t a))
                      \<and> s = envTrans eact aact (tLast t) }"
        using indhyp by (simp add: jpTraces_step_length_inv)
      also have "... = jkbpCn (Suc n)"
        apply (auto iff: Let_def)
        apply (auto iff: implements_actJP_jAction[OF impl, symmetric])
        done
      finally show ?case by (auto iff: jkbpC_traces_of_length)
    qed }
  hence R: "jpTraces jp = jkbpC" by auto
  from R jkbpC_represents
  show "represents (jpTraces jp)" by simp
qed

lemma implements_ind_jkbpC:
  assumes acts: "\<And>a n t.
                  \<lbrakk> {t \<in> jpTraces jp. tLength t = n} = jkbpCn n; t \<in> jkbpCn n \<rbrakk>
                  \<Longrightarrow> actJP jp t a = jAction MC t a"
  shows "implements jp"
proof -
  let ?T = "jpTraces jp"

  from acts have acts':
      "\<And>n t. \<lbrakk> {t \<in> jpTraces jp. tLength t = n} = jkbpCn n; t \<in> jkbpCn n \<rbrakk>
          \<Longrightarrow> actJP jp t = jAction (MCn n) t"
    by (simp only: jkbpC_jkbpCn_jAction_eq)

  from acts have acts':
      "\<And>n t. \<lbrakk> {t \<in> jpTraces jp. tLength t = n} = jkbpCn n; t \<in> jkbpCn n \<rbrakk>
          \<Longrightarrow> actJP jp t = jAction (MCn n) t"
    apply -
    apply (rule ext)
    apply simp
    using jkbpC_jkbpCn_jAction_eq
    apply simp
    done

  { fix n
    have "{ t \<in> ?T . tLength t = n } = { t \<in> jkbpC . tLength t = n }"
    proof(induct n)
      case 0 thus ?case
        by (auto dest: jpTraces_init_length_inv iff: jkbpC_traces_of_length)
    next
      case (Suc n)
      hence indhyp: "{t \<in> ?T. tLength t = n} = jkbpCn n"
        by (simp add: jkbpC_traces_of_length)

      have "{t \<in> jpTraces jp. tLength t = Suc n}
          = {t \<leadsto> s |eact aact t s. t \<in> jkbpCn n
                      \<and> eact \<in> set (envAction (tLast t))
                      \<and> (\<forall>a. aact a \<in> set (actJP jp t a))
                      \<and> s = envTrans eact aact (tLast t) }"
        using indhyp by (simp add: jpTraces_step_length_inv)
      also have "... = jkbpCn (Suc n)"
        apply (auto iff: Let_def)
         apply (drule acts'[OF indhyp, symmetric])
         apply auto[1]
        apply (drule acts'[OF indhyp, symmetric])
        apply auto[1]
        done
      finally show ?case
        apply (auto iff: jkbpC_traces_of_length)
        done
    qed
    hence "\<forall>t\<in>jkbpCn n. actJP jp t = jAction (MCn n) t"
      apply clarsimp
      apply (rule acts')
       apply (auto iff: jkbpC_traces_of_length)
      done
    hence "\<forall>t\<in>jkbpCn n. actJP jp t = jAction MC t"
      apply clarsimp
      by ( rule sync_jview_jAction_eq[where n="n"]
         , auto iff: jkbpC_traces_of_length)
  }
  thus ?thesis
    unfolding implements_def jkbpC_def
    apply clarsimp
    done
qed

(*>*)
text\<open>

The proof is by a straightfoward induction over the lengths of traces
generated by the joint protocol.

Our final piece of technical machinery allows us to refine automata
definitions: we say that two joint protocols are \emph{behaviourally
equivalent} if the actions they propose coincide for each canonical
trace. The implementation relation is preserved by this relation.

\<close>

definition
  behaviourally_equiv :: "('a, 'obs, 'aAct, 'ps) JointProtocol
                        \<Rightarrow> ('a, 'obs, 'aAct, 'ps') JointProtocol
                        \<Rightarrow> bool"
where
  "behaviourally_equiv jp jp' \<equiv> \<forall>t \<in> jkbpC. set \<circ> actJP jp t = set \<circ> actJP jp' t"

(*<*)
lemma behaviourally_equivI[intro]:
  "(\<And>t. t \<in> jkbpC \<Longrightarrow> set \<circ> actJP jp t = set \<circ> actJP jp' t)
    \<Longrightarrow> behaviourally_equiv jp jp'"
  unfolding behaviourally_equiv_def by simp
(*>*)

lemma behaviourally_equiv_implements:
  assumes "behaviourally_equiv jp jp'"
  shows "implements jp \<longleftrightarrow> implements jp'"
(*<*)
  using assms unfolding behaviourally_equiv_def implements_def by simp
(*>*)
text\<open>\<close>

end (* context IncrEnvironment *)

(* **************************************** *)

subsection\<open>Automata using Equivalence Classes\<close>

text\<open>

We now show that there is an implementation of every JKBP with respect
to every incremental synchronous view. Intuitively the states of the
automaton for agent @{term "a"} represent the equivalence classes of
traces that @{term "a"} considers possible, and the transitions update
these sets according to her KBP.

\<close>

context IncrEnvironment
begin

definition
  mkAutoEC :: "('a, 'obs, 'aAct, 's Trace set) JointProtocol"
where
  "mkAutoEC \<equiv> \<lambda>a.
     \<lparr> pInit = \<lambda>obs. { t \<in> jkbpC . jviewInit a obs = jview a t },
       pTrans = \<lambda>obs ps. { t |t t'. t \<in> jkbpC \<and> t' \<in> ps
                                 \<and> jview a t = jviewIncr a obs (jview a t') },
       pAct = \<lambda>ps. jAction MC (SOME t. t \<in> ps) a \<rparr>"

text\<open>

The function \<open>SOME\<close> is Hilbert's indefinite description
operator @{term "\<epsilon>"}, used here to choose an arbitrary trace from the
protocol state.

That this automaton maintains the correct equivalence class on a trace
@{term "t"} follows from an easy induction over @{term "t"}.

\<close>

lemma mkAutoEC_ec:
  assumes "t \<in> jkbpC"
  shows "runJP mkAutoEC t a = { t' \<in> jkbpC . jview a t' = jview a t }"
(*<*)
  using assms
  apply (induct t)
   apply (auto simp add: mkAutoEC_def jviewInit)[1]
  apply simp
  apply (subst mkAutoEC_def)
  apply (auto iff: Let_def jviewIncr)
  done
(*>*)

text\<open>

We can show that the construction yields an implementation by
appealing to the previous lemma and showing that the @{term "pAct"}
functions coincide.

\<close>

lemma mkAutoEC_implements: "implements mkAutoEC"
(*<*)
  apply (rule implements_ind_jkbpC)
  apply (subst mkAutoEC_def)
  apply simp
  apply (subgoal_tac "t \<in> jkbpC")
   using mkAutoEC_ec
   apply simp
   apply (rule S5n_jAction_eq)
    apply simp_all
    apply (rule_tac a=t in someI2)
     apply simp_all
    unfolding mkM_def
    apply auto
   done
(*>*)

text\<open>

This definition leans on the canonical trace set jkbpC, and is indeed
effective: we can enumerate all canonical traces and are sure to find
one that has the view we expect. Then it is sufficient to consider
other traces of the same length due to synchrony.  We would need to do
this computation dynamically, as the automaton will (in general) have
an infinite state space.

\<close>

end (* context IncrEnvironment *)

(* **************************************** *)

subsection\<open>Simulations\<close>

text\<open>
\label{sec:kbps-theory-automata-env-sims}

Our goal now is to reduce the space required by the automaton
constructed by @{term "mkAutoEC"} by \emph{simulating} the equivalence
classes (\S\ref{sec:kripke-theory-simulations}).

The following locale captures the framework of \<^citet>\<open>"Ron:1996"\<close>:

\<close>

locale SimIncrEnvironment =
  IncrEnvironment jkbp envInit envAction envTrans envVal jview envObs
                  jviewInit jviewIncr
    for jkbp :: "('a, 'p, 'aAct) JKBP"

    and envInit :: "'s list"
    and envAction :: "'s \<Rightarrow> 'eAct list"
    and envTrans :: "'eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's"
    and envVal :: "'s \<Rightarrow> 'p \<Rightarrow> bool"
    and jview :: "('a, 's, 'tv) JointView"
    and envObs :: "'a \<Rightarrow> 's \<Rightarrow> 'obs"
    and jviewInit :: "('a, 'obs, 'tv) InitialIncrJointView"
    and jviewIncr :: "('a, 'obs, 'tv) IncrJointView"
+ fixes simf :: "'s Trace \<Rightarrow> 'ss"
  fixes simRels :: "'a \<Rightarrow> 'ss Relation"
  fixes simVal :: "'ss \<Rightarrow> 'p \<Rightarrow> bool"
  assumes simf: "sim MC (mkKripke (simf ` jkbpC) simRels simVal) simf"

context SimIncrEnvironment
begin

text\<open>

Note that the back tick \<open>`\<close> is Isabelle/HOL's relational image
operator. In context it says that @{term "simf"} must be a simulation
from @{term "jkbpC"} to its image under @{term "simf"}.

Firstly we lift our familiar canonical trace sets and Kripke
structures through the simulation.

\<close>

abbreviation jkbpCSn :: "nat \<Rightarrow> 'ss set"(*<*)("jkbpCS\<^bsub>_\<^esub>")(*>*) where
  "jkbpCS\<^bsub>n\<^esub> \<equiv> simf ` jkbpC\<^bsub>n\<^esub>"

abbreviation jkbpCS :: "'ss set" where
  "jkbpCS \<equiv> simf ` jkbpC"

abbreviation MCSn :: "nat \<Rightarrow> ('a, 'p, 'ss) KripkeStructure"(*<*)("MCS\<^bsub>_\<^esub>")(*>*) where
  "MCS\<^bsub>n\<^esub> \<equiv> mkKripke jkbpCS\<^bsub>n\<^esub> simRels simVal"

abbreviation MCS :: "('a, 'p, 'ss) KripkeStructure" where
  "MCS \<equiv> mkKripke jkbpCS simRels simVal"
(*<*)
lemma jkbpCSn_jkbpCS_subset:
  "jkbpCSn n \<subseteq> jkbpCS"
  by (rule image_mono[OF jkbpCn_jkbpC_subset])

(*>*)
text\<open>

We will be often be concerned with the equivalence class of traces
generated by agent @{term "a"}'s view:

\<close>

abbreviation sim_equiv_class :: "'a \<Rightarrow> 's Trace \<Rightarrow> 'ss set" where
  "sim_equiv_class a t \<equiv> simf ` { t' \<in> jkbpC . jview a t' = jview a t }"

abbreviation jkbpSEC :: "'ss set set" where
  "jkbpSEC \<equiv> \<Union>a. sim_equiv_class a ` jkbpC"

text\<open>

With some effort we can show that the temporal slice of the simulated
structure is adequate for determining the actions of the JKBP. The
proof is tedious and routine, exploiting the sub-model property
(\S\ref{sec:generated_models}).

\<close>
(*<*)

lemma sim_submodel_aux:
  assumes s: "s \<in> worlds (MCSn n)"
  shows "gen_model MCS s = gen_model (MCSn n) s"
proof(rule gen_model_subset[where T="jkbpCSn n"])
  from s show "s \<in> worlds MCS"
    by (simp add: subsetD[OF jkbpCSn_jkbpCS_subset])
  from s show "s \<in> worlds (MCSn n)" by assumption
next
  fix a
  show "relations MCS a \<inter> jkbpCSn n \<times> jkbpCSn n
      = relations (MCSn n) a \<inter> jkbpCSn n \<times> jkbpCSn n"
    by (simp add: Int_ac Int_absorb1
                  relation_mono[OF jkbpCSn_jkbpCS_subset jkbpCSn_jkbpCS_subset])
next
  from s
  show "(\<Union>a. relations (MCSn n) a)\<^sup>* `` {s} \<subseteq> jkbpCSn n"
    apply (clarsimp simp del: mkKripke_simps)
    apply (erule kripke_rels_trc_worlds)
    apply auto
    done
next
  from s obtain t
    where st: "s = simf t"
      and tCn: "t \<in> jkbpCn n"
    by fastforce
  from tCn have tC: "t \<in> jkbpC" by blast
  { fix t'
    assume tt': "(t, t') \<in> (\<Union>a. relations MC a)\<^sup>*"
    from tC tt' have t'C: "t' \<in> jkbpC"
      by - (erule kripke_rels_trc_worlds, simp_all)
    from tCn tt' have t'Len: "tLength t' = n"
      by (auto dest: sync_tLength_eq_trc[where as=UNIV])
    from t'C t'Len have "t' \<in> jkbpCn n"
      by - (erule jkbpC_tLength_inv) }
  hence "(\<Union>a. relations MC a)\<^sup>* `` {t} \<subseteq> jkbpCn n"
    by clarsimp
  hence "simf ` ((\<Union>a. relations MC a)\<^sup>* `` {t}) \<subseteq> jkbpCSn n"
    by (rule image_mono)
  with st tC
  show "(\<Union>a. relations MCS a)\<^sup>* `` {s} \<subseteq> jkbpCSn n"
    using sim_trc_commute[OF _ simf, where t=t]
    by simp
qed simp_all
(*>*)

lemma jkbpC_jkbpCSn_jAction_eq:
  assumes tCn: "t \<in> jkbpCn n"
  shows "jAction MC t = jAction (MCSn n) (simf t)"
(*<*) (is "?lhs = ?rhs")
proof -
  have "?lhs = jAction MCS (simf t)"
    by (simp add: simulation_jAction_eq simf jkbpCn_jkbpC_inc[OF tCn])
  also have "... = ?rhs"
    using tCn
    by - ( rule gen_model_jAction_eq[OF sim_submodel_aux, where w="simf t"]
         , auto intro: gen_model_world_refl )
  finally show ?thesis .
qed
(*>*)

end (* context SimIncrEnvironment *)

text\<open>

It can be shown that a suitable simulation into a finite structure is
adequate to establish the existence of finite-state implementations
\<^citep>\<open>\<open>Theorem~2\<close> in "Ron:1996"\<close>: essentially we apply the simulation to
the states of @{term "mkAutoEC"}. However this result does not make it
clear how the transition function can be incrementally
constructed. One approach is to maintain @{term "jkbpC"} while
extending the automaton, which is quite space inefficient.

Intuitively we would like to compute the possible @{term
"sim_equiv_class"} successors of a given @{term "sim_equiv_class"}
without reference to @{term "jkbpC"}, and this should be possible as
the reachable simulated worlds must contain enough information to
differentiate themselves from every other simulated world (reachable
or not) that represents a trace that is observationally distinct to
their own.

This leads us to asking for some extra functionality of our
simulation, which we do in the following section.

\<close>

subsection\<open>Automata using simulations\<close>

text_raw\<open>
\label{sec:kbps-automata-synthesis-alg}

\begin{figure}[hp]
\begin{isabellebody}%
\<close>
locale AlgSimIncrEnvironment =
  SimIncrEnvironment jkbp envInit envAction envTrans envVal
                     jview envObs jviewInit jviewIncr simf simRels simVal
    for jkbp :: "('a, 'p, 'aAct) JKBP"
    and envInit :: "'s list"
    and envAction :: "'s \<Rightarrow> 'eAct list"
    and envTrans :: "'eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's"
    and envVal :: "'s \<Rightarrow> 'p \<Rightarrow> bool"

    and jview :: "('a, 's, 'tv) JointView"
    and envObs :: "'a \<Rightarrow> 's \<Rightarrow> 'obs"
    and jviewInit :: "('a, 'obs, 'tv) InitialIncrJointView"
    and jviewIncr :: "('a, 'obs, 'tv) IncrJointView"

    and simf :: "'s Trace \<Rightarrow> 'ss"
    and simRels :: "'a \<Rightarrow> 'ss Relation"
    and simVal :: "'ss \<Rightarrow> 'p \<Rightarrow> bool"

+ fixes simAbs :: "'rep \<Rightarrow> 'ss set"

    and simObs :: "'a \<Rightarrow> 'rep \<Rightarrow> 'obs"
    and simInit :: "'a \<Rightarrow> 'obs \<Rightarrow> 'rep"
    and simTrans :: "'a \<Rightarrow> 'rep \<Rightarrow> 'rep list"
    and simAction :: "'a \<Rightarrow> 'rep \<Rightarrow> 'aAct list"

  assumes simInit:
            "\<forall>a iobs. iobs \<in> envObs a ` set envInit
                   \<longrightarrow> simAbs (simInit a iobs)
                     = simf ` { t' \<in> jkbpC. jview a t' = jviewInit a iobs }"
      and simObs:
            "\<forall>a ec t. t \<in> jkbpC \<and> simAbs ec = sim_equiv_class a t
                   \<longrightarrow> simObs a ec = envObs a (tLast t)"
      and simAction:
            "\<forall>a ec t. t \<in> jkbpC \<and> simAbs ec = sim_equiv_class a t
                   \<longrightarrow> set (simAction a ec) = set (jAction MC t a)"
      and simTrans:
            "\<forall>a ec t. t \<in> jkbpC \<and> simAbs ec = sim_equiv_class a t
                   \<longrightarrow> simAbs ` set (simTrans a ec)
                     = { sim_equiv_class a (t' \<leadsto> s)
                         |t' s. t' \<leadsto> s \<in> jkbpC \<and> jview a t' = jview a t }"
text_raw\<open>
\end{isabellebody}%
\begin{isamarkuptext}%
\caption{The \<open>SimEnvironment\<close> locale extends the @{term
"Environment"} locale with simulation and algorithmic operations. The
backtick \<open>`\<close> is Isabelle/HOL's image-of-a-set-under-a-function
operator.}
\label{fig:kbps-theory-auto-SimEnvironment}
\end{isamarkuptext}%
\end{figure}
\<close>

text\<open>

The locale in Figure~\ref{fig:kbps-theory-auto-SimEnvironment} captures
our extra requirements of a simulation.

Firstly we relate the concrete representation @{typ "'rep"} of
equivalence classes under simulation to differ from the abstract
representation @{typ "'ss set"} using the abstraction function @{term
"simAbs"} \<^citep>\<open>"EdR:cup98"\<close>; there is no one-size-fits-all concrete
representation, as we will see.

Secondly we ask for a function @{term "simInit a iobs"} that
faithfully generates a representation of the equivalence class of
simulated initial states that are possible for agent @{term "a"} given
the valid initial observation @{term "iobs"}.

Thirdly the @{term "simObs"} function allows us to partition the
results of @{term "simTrans"} according to the recurrent observation
that agent @{term "a"} makes of the equivalence class.

Fourthly, the function @{term "simAction"} computes a list of actions
enabled by the JKBP on a state that concretely represents a canonical
equivalence class.

Finally we expect to compute the list of represented @{term
"sim_equiv_class"} successors of a given @{term "sim_equiv_class"}
using @{term "simTrans"}.

Note that these definitions are stated relative to the environment and
the JKBP, allowing us to treat specialised cases such as broadcast
(\S\ref{sec:kbps-theory-spr-deterministic-protocols} and
\S\ref{sec:kbps-theory-spr-non-deterministic-protocols}).

With these functions in hand, we can define our desired automaton:

\<close>

definition (in AlgSimIncrEnvironment)
  mkAutoSim :: "('a, 'obs, 'aAct, 'rep) JointProtocol"
where
  "mkAutoSim \<equiv> \<lambda>a.
     \<lparr> pInit = simInit a,
       pTrans = \<lambda>obs ec. (SOME ec'. ec' \<in> set (simTrans a ec)
                                  \<and> simObs a ec' = obs),
       pAct = simAction a \<rparr>"
(*<*)

context AlgSimIncrEnvironment
begin

lemma jAction_simAbs_cong:
  assumes tC: "t \<in> jkbpC"
      and ec: "simAbs ec = sim_equiv_class a t"
      and ec': "simAbs ec = simAbs ec'"
  shows "set (simAction a ec) = set (simAction a ec')"
  using assms simAction[rule_format, where a=a and t=t] tC by simp

lemma simTrans_simAbs_cong:
  assumes tC: "t \<in> jkbpC"
      and ec: "simAbs ec = sim_equiv_class a t"
      and ec': "simAbs ec = simAbs ec'"
  shows "simAbs ` set (simTrans a ec) = simAbs ` set (simTrans a ec')"
  using assms simTrans[rule_format, where a=a and t=t] tC by simp

lemma mkAutoSim_simps[simp]:
  "pInit (mkAutoSim a) = simInit a"
  "pTrans (mkAutoSim a) = (\<lambda>obs ec. (SOME ec'. ec' \<in> set (simTrans a ec) \<and> simObs a ec' = obs))"
  "pAct (mkAutoSim a) = simAction a"
  unfolding mkAutoSim_def by simp_all

end (* context AlgSimIncrEnvironment *)

(*>*)
text\<open>

The automaton faithfully constructs the simulated equivalence class of
the given trace:

\<close>

lemma (in AlgSimIncrEnvironment) mkAutoSim_ec:
  assumes tC: "t \<in> jkbpC"
  shows "simAbs (runJP mkAutoSim t a) = sim_equiv_class a t"
(*<*)
using tC
proof(induct t)
  case (tInit s) thus ?case
    by (simp add: jviewInit[rule_format, symmetric] simInit)
next
  case (tStep t s)
  hence tC: "t \<in> jkbpC" by blast

      from tC tStep
      have F: "simAbs ` set (simTrans a (runJP mkAutoSim t a))
             = { sim_equiv_class a (t' \<leadsto> s)
                 |t' s. t' \<leadsto> s \<in> jkbpC \<and> jview a t' = jview a t}"
        using simTrans[rule_format, where a=a and t=t and ec="runJP mkAutoSim t a"]
        apply clarsimp
        done

      from tStep
      have G: "sim_equiv_class a (t \<leadsto> s)
             \<in> { sim_equiv_class a (t' \<leadsto> s)
                |t' s. t' \<leadsto> s \<in> jkbpC \<and> jview a t' = jview a t}"
        by auto

      from F G
      have H: "sim_equiv_class a (t \<leadsto> s) \<in> simAbs ` set (simTrans a (runJP mkAutoSim t a))"
        by simp

      then obtain r
        where R: "r \<in> set (simTrans a (runJP mkAutoSim t a))"
        and S: "simAbs r = sim_equiv_class a (t \<leadsto> s)"
        by auto

  show ?case
  proof(simp, rule someI2)
    from R S tStep tC
    show "r \<in> set (simTrans a (runJP mkAutoSim t a)) \<and> simObs a r = envObs a s"
      using simObs[rule_format, where t="t\<leadsto>s" and a=a]
      apply clarsimp
      done
  next
    fix x assume x: "x \<in> set (simTrans a (runJP mkAutoSim t a)) \<and> simObs a x = envObs a s"

    from x
    have A: "simObs a x = envObs a s" by simp

    from x
    have "simAbs x \<in> simAbs ` set (simTrans a (runJP mkAutoSim t a))" by simp
    with tStep tC
    have "simAbs x \<in> { sim_equiv_class a (t' \<leadsto> s)
                         |t' s. t' \<leadsto> s \<in> jkbpC \<and> jview a t' = jview a t}"
      using simTrans[rule_format, where a=a and t=t] by simp
    then obtain t' s'
      where X: "simAbs x = sim_equiv_class a (t' \<leadsto> s')"
          and Y: "t' \<leadsto> s' \<in> jkbpC"
          and Z: "jview a t' = jview a t"
      by auto

    from A X Y Z
    show "simAbs x = sim_equiv_class a (t \<leadsto> s)"
      using simObs[rule_format, where a=a and t="t'\<leadsto>s'", symmetric]
      by (simp add: jviewIncr)
  qed
qed

(*>*)
text\<open>

This follows from a simple induction on @{term "t"}.

The following is a version of the Theorem 2 of \<^citet>\<open>"Ron:1996"\<close>.

\<close>

theorem (in AlgSimIncrEnvironment) mkAutoSim_implements:
  "implements mkAutoSim"
(*<*)
  apply rule
  apply rule
  apply (auto dest: jkbpCn_jkbpC_inc iff: mkAutoSim_ec simAction)
  done
(*>*)

text\<open>

The reader may care to contrast these structures with the
\emph{progression structures} of \<^citet>\<open>"Ron:1997"\<close>, where states
contain entire Kripke structures, and expanding the automaton is
alternated with bisimulation reduction to ensure termination when a
finite-state implementation exists (see \S\ref{sec:kbps-alg-auto-min})
We also use simulations in Appendix~\ref{ch:complexity} to show the
complexity of some related model checking problems.

We now review a simple \emph{depth-first search} (DFS) theory, and an
abstraction of finite maps, before presenting the algorithm for KBP
synthesis.

\FloatBarrier

\<close>

(*<*)
end
(*>*)