(*  Title:       variants/e_all_abcd/Seq_Invariants.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
    Author:      Peter Höfner, NICTA
*)

section "Invariant proofs on individual processes"

theory E_Seq_Invariants
imports AWN.Invariants E_Aodv E_Aodv_Data E_Aodv_Predicates E_Fresher
begin

text \<open>
  The proposition numbers are taken from the December 2013 version of
  the Fehnker et al technical report.
\<close>

text \<open>Proposition 7.2\<close>

lemma sequence_number_increases:
  "paodv i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<xi>, _), _, (\<xi>', _)). sn \<xi> \<le> sn \<xi>')"
  by inv_cterms

lemma sequence_number_one_or_bigger:
  "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, _). 1 \<le> sn \<xi>)"
  by (rule onll_step_to_invariantI [OF sequence_number_increases])
     (auto simp: \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V_def)

text \<open>We can get rid of the onl/onll if desired...\<close>

lemma sequence_number_increases':
  "paodv i \<TTurnstile>\<^sub>A (\<lambda>((\<xi>, _), _, (\<xi>', _)). sn \<xi> \<le> sn \<xi>')"
  by (rule step_invariant_weakenE [OF sequence_number_increases]) (auto dest!: onllD)

lemma sequence_number_one_or_bigger':
  "paodv i \<TTurnstile> (\<lambda>(\<xi>, _). 1 \<le> sn \<xi>)"
  by (rule invariant_weakenE [OF sequence_number_one_or_bigger]) auto

lemma sip_in_kD:
  "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l). l \<in> ({PAodv-:7} \<union> {PAodv-:5} \<union> {PRrep-:0..PRrep-:4}
                                     \<union> {PRreq-:0..PRreq-:3}) \<longrightarrow> sip \<xi> \<in> kD (rt \<xi>))"
  by inv_cterms

text \<open>Proposition 7.38\<close>

lemma includes_nhip:
  "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l). \<forall>dip\<in>kD(rt \<xi>). the (nhop (rt \<xi>) dip)\<in>kD(rt \<xi>))"
  proof -
    { fix ip and \<xi> \<xi>' :: state
      assume "\<forall>dip\<in>kD (rt \<xi>). the (nhop (rt \<xi>) dip) \<in> kD (rt \<xi>)"
         and "\<xi>' = \<xi>\<lparr>rt := update (rt \<xi>) ip (0, unk, val, Suc 0, ip)\<rparr>"
      hence "\<forall>dip\<in>kD (rt \<xi>).
               the (nhop (update (rt \<xi>) ip (0, unk, val, Suc 0, ip)) dip) = ip
             \<or> the (nhop (update (rt \<xi>) ip (0, unk, val, Suc 0, ip)) dip) \<in> kD (rt \<xi>)"
        by clarsimp (metis nhop_update_unk_val update_another)
    } note one_hop = this
    {  fix ip sip sn hops and \<xi> \<xi>' :: state
       assume "\<forall>dip\<in>kD (rt \<xi>). the (nhop (rt \<xi>) dip) \<in> kD (rt \<xi>)"
          and "\<xi>' = \<xi>\<lparr>rt := update (rt \<xi>) ip (sn, kno, val, Suc hops, sip)\<rparr>"
          and "sip \<in> kD (rt \<xi>)"
       hence "(the (nhop (update (rt \<xi>) ip (sn, kno, val, Suc hops, sip)) ip) = ip
                 \<or> the (nhop (update (rt \<xi>) ip (sn, kno, val, Suc hops, sip)) ip) \<in> kD (rt \<xi>))
               \<and> (\<forall>dip\<in>kD (rt \<xi>).
                    the (nhop (update (rt \<xi>) ip (sn, kno, val, Suc hops, sip)) dip) = ip
                    \<or> the (nhop (update (rt \<xi>) ip (sn, kno, val, Suc hops, sip)) dip) \<in> kD (rt \<xi>))"
         by (metis kD_update_unchanged nhop_update_changed update_another)
    } note nhip_is_sip = this
    show ?thesis
      by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf sip_in_kD]
                       solve: one_hop nhip_is_sip)
  qed

text \<open>Proposition 7.4\<close>

lemma known_destinations_increase:
  "paodv i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<xi>, _), _, (\<xi>', _)). kD (rt \<xi>) \<subseteq> kD (rt \<xi>'))"
  by (inv_cterms simp add: subset_insertI)

text \<open>Proposition 7.5\<close>

lemma rreqs_increase:
  "paodv i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<xi>, _), _, (\<xi>', _)). rreqs \<xi> \<subseteq> rreqs \<xi>')"
  by (inv_cterms simp add: subset_insertI)

lemma dests_bigger_than_sqn:
  "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l). l \<in> {PAodv-:15..PAodv-:17}
                                 \<union> {PPkt-:7..PPkt-:9}
                                 \<union> {PRreq-:11..PRreq-:13}
                                 \<union> {PRreq-:20..PRreq-:22}
                                 \<union> {PRrep-:7..PRrep-:9}
                                 \<union> {PRerr-:1..PRerr-:4} \<union> {PRerr-:6}
                         \<longrightarrow> (\<forall>ip\<in>dom(dests \<xi>). ip\<in>kD(rt \<xi>) \<and> sqn (rt \<xi>) ip \<le> the (dests \<xi> ip)))"
  proof -
    have sqninv:
      "\<And>dests rt rsn ip.
       \<lbrakk> \<forall>ip\<in>dom(dests). ip\<in>kD(rt) \<and> sqn rt ip \<le> the (dests ip); dests ip = Some rsn \<rbrakk>
        \<Longrightarrow> sqn (invalidate rt dests) ip \<le> rsn"
        by (rule sqn_invalidate_in_dests [THEN eq_imp_le], assumption) auto
    have indests:
      "\<And>dests rt rsn ip.
       \<lbrakk> \<forall>ip\<in>dom(dests). ip\<in>kD(rt) \<and> sqn rt ip \<le> the (dests ip); dests ip = Some rsn \<rbrakk>
        \<Longrightarrow> ip\<in>kD(rt) \<and> sqn rt ip \<le> rsn"
        by (metis domI option.sel)
    show ?thesis
      by inv_cterms
         (clarsimp split: if_split_asm option.split_asm
                   elim!: sqninv indests)+
  qed

text \<open>Proposition 7.6\<close>

lemma sqns_increase:
   "paodv i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<xi>, _), _, (\<xi>', _)). \<forall>ip. sqn (rt \<xi>) ip \<le> sqn (rt \<xi>') ip)"
  proof -
    { fix \<xi> :: state
      assume *: "\<forall>ip\<in>dom(dests \<xi>). ip \<in> kD (rt \<xi>) \<and> sqn (rt \<xi>) ip \<le> the (dests \<xi> ip)"
      have "\<forall>ip. sqn (rt \<xi>) ip \<le> sqn (invalidate (rt \<xi>) (dests \<xi>)) ip"
      proof
        fix ip
        from * have "ip\<notin>dom(dests \<xi>) \<or> sqn (rt \<xi>) ip \<le> the (dests \<xi> ip)" by simp
        thus "sqn (rt \<xi>) ip \<le> sqn (invalidate (rt \<xi>) (dests \<xi>)) ip"
          by (metis domI invalidate_sqn option.sel)
      qed
    } note solve_invalidate = this
    show ?thesis
      by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf dests_bigger_than_sqn]
                    simp add: solve_invalidate)
  qed

text \<open>Proposition 7.7\<close>

lemma ip_constant:
  "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, _). ip \<xi> = i)"
  by (inv_cterms simp add: \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V_def)

text \<open>Proposition 7.8\<close>

lemma sender_ip_valid':
  "paodv i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<xi>, _), a, _). anycast (\<lambda>m. not_Pkt m \<longrightarrow> msg_sender m = ip \<xi>) a)"
  by inv_cterms

lemma sender_ip_valid:
  "paodv i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<xi>, _), a, _). anycast (\<lambda>m. not_Pkt m \<longrightarrow> msg_sender m = i) a)"
  by (rule step_invariant_weaken_with_invariantE [OF ip_constant sender_ip_valid'])
     (auto dest!: onlD onllD)

lemma received_msg_inv:
  "paodv i \<TTurnstile> (recvmsg P \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l). l \<in> {PAodv-:1} \<longrightarrow> P (msg \<xi>))"
  by inv_cterms

text \<open>Proposition 7.9\<close>

lemma sip_not_ip':
  "paodv i \<TTurnstile> (recvmsg (\<lambda>m. not_Pkt m \<longrightarrow> msg_sender m \<noteq> i) \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, _). sip \<xi> \<noteq> ip \<xi>)"
  by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf received_msg_inv]
                          onl_invariant_sterms [OF aodv_wf ip_constant [THEN invariant_restrict_inD]]
                simp add: clear_locals_sip_not_ip') clarsimp+

lemma sip_not_ip:
  "paodv i \<TTurnstile> (recvmsg (\<lambda>m. not_Pkt m \<longrightarrow> msg_sender m \<noteq> i) \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, _). sip \<xi> \<noteq> i)"
  by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf received_msg_inv]
                          onl_invariant_sterms [OF aodv_wf ip_constant [THEN invariant_restrict_inD]]
                simp add: clear_locals_sip_not_ip') clarsimp+

text \<open>Neither \<open>sip_not_ip'\<close> nor \<open>sip_not_ip\<close> is needed to show loop freedom.\<close>

text \<open>Proposition 7.10\<close>

lemma hop_count_positive:
  "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, _). \<forall>ip\<in>kD (rt \<xi>). the (dhops (rt \<xi>) ip) \<ge> 1)"
  by (inv_cterms) auto

lemma rreq_dip_in_vD_dip_eq_ip:
  "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l). (l \<in> {PRreq-:16..PRreq-:17} \<longrightarrow> dip \<xi> \<in> vD(rt \<xi>))
                            \<and> (l \<in> {PRreq-:6, PRreq-:7} \<longrightarrow> dip \<xi> = ip \<xi>)
                            \<and> (l \<in> {PRreq-:15..PRreq-:17} \<longrightarrow> dip \<xi> \<noteq> ip \<xi>))"
  by inv_cterms

lemma rrep_dip_in_vD:
  "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l). (l \<in> {PRrep-:4} \<longrightarrow> dip \<xi> \<in> vD(rt \<xi>)))"
  by inv_cterms

text \<open>Proposition 7.11\<close>

lemma anycast_msg_zhops:
  "\<And>rreqid dip dsn dsk oip osn sip.
      paodv i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(_, a, _). anycast msg_zhops a)"
  proof (inv_cterms inv add:
           onl_invariant_sterms [OF aodv_wf rreq_dip_in_vD_dip_eq_ip]
           onl_invariant_sterms [OF aodv_wf rrep_dip_in_vD]
           onl_invariant_sterms [OF aodv_wf hop_count_positive],
         elim conjE)
    fix l \<xi> a pp p' pp'
    assume "(\<xi>, pp) \<in> reachable (paodv i) TT"
       and "{PRreq-:16}unicast(\<lambda>\<xi>. the (nhop (rt \<xi>) (oip \<xi>)),
               \<lambda>\<xi>. Rrep (the (dhops (rt \<xi>) (dip \<xi>))) (dip \<xi>) (sqn (rt \<xi>) (dip \<xi>)) (oip \<xi>) (ip \<xi>)).
                     p' \<triangleright> pp' \<in> sterms \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V pp"
       and "l = PRreq-:16"
       and "a = unicast (the (nhop (rt \<xi>) (oip \<xi>)))
                 (Rrep (the (dhops (rt \<xi>) (dip \<xi>))) (dip \<xi>) (sqn (rt \<xi>) (dip \<xi>)) (oip \<xi>) (ip \<xi>))"
       and *: "\<forall>ip\<in>kD (rt \<xi>). Suc 0 \<le> the (dhops (rt \<xi>) ip)"
       and "dip \<xi> \<in> vD (rt \<xi>)"
    from \<open>dip \<xi> \<in> vD (rt \<xi>)\<close> have "dip \<xi> \<in> kD (rt \<xi>)"
      by (rule vD_iD_gives_kD(1))
    with * have "Suc 0 \<le> the (dhops (rt \<xi>) (dip \<xi>))" ..
    thus "0 < the (dhops (rt \<xi>) (dip \<xi>))" by simp
  next
    fix l \<xi> a pp p' pp'
    assume "(\<xi>, pp) \<in> reachable (paodv i) TT"
      and "{PRrep-:4}unicast(\<lambda>\<xi>. the (nhop (rt \<xi>) (oip \<xi>)),
              \<lambda>\<xi>. Rrep (the (dhops (rt \<xi>) (dip \<xi>))) (dip \<xi>) (sqn (rt \<xi>) (dip \<xi>)) (oip \<xi>) (ip \<xi>)).
                     p' \<triangleright> pp' \<in> sterms \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V pp"
      and "l = PRrep-:4"
      and "a = unicast (the (nhop (rt \<xi>) (oip \<xi>)))
                 (Rrep (the (dhops (rt \<xi>) (dip \<xi>))) (dip \<xi>) (sqn (rt \<xi>) (dip \<xi>)) (oip \<xi>) (ip \<xi>))"
      and *: "\<forall>ip\<in>kD (rt \<xi>). Suc 0 \<le> the (dhops (rt \<xi>) ip)"
      and "dip \<xi> \<in> vD (rt \<xi>)"
    from \<open>dip \<xi> \<in> vD (rt \<xi>)\<close> have "dip \<xi> \<in> kD (rt \<xi>)"
      by (rule vD_iD_gives_kD(1))
    with * have "Suc 0 \<le> the (dhops (rt \<xi>) (dip \<xi>))" ..
    thus "the (dhops (rt \<xi>) (dip \<xi>)) = 0 \<longrightarrow> dip \<xi> = ip \<xi>"
      by auto
  qed

lemma hop_count_zero_oip_dip_sip:
  "paodv i \<TTurnstile> (recvmsg msg_zhops \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                 (l\<in>{PAodv-:4..PAodv-:5} \<union> {PRreq-:n|n. True} \<longrightarrow>
                          (hops \<xi> = 0 \<longrightarrow> oip \<xi> = sip \<xi>))
                 \<and>
                 ((l\<in>{PAodv-:6..PAodv-:7} \<union> {PRrep-:n|n. True} \<longrightarrow>
                          (hops \<xi> = 0 \<longrightarrow> dip \<xi> = sip \<xi>))))"
  by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf received_msg_inv]) auto

lemma osn_rreq:
  "paodv i \<TTurnstile> (recvmsg rreq_rrep_sn \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                                    l \<in> {PAodv-:4, PAodv-:5} \<union> {PRreq-:n|n. True} \<longrightarrow> 1 \<le> osn \<xi>)"
  by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf received_msg_inv]) clarsimp

lemma osn_rreq':
  "paodv i \<TTurnstile> (recvmsg (\<lambda>m. rreq_rrep_sn m \<and> msg_zhops m) \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                                    l \<in> {PAodv-:4, PAodv-:5} \<union> {PRreq-:n|n. True} \<longrightarrow> 1 \<le> osn \<xi>)"
  proof (rule invariant_weakenE [OF osn_rreq])
    fix a
    assume "recvmsg (\<lambda>m. rreq_rrep_sn m \<and> msg_zhops m) a"
    thus "recvmsg rreq_rrep_sn a"
      by (cases a) simp_all
  qed

lemma dsn_rrep:
  "paodv i \<TTurnstile> (recvmsg rreq_rrep_sn \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                                    l \<in> {PAodv-:6, PAodv-:7} \<union> {PRrep-:n|n. True} \<longrightarrow> 1 \<le> dsn \<xi>)"
  by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf received_msg_inv]) clarsimp

lemma dsn_rrep':
  "paodv i \<TTurnstile> (recvmsg (\<lambda>m. rreq_rrep_sn m \<and> msg_zhops m) \<rightarrow>)  onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                                    l \<in> {PAodv-:6, PAodv-:7} \<union> {PRrep-:n|n. True} \<longrightarrow> 1 \<le> dsn \<xi>)"
  proof (rule invariant_weakenE [OF dsn_rrep])
    fix a
    assume "recvmsg (\<lambda>m. rreq_rrep_sn m \<and> msg_zhops m) a"
    thus "recvmsg rreq_rrep_sn a"
      by (cases a) simp_all
  qed

lemma hop_count_zero_oip_dip_sip':
  "paodv i \<TTurnstile> (recvmsg (\<lambda>m. rreq_rrep_sn m \<and> msg_zhops m) \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                 (l\<in>{PAodv-:4..PAodv-:5} \<union> {PRreq-:n|n. True} \<longrightarrow>
                          (hops \<xi> = 0 \<longrightarrow> oip \<xi> = sip \<xi>))
                 \<and>
                 ((l\<in>{PAodv-:6..PAodv-:7} \<union> {PRrep-:n|n. True} \<longrightarrow>
                          (hops \<xi> = 0 \<longrightarrow> dip \<xi> = sip \<xi>))))"
  proof (rule invariant_weakenE [OF hop_count_zero_oip_dip_sip])
    fix a
    assume "recvmsg (\<lambda>m. rreq_rrep_sn m \<and> msg_zhops m) a"
    thus "recvmsg msg_zhops a"
      by (cases a) simp_all
  qed

text \<open>Proposition 7.12\<close>

lemma zero_seq_unk_hops_one':
  "paodv i \<TTurnstile> (recvmsg (\<lambda>m. rreq_rrep_sn m \<and> msg_zhops m) \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, _).
                 \<forall>dip\<in>kD(rt \<xi>). (sqn (rt \<xi>) dip = 0 \<longrightarrow> sqnf (rt \<xi>) dip = unk)
                              \<and> (sqnf (rt \<xi>) dip = unk \<longrightarrow> the (dhops (rt \<xi>) dip) = 1)
                              \<and> (the (dhops (rt \<xi>) dip) = 1 \<longrightarrow> the (nhop (rt \<xi>) dip) = dip))"
  proof -
  { fix dip and \<xi> :: state and P
    assume "sqn (invalidate (rt \<xi>) (dests \<xi>)) dip = 0"
       and all: "\<forall>ip. sqn (rt \<xi>) ip \<le> sqn (invalidate (rt \<xi>) (dests \<xi>)) ip"
       and *: "sqn (rt \<xi>) dip = 0 \<Longrightarrow> P \<xi> dip"
    have "P \<xi> dip"
    proof -
      from all have "sqn (rt \<xi>) dip \<le> sqn (invalidate (rt \<xi>) (dests \<xi>)) dip" ..
      with \<open>sqn (invalidate (rt \<xi>) (dests \<xi>)) dip = 0\<close> have "sqn (rt \<xi>) dip = 0" by simp
      thus "P \<xi> dip" by (rule *)
    qed
  } note sqn_invalidate_zero [elim!] = this

  { fix dsn hops :: nat and sip oip rt and ip dip :: ip
    assume "\<forall>dip\<in>kD(rt).
                (sqn rt dip = 0 \<longrightarrow> \<pi>\<^sub>3(the (rt dip)) = unk) \<and>
                (\<pi>\<^sub>3(the (rt dip)) = unk \<longrightarrow> the (dhops rt dip) = Suc 0) \<and>
                (the (dhops rt dip) = Suc 0 \<longrightarrow> the (nhop rt dip) = dip)"
       and "hops = 0 \<longrightarrow> sip = dip"
       and "Suc 0 \<le> dsn"
       and "ip \<noteq> dip \<longrightarrow> ip\<in>kD(rt)"
    hence "the (dhops (update rt dip (dsn, kno, val, Suc hops, sip)) ip) = Suc 0 \<longrightarrow>
           the (nhop (update rt dip (dsn, kno, val, Suc hops, sip)) ip) = ip"
      by - (rule update_cases, auto simp add: sqn_def dest!: bspec)
  } note prreq_ok1 [simp] = this

  { fix ip dsn hops sip oip rt dip
    assume "\<forall>dip\<in>kD(rt).
                (sqn rt dip = 0 \<longrightarrow> \<pi>\<^sub>3(the (rt dip)) = unk) \<and>
                (\<pi>\<^sub>3(the (rt dip)) = unk \<longrightarrow> the (dhops rt dip) = Suc 0) \<and>
                (the (dhops rt dip) = Suc 0 \<longrightarrow> the (nhop rt dip) = dip)"
       and "Suc 0 \<le> dsn"
       and "ip \<noteq> dip \<longrightarrow> ip\<in>kD(rt)"
    hence "\<pi>\<^sub>3(the (update rt dip (dsn, kno, val, Suc hops, sip) ip)) = unk \<longrightarrow>
           the (dhops (update rt dip (dsn, kno, val, Suc hops, sip)) ip) = Suc 0"
      by - (rule update_cases, auto simp add: sqn_def sqnf_def dest!: bspec)
  } note prreq_ok2 [simp] = this

  { fix ip dsn hops sip oip rt dip
    assume "\<forall>dip\<in>kD(rt).
                (sqn rt dip = 0 \<longrightarrow> \<pi>\<^sub>3(the (rt dip)) = unk) \<and>
                (\<pi>\<^sub>3(the (rt dip)) = unk \<longrightarrow> the (dhops rt dip) = Suc 0) \<and>
                (the (dhops rt dip) = Suc 0 \<longrightarrow> the (nhop rt dip) = dip)"
       and "Suc 0 \<le> dsn"
       and "ip \<noteq> dip \<longrightarrow> ip\<in>kD(rt)"
    hence "sqn (update rt dip (dsn, kno, val, Suc hops, sip)) ip = 0 \<longrightarrow>
           \<pi>\<^sub>3 (the (update rt dip (dsn, kno, val, Suc hops, sip) ip)) = unk"
      by - (rule update_cases, auto simp add: sqn_def dest!: bspec)
  } note prreq_ok3 [simp] = this

  { fix rt sip
    assume "\<forall>dip\<in>kD rt.
              (sqn rt dip = 0 \<longrightarrow> \<pi>\<^sub>3(the (rt dip)) = unk) \<and>
              (\<pi>\<^sub>3(the (rt dip)) = unk \<longrightarrow> the (dhops rt dip) = Suc 0) \<and>
              (the (dhops rt dip) = Suc 0 \<longrightarrow> the (nhop rt dip) = dip)"
    hence "\<forall>dip\<in>kD rt.
          (sqn (update rt sip (0, unk, val, Suc 0, sip)) dip = 0 \<longrightarrow>
           \<pi>\<^sub>3(the (update rt sip (0, unk, val, Suc 0, sip) dip)) = unk)
        \<and> (\<pi>\<^sub>3(the (update rt sip (0, unk, val, Suc 0, sip) dip)) = unk \<longrightarrow>
           the (dhops (update rt sip (0, unk, val, Suc 0, sip)) dip) = Suc 0)
        \<and> (the (dhops (update rt sip (0, unk, val, Suc 0, sip)) dip) = Suc 0 \<longrightarrow>
           the (nhop (update rt sip (0, unk, val, Suc 0, sip)) dip) = dip)"
    by - (rule update_cases, simp_all add: sqnf_def sqn_def)
  } note prreq_ok4 [simp] = this

  have prreq_ok5 [simp]: "\<And>sip rt.
    \<pi>\<^sub>3(the (update rt sip (0, unk, val, Suc 0, sip) sip)) = unk \<longrightarrow>
    the (dhops (update rt sip (0, unk, val, Suc 0, sip)) sip) = Suc 0"
    by (rule update_cases) simp_all

  have prreq_ok6 [simp]: "\<And>sip rt.
    sqn (update rt sip (0, unk, val, Suc 0, sip)) sip = 0 \<longrightarrow>
    \<pi>\<^sub>3 (the (update rt sip (0, unk, val, Suc 0, sip) sip)) = unk"
    by (rule update_cases) simp_all

  show ?thesis
    by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf hop_count_zero_oip_dip_sip']
                            seq_step_invariant_sterms_TT [OF sqns_increase aodv_wf aodv_trans]
                            onl_invariant_sterms [OF aodv_wf osn_rreq']
                            onl_invariant_sterms [OF aodv_wf dsn_rrep']) clarsimp+
  qed

lemma zero_seq_unk_hops_one:
  "paodv i \<TTurnstile> (recvmsg (\<lambda>m. rreq_rrep_sn m \<and> msg_zhops m) \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, _).
                 \<forall>dip\<in>kD(rt \<xi>). (sqn (rt \<xi>) dip = 0 \<longrightarrow> (sqnf (rt \<xi>) dip = unk
                                                         \<and> the (dhops (rt \<xi>) dip) = 1
                                                         \<and> the (nhop (rt \<xi>) dip) = dip)))"
  by (rule invariant_weakenE [OF zero_seq_unk_hops_one']) auto

lemma kD_unk_or_atleast_one:
  "paodv i \<TTurnstile> (recvmsg rreq_rrep_sn \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                               \<forall>dip\<in>kD(rt \<xi>). \<pi>\<^sub>3(the (rt \<xi> dip)) = unk \<or> 1 \<le> \<pi>\<^sub>2(the (rt \<xi> dip)))"
  proof -
    { fix sip rt dsn1 dsn2 dsk1 dsk2 flag1 flag2 hops1 hops2 nhip1 nhip2
      assume "dsk1 = unk \<or> Suc 0 \<le> dsn2"
      hence "\<pi>\<^sub>3(the (update rt sip (dsn1, dsk1, flag1, hops1, nhip1) sip)) = unk
            \<or> Suc 0 \<le> sqn (update rt sip (dsn2, dsk2, flag2, hops2, nhip2)) sip"
        unfolding update_def by (cases "dsk1 =unk") (clarsimp split: option.split)+
    } note fromsip [simp] = this

    { fix dip sip rt dsn1 dsn2 dsk1 dsk2 flag1 flag2 hops1 hops2 nhip1 nhip2
      assume allkd: "\<forall>dip\<in>kD(rt). \<pi>\<^sub>3(the (rt dip)) = unk \<or> Suc 0 \<le> sqn rt dip"
         and    **: "dsk1 = unk \<or> Suc 0 \<le> dsn2"
      have "\<forall>dip\<in>kD(rt). \<pi>\<^sub>3(the (update rt sip (dsn1, dsk1, flag1, hops1, nhip1) dip)) = unk
            \<or> Suc 0 \<le> sqn (update rt sip (dsn2, dsk2, flag2, hops2, nhip2)) dip"
        (is "\<forall>dip\<in>kD(rt). ?prop dip")
      proof
        fix dip
        assume "dip\<in>kD(rt)"
        thus "?prop dip"
        proof (cases "dip = sip")
          assume "dip = sip"
          with ** show ?thesis
            by simp
        next
          assume "dip \<noteq> sip"
          with \<open>dip\<in>kD(rt)\<close> allkd show ?thesis
            by simp
        qed
      qed
    } note solve_update [simp] = this

    { fix dip rt dests
      assume  *: "\<forall>ip\<in>dom(dests). ip\<in>kD(rt) \<and> sqn rt ip \<le> the (dests ip)"
         and **: "\<forall>ip\<in>kD(rt). \<pi>\<^sub>3(the (rt ip)) = unk \<or> Suc 0 \<le> sqn rt ip"
      have "\<forall>dip\<in>kD(rt). \<pi>\<^sub>3(the (rt dip)) = unk \<or> Suc 0 \<le> sqn (invalidate rt dests) dip"
      proof
        fix dip
        assume "dip\<in>kD(rt)"
        with ** have "\<pi>\<^sub>3(the (rt dip)) = unk \<or> Suc 0 \<le> sqn rt dip" ..
        thus "\<pi>\<^sub>3 (the (rt dip)) = unk \<or> Suc 0 \<le> sqn (invalidate rt dests) dip"
        proof
          assume "\<pi>\<^sub>3(the (rt dip)) = unk" thus ?thesis ..
        next
          assume "Suc 0 \<le> sqn rt dip"
          have "Suc 0 \<le> sqn (invalidate rt dests) dip"
          proof (cases "dip\<in>dom(dests)")
            assume "dip\<in>dom(dests)"
            with * have "sqn rt dip \<le> the (dests dip)" by simp
            with \<open>Suc 0 \<le> sqn rt dip\<close> have "Suc 0 \<le> the (dests dip)" by simp
            with \<open>dip\<in>dom(dests)\<close> \<open>dip\<in>kD(rt)\<close> [THEN kD_Some] show ?thesis
              unfolding invalidate_def sqn_def by auto
          next
            assume "dip\<notin>dom(dests)"
            with \<open>Suc 0 \<le> sqn rt dip\<close> \<open>dip\<in>kD(rt)\<close> [THEN kD_Some] show ?thesis
              unfolding invalidate_def sqn_def by auto
          qed
        thus ?thesis by (rule disjI2)
        qed
      qed
    } note solve_invalidate [simp] = this

    show ?thesis
      by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf dests_bigger_than_sqn
                                                               [THEN invariant_restrict_inD]]
                              onl_invariant_sterms [OF aodv_wf osn_rreq]
                              onl_invariant_sterms [OF aodv_wf dsn_rrep]
                    simp add: proj3_inv proj2_eq_sqn)
  qed

text \<open>Proposition 7.13\<close>

lemma rreq_rrep_sn_any_step_invariant:
  "paodv i \<TTurnstile>\<^sub>A (recvmsg rreq_rrep_sn \<rightarrow>) onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(_, a, _). anycast rreq_rrep_sn a)"
  proof -
    (* due to lack of addpreRT_welldefined, sqnf_know needed some small adaption [adding dip \<xi> \<in> kD (rt \<xi>)] *)
    have sqnf_kno: "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                                      (l \<in> {PRreq-:16} \<longrightarrow> dip \<xi> \<in> kD (rt \<xi>) \<and> sqnf (rt \<xi>) (dip \<xi>) = kno))"
      by (inv_cterms)

    have rrep_sqn_greater_dsn: "paodv i \<TTurnstile> (recvmsg rreq_rrep_sn \<rightarrow>) onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                                      (l \<in> {PRrep-:1 .. PRrep-:4} \<longrightarrow> 1 \<le> sqn (rt \<xi>) (dip \<xi>)))"
      by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf received_msg_inv]
                              onl_invariant_sterms [OF aodv_wf dsn_rrep])
         (clarsimp simp: update_kno_dsn_greater_zero [simplified])
    show ?thesis
      by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf sequence_number_one_or_bigger
                                                               [THEN invariant_restrict_inD]]
                              onl_invariant_sterms [OF aodv_wf kD_unk_or_atleast_one]
                              onl_invariant_sterms_TT [OF aodv_wf sqnf_kno]
                              onl_invariant_sterms [OF aodv_wf osn_rreq]
                              onl_invariant_sterms [OF aodv_wf dsn_rrep]
                              onl_invariant_sterms [OF aodv_wf rrep_sqn_greater_dsn])
         (auto simp: proj2_eq_sqn)
  qed

text \<open>Proposition 7.14\<close>

lemma rreq_rrep_fresh_any_step_invariant:
  "paodv i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<xi>, _), a, _). anycast (rreq_rrep_fresh (rt \<xi>)) a)"
  proof -
    have rreq_oip: "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                       (l \<in> {PRreq-:3..PRreq-:9} \<union> {PRreq-:15, PRreq-:24, PRreq-:26}
                               \<longrightarrow> oip \<xi> \<in> kD(rt \<xi>)
                                 \<and> (sqn (rt \<xi>) (oip \<xi>) > (osn \<xi>)
                                     \<or> (sqn (rt \<xi>) (oip \<xi>) = (osn \<xi>)
                                        \<and> the (dhops (rt \<xi>) (oip \<xi>)) \<le> Suc (hops \<xi>)
                                        \<and> the (flag (rt \<xi>) (oip \<xi>)) = val))))"
      proof inv_cterms
        fix l \<xi> l' pp p'
        assume "(\<xi>, pp) \<in> reachable (paodv i) TT"
           and "{PRreq-:2}\<lbrakk>\<lambda>\<xi>. \<xi>\<lparr>rt :=
                update (rt \<xi>) (oip \<xi>) (osn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>)\<rparr>\<rbrakk> p' \<in> sterms \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V pp"
           and "l' = PRreq-:3"
        show "osn \<xi> < sqn (update (rt \<xi>) (oip \<xi>) (osn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>)) (oip \<xi>)
           \<or> (sqn (update (rt \<xi>) (oip \<xi>) (osn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>)) (oip \<xi>) = osn \<xi>
             \<and> the (dhops (update (rt \<xi>) (oip \<xi>) (osn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>)) (oip \<xi>))
                                                                            \<le> Suc (hops \<xi>)
             \<and> the (flag (update (rt \<xi>) (oip \<xi>) (osn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>)) (oip \<xi>))
                                                                            = val)"
          unfolding update_def by (clarsimp split: option.split)
                                  (metis linorder_neqE_nat not_less)
      qed

    have rrep_prrep: "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
          (l \<in> {PRrep-:4} \<longrightarrow> (dip \<xi> \<in> kD(rt \<xi>)
                                        \<and> the (flag (rt \<xi>) (dip \<xi>)) = val)))"
      by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf sip_in_kD])

    have rreq_oip_kD: "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l). (l \<in> {PRreq-:3..PRreq-:22} \<longrightarrow> oip \<xi> \<in> kD(rt \<xi>)))"
      by(inv_cterms)

    have rreq_dip_kD_oip_sqn: "paodv i \<TTurnstile> onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l).
                       (l \<in> {PRreq-:16..PRreq-:17}
                              \<longrightarrow> (dip \<xi> \<in> kD(rt \<xi>)
                                 \<and> (sqn (rt \<xi>) (oip \<xi>) > (osn \<xi>)
                                     \<or> (sqn (rt \<xi>) (oip \<xi>) = (osn \<xi>)
                                        \<and> the (dhops (rt \<xi>) (oip \<xi>)) \<le> Suc (hops \<xi>)
                                        \<and> the (flag (rt \<xi>) (oip \<xi>)) = val)))))"
      by(inv_cterms inv add: onl_invariant_sterms [OF aodv_wf rreq_oip])
    show ?thesis
      by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf rreq_oip]
                              onl_invariant_sterms [OF aodv_wf rreq_dip_in_vD_dip_eq_ip]
                              onl_invariant_sterms [OF aodv_wf rrep_prrep]
                              onl_invariant_sterms [OF aodv_wf rreq_oip_kD]
                              onl_invariant_sterms [OF aodv_wf rreq_dip_kD_oip_sqn])
  qed

text \<open>Proposition 7.15\<close>

lemma rerr_invalid_any_step_invariant:
  "paodv i \<TTurnstile>\<^sub>A onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<xi>, _), a, _). anycast (rerr_invalid (rt \<xi>)) a)"
  proof -
    have dests_inv: "paodv i \<TTurnstile>
                      onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l). (l \<in> {PAodv-:15, PPkt-:7, PRreq-:11,
                                            PRreq-:20, PRrep-:7, PRerr-:1}
                          \<longrightarrow> (\<forall>ip\<in>dom(dests \<xi>). ip\<in>vD(rt \<xi>)))
                         \<and> (l \<in> {PAodv-:16..PAodv-:17}
                              \<union> {PPkt-:8..PPkt-:9}
                              \<union> {PRreq-:12..PRreq-:13}
                              \<union> {PRreq-:21..PRreq-:22}
                              \<union> {PRrep-:8..PRrep-:9}
                              \<union> {PRerr-:2..PRerr-:4} \<longrightarrow> (\<forall>ip\<in>dom(dests \<xi>). ip\<in>iD(rt \<xi>)
                                                          \<and> the (dests \<xi> ip) = sqn (rt \<xi>) ip))
                         \<and> (l = PPkt-:12 \<longrightarrow> dip \<xi>\<in>iD(rt \<xi>)))"
      by inv_cterms (clarsimp split: if_split_asm option.split_asm simp: domIff)+
    show ?thesis
      by (inv_cterms inv add: onl_invariant_sterms [OF aodv_wf dests_inv])
  qed

text \<open>Proposition 7.16\<close>

text \<open>
  Some well-definedness obligations are irrelevant for the Isabelle development:

  \begin{enumerate}
  \item In each routing table there is at most one entry for each destination: guaranteed by type.

  \item In each store of queued data packets there is at most one data queue for
        each destination: guaranteed by structure.

  \item Whenever a set of pairs @{term "(rip, rsn)"} is assigned to the variable
        @{term "dests"} of type @{typ "ip \<rightharpoonup> sqn"}, or to the first argument of
        the function @{term "rerr"}, this set is a partial function, i.e., there
        is at most one entry @{term "(rip, rsn)"} for each destination
        @{term "rip"}: guaranteed by type.
  \end{enumerate}
\<close>

lemma dests_vD_inc_sqn:
  "paodv i \<TTurnstile>
        onl \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(\<xi>, l). (l \<in> {PAodv-:15, PPkt-:7, PRreq-:11, PRreq-:20, PRrep-:7}
             \<longrightarrow> (\<forall>ip\<in>dom(dests \<xi>). ip\<in>vD(rt \<xi>) \<and> the (dests \<xi> ip) = inc (sqn (rt \<xi>) ip)))
           \<and> (l = PRerr-:1
             \<longrightarrow> (\<forall>ip\<in>dom(dests \<xi>). ip\<in>vD(rt \<xi>) \<and> the (dests \<xi> ip) > sqn (rt \<xi>) ip)))"
  by inv_cterms (clarsimp split: if_split_asm option.split_asm)+

text \<open>Proposition 7.27\<close>

lemma route_tables_fresher:
  "paodv i \<TTurnstile>\<^sub>A (recvmsg rreq_rrep_sn \<rightarrow>) onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<xi>, _), _, (\<xi>', _)).
                                                                \<forall>dip\<in>kD(rt \<xi>). rt \<xi> \<sqsubseteq>\<^bsub>dip\<^esub> rt \<xi>')"
  proof (inv_cterms inv add:
           onl_invariant_sterms [OF aodv_wf dests_vD_inc_sqn [THEN invariant_restrict_inD]]
           onl_invariant_sterms [OF aodv_wf hop_count_positive [THEN invariant_restrict_inD]]
           onl_invariant_sterms [OF aodv_wf osn_rreq]
           onl_invariant_sterms [OF aodv_wf dsn_rrep]
           onl_invariant_sterms [OF aodv_wf invariant_restrict_inD])
    fix \<xi> pp p'
    assume "(\<xi>, pp) \<in> reachable (paodv i) (recvmsg rreq_rrep_sn)"
       and "{PRreq-:2}\<lbrakk>\<lambda>\<xi>. \<xi>\<lparr>rt := update (rt \<xi>) (oip \<xi>) (osn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>)\<rparr>\<rbrakk>
               p' \<in> sterms \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V pp"
       and "Suc 0 \<le> osn \<xi>"
       and *: "\<forall>ip\<in>kD (rt \<xi>). Suc 0 \<le> the (dhops (rt \<xi>) ip)"
    show "\<forall>ip\<in>kD (rt \<xi>). rt \<xi> \<sqsubseteq>\<^bsub>ip\<^esub> update (rt \<xi>) (oip \<xi>) (osn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>)"
    proof
      fix ip
      assume "ip\<in>kD (rt \<xi>)"
      moreover with * have "1 \<le> the (dhops (rt \<xi>) ip)" by simp
      moreover from \<open>Suc 0 \<le> osn \<xi>\<close>
        have "update_arg_wf (osn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>)" ..
      ultimately show "rt \<xi> \<sqsubseteq>\<^bsub>ip\<^esub> update (rt \<xi>) (oip \<xi>) (osn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>)"
        by (rule rt_fresher_update)
    qed
  next
    fix \<xi> pp p'
    assume "(\<xi>, pp) \<in> reachable (paodv i) (recvmsg rreq_rrep_sn)"
       and "{PRrep-:0}\<lbrakk>\<lambda>\<xi>. \<xi>\<lparr>rt := update (rt \<xi>) (dip \<xi>) (dsn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>)\<rparr>\<rbrakk>
            p' \<in> sterms \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V pp"
       and "Suc 0 \<le> dsn \<xi>"
       and *: "\<forall>ip\<in>kD (rt \<xi>). Suc 0 \<le> the (dhops (rt \<xi>) ip)"
    show "\<forall>ip\<in>kD (rt \<xi>). rt \<xi> \<sqsubseteq>\<^bsub>ip\<^esub> update (rt \<xi>) (dip \<xi>) (dsn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>)"
    proof
      fix ip
      assume "ip\<in>kD (rt \<xi>)"
      moreover with * have "1 \<le> the (dhops (rt \<xi>) ip)" by simp
      moreover from \<open>Suc 0 \<le> dsn \<xi>\<close>
        have "update_arg_wf (dsn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>)" ..
      ultimately show "rt \<xi> \<sqsubseteq>\<^bsub>ip\<^esub> update (rt \<xi>) (dip \<xi>) (dsn \<xi>, kno, val, Suc (hops \<xi>), sip \<xi>)"
        by (rule rt_fresher_update)
    qed
  qed

end


(*
    Author:   Benedikt Seidl
    License:  BSD
*)

section \<open>The ``after''-Function\<close>

theory After
imports
  LTL.LTL LTL.Equivalence_Relations Syntactic_Fragments_and_Stability
begin

subsection \<open>Definition of af\<close>

primrec af_letter :: "'a ltln \<Rightarrow> 'a set \<Rightarrow> 'a ltln"
where
  "af_letter true\<^sub>n \<nu> = true\<^sub>n"
| "af_letter false\<^sub>n \<nu> = false\<^sub>n"
| "af_letter prop\<^sub>n(a) \<nu> = (if a \<in> \<nu> then true\<^sub>n else false\<^sub>n)"
| "af_letter nprop\<^sub>n(a) \<nu>  = (if a \<notin> \<nu> then true\<^sub>n else false\<^sub>n)"
| "af_letter (\<phi> and\<^sub>n \<psi>) \<nu> = (af_letter \<phi> \<nu>) and\<^sub>n (af_letter \<psi> \<nu>)"
| "af_letter (\<phi> or\<^sub>n \<psi>) \<nu> = (af_letter \<phi> \<nu>) or\<^sub>n (af_letter \<psi> \<nu>)"
| "af_letter (X\<^sub>n \<phi>) \<nu> = \<phi>"
| "af_letter (\<phi> U\<^sub>n \<psi>) \<nu> = (af_letter \<psi> \<nu>) or\<^sub>n ((af_letter \<phi> \<nu>) and\<^sub>n (\<phi> U\<^sub>n \<psi>))"
| "af_letter (\<phi> R\<^sub>n \<psi>) \<nu> = (af_letter \<psi> \<nu>) and\<^sub>n ((af_letter \<phi> \<nu>) or\<^sub>n (\<phi> R\<^sub>n \<psi>))"
| "af_letter (\<phi> W\<^sub>n \<psi>) \<nu> = (af_letter \<psi> \<nu>) or\<^sub>n ((af_letter \<phi> \<nu>) and\<^sub>n (\<phi> W\<^sub>n \<psi>))"
| "af_letter (\<phi> M\<^sub>n \<psi>) \<nu> = (af_letter \<psi> \<nu>) and\<^sub>n ((af_letter \<phi> \<nu>) or\<^sub>n (\<phi> M\<^sub>n \<psi>))"

abbreviation af :: "'a ltln \<Rightarrow> 'a set list \<Rightarrow> 'a ltln"
where
  "af \<phi> w \<equiv> foldl af_letter \<phi> w"

lemma af_simps[simp]:
  "af true\<^sub>n w = true\<^sub>n"
  "af false\<^sub>n w = false\<^sub>n"
  "af (X\<^sub>n \<phi>) (x # xs) = af \<phi> xs"
  by (induction w) simp_all

lemma af_subsequence_append:
  "i \<le> j \<Longrightarrow> j \<le> k \<Longrightarrow> af (af \<phi> (w [i \<rightarrow> j])) (w [j \<rightarrow> k]) = af \<phi> (w [i \<rightarrow> k])"
  by (metis foldl_append le_Suc_ex map_append subsequence_def upt_add_eq_append)

lemma af_subsequence_U:
  "af (\<phi> U\<^sub>n \<psi>) (w [0 \<rightarrow> Suc n]) = (af \<psi> (w [0 \<rightarrow> Suc n])) or\<^sub>n ((af \<phi> (w [0 \<rightarrow> Suc n])) and\<^sub>n af (\<phi> U\<^sub>n \<psi>) (w [1 \<rightarrow> Suc n]))"
  by (induction n) fastforce+

lemma af_subsequence_U':
  "af (\<phi> U\<^sub>n \<psi>) (a # xs) = (af \<psi> (a # xs)) or\<^sub>n ((af \<phi> (a # xs)) and\<^sub>n af (\<phi> U\<^sub>n \<psi>) xs)"
  by (simp add: af_decompose)

lemma af_subsequence_R:
  "af (\<phi> R\<^sub>n \<psi>) (w [0 \<rightarrow> Suc n]) = (af \<psi> (w [0 \<rightarrow> Suc n])) and\<^sub>n ((af \<phi> (w [0 \<rightarrow> Suc n])) or\<^sub>n af (\<phi> R\<^sub>n \<psi>) (w [1 \<rightarrow> Suc n]))"
  by (induction n) fastforce+

lemma af_subsequence_R':
  "af (\<phi> R\<^sub>n \<psi>) (a # xs) = (af \<psi> (a # xs)) and\<^sub>n ((af \<phi> (a # xs)) or\<^sub>n af (\<phi> R\<^sub>n \<psi>) xs)"
  by (simp add: af_decompose)

lemma af_subsequence_W:
  "af (\<phi> W\<^sub>n \<psi>) (w [0 \<rightarrow> Suc n]) = (af \<psi> (w [0 \<rightarrow> Suc n])) or\<^sub>n ((af \<phi> (w [0 \<rightarrow> Suc n])) and\<^sub>n af (\<phi> W\<^sub>n \<psi>) (w [1 \<rightarrow> Suc n]))"
  by (induction n) fastforce+

lemma af_subsequence_W':
  "af (\<phi> W\<^sub>n \<psi>) (a # xs) = (af \<psi> (a # xs)) or\<^sub>n ((af \<phi> (a # xs)) and\<^sub>n af (\<phi> W\<^sub>n \<psi>) xs)"
  by (simp add: af_decompose)

lemma af_subsequence_M:
  "af (\<phi> M\<^sub>n \<psi>) (w [0 \<rightarrow> Suc n]) = (af \<psi> (w [0 \<rightarrow> Suc n])) and\<^sub>n ((af \<phi> (w [0 \<rightarrow> Suc n])) or\<^sub>n af (\<phi> M\<^sub>n \<psi>) (w [1 \<rightarrow> Suc n]))"
  by (induction n) fastforce+

lemma af_subsequence_M':
  "af (\<phi> M\<^sub>n \<psi>) (a # xs) = (af \<psi> (a # xs)) and\<^sub>n ((af \<phi> (a # xs)) or\<^sub>n af (\<phi> M\<^sub>n \<psi>) xs)"
  by (simp add: af_decompose)

lemma suffix_build[simp]:
  "suffix (Suc n) (x ## xs) = suffix n xs"
  by fastforce

lemma af_letter_build:
  "(x ## w) \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n af_letter \<phi> x"
proof (induction \<phi> arbitrary: x w)
  case (Until_ltln \<phi> \<psi>)
  then show ?case
    unfolding ltln_expand_Until by force
next
  case (Release_ltln \<phi> \<psi>)
  then show ?case
    unfolding ltln_expand_Release by force
next
  case (WeakUntil_ltln \<phi> \<psi>)
  then show ?case
    unfolding ltln_expand_WeakUntil by force
next
  case (StrongRelease_ltln \<phi> \<psi>)
  then show ?case
    unfolding ltln_expand_StrongRelease by force
qed simp+

lemma af_ltl_continuation:
  "(w \<frown> w') \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow> w' \<Turnstile>\<^sub>n af \<phi> w"
proof (induction w arbitrary: \<phi> w')
  case (Cons x xs)
  then show ?case
    using af_letter_build by fastforce
qed simp

subsection \<open>Range of the after function\<close>

lemma af_letter_atoms:
  "atoms_ltln (af_letter \<phi> \<nu>) \<subseteq> atoms_ltln \<phi>"
  by (induction \<phi>) auto

lemma af_atoms:
  "atoms_ltln (af \<phi> w) \<subseteq> atoms_ltln \<phi>"
  by (induction w rule: rev_induct) (simp, insert af_letter_atoms, fastforce)

lemma af_letter_nested_prop_atoms:
  "nested_prop_atoms (af_letter \<phi> \<nu>) \<subseteq> nested_prop_atoms \<phi>"
  by (induction \<phi>) auto

lemma af_nested_prop_atoms:
  "nested_prop_atoms (af \<phi> w) \<subseteq> nested_prop_atoms \<phi>"
  by (induction w rule: rev_induct) (auto, insert af_letter_nested_prop_atoms, blast)

lemma af_letter_range:
  "range (af_letter \<phi>) \<subseteq> {\<psi>. nested_prop_atoms \<psi> \<subseteq> nested_prop_atoms \<phi>}"
  using af_letter_nested_prop_atoms by blast

lemma af_range:
  "range (af \<phi>) \<subseteq> {\<psi>. nested_prop_atoms \<psi> \<subseteq> nested_prop_atoms \<phi>}"
  using af_nested_prop_atoms by blast

subsection \<open>Subformulas of the after function\<close>

lemma af_letter_subformulas\<^sub>\<mu>:
  "subformulas\<^sub>\<mu> (af_letter \<phi> \<xi>) = subformulas\<^sub>\<mu> \<phi>"
  by (induction \<phi>) auto

lemma af_subformulas\<^sub>\<mu>:
  "subformulas\<^sub>\<mu> (af \<phi> w) = subformulas\<^sub>\<mu> \<phi>"
  using af_letter_subformulas\<^sub>\<mu>
  by (induction w arbitrary: \<phi> rule: rev_induct) (simp, fastforce)

lemma af_letter_subformulas\<^sub>\<nu>:
  "subformulas\<^sub>\<nu> (af_letter \<phi> \<xi>) = subformulas\<^sub>\<nu> \<phi>"
  by (induction \<phi>) auto

lemma af_subformulas\<^sub>\<nu>:
  "subformulas\<^sub>\<nu> (af \<phi> w) = subformulas\<^sub>\<nu> \<phi>"
  using af_letter_subformulas\<^sub>\<nu>
  by (induction w arbitrary: \<phi> rule: rev_induct) (simp, fastforce)

subsection \<open>Stability and the after function\<close>

lemma \<G>\<F>_af:
  "\<G>\<F> (af \<phi> (prefix i w)) (suffix i w) = \<G>\<F> \<phi> (suffix i w)"
  unfolding \<G>\<F>_semantics' af_subformulas\<^sub>\<mu> by blast

lemma \<F>_af:
  "\<F> (af \<phi> (prefix i w)) (suffix i w) = \<F> \<phi> (suffix i w)"
  unfolding \<F>_semantics' af_subformulas\<^sub>\<mu> by blast

lemma \<F>\<G>_af:
  "\<F>\<G> (af \<phi> (prefix i w)) (suffix i w) = \<F>\<G> \<phi> (suffix i w)"
  unfolding \<F>\<G>_semantics' af_subformulas\<^sub>\<nu> by blast

lemma \<G>_af:
  "\<G> (af \<phi> (prefix i w)) (suffix i w) = \<G> \<phi> (suffix i w)"
  unfolding \<G>_semantics' af_subformulas\<^sub>\<nu> by blast

subsection \<open>Congruence\<close>

lemma af_letter_lang_congruent:
  "\<phi> \<sim>\<^sub>L \<psi> \<Longrightarrow> af_letter \<phi> \<nu> \<sim>\<^sub>L af_letter \<psi> \<nu>"
  unfolding ltl_lang_equiv_def
  using af_letter_build by blast

lemma af_lang_congruent:
  "\<phi> \<sim>\<^sub>L \<psi> \<Longrightarrow> af \<phi> w \<sim>\<^sub>L af \<psi> w"
  unfolding ltl_lang_equiv_def using af_ltl_continuation
  by (induction \<phi>) blast+

lemma af_letter_subst:
  "af_letter \<phi> \<nu> = subst \<phi> (\<lambda>\<psi>. Some (af_letter \<psi> \<nu>))"
  by (induction \<phi>) auto

lemma af_letter_prop_congruent:
  "\<phi> \<longrightarrow>\<^sub>P \<psi> \<Longrightarrow> af_letter \<phi> \<nu> \<longrightarrow>\<^sub>P af_letter \<psi> \<nu>"
  "\<phi> \<sim>\<^sub>P \<psi> \<Longrightarrow> af_letter \<phi> \<nu> \<sim>\<^sub>P af_letter \<psi> \<nu>"
  by (metis af_letter_subst subst_respects_ltl_prop_entailment)+

lemma af_prop_congruent:
  "\<phi> \<longrightarrow>\<^sub>P \<psi> \<Longrightarrow> af \<phi> w \<longrightarrow>\<^sub>P af \<psi> w"
  "\<phi> \<sim>\<^sub>P \<psi> \<Longrightarrow> af \<phi> w \<sim>\<^sub>P af \<psi> w"
  by (induction w arbitrary: \<phi> \<psi>) (insert af_letter_prop_congruent, fastforce+)

lemma af_letter_const_congruent:
  "\<phi> \<sim>\<^sub>C \<psi> \<Longrightarrow> af_letter \<phi> \<nu> \<sim>\<^sub>C af_letter \<psi> \<nu>"
  by (metis af_letter_subst subst_respects_ltl_const_entailment)

lemma af_const_congruent:
  "\<phi> \<sim>\<^sub>C \<psi> \<Longrightarrow> af \<phi> w \<sim>\<^sub>C af \<psi> w"
  by (induction w arbitrary: \<phi> \<psi>) (insert af_letter_const_congruent, fastforce+)

lemma af_letter_one_step_back:
  "{x. \<A> \<Turnstile>\<^sub>P af_letter x \<sigma>} \<Turnstile>\<^sub>P \<phi> \<longleftrightarrow> \<A> \<Turnstile>\<^sub>P af_letter \<phi> \<sigma>"
  by (induction \<phi>) simp_all

subsection \<open>Implications\<close>

lemma af_F_prefix_prop:
  "af (F\<^sub>n \<phi>) w \<longrightarrow>\<^sub>P af (F\<^sub>n \<phi>) (w' @ w)"
  by (induction w') (simp add: ltl_prop_implies_def af_decompose(1,2))+

lemma af_G_prefix_prop:
  "af (G\<^sub>n \<phi>) (w' @ w) \<longrightarrow>\<^sub>P af (G\<^sub>n \<phi>) w"
  by (induction w') (simp add: ltl_prop_implies_def af_decompose(1,2))+

lemma af_F_prefix_lang:
  "w \<Turnstile>\<^sub>n af (F\<^sub>n \<phi>) ys \<Longrightarrow> w \<Turnstile>\<^sub>n af (F\<^sub>n \<phi>) (xs @ ys)"
  using af_F_prefix_prop ltl_prop_implication_implies_ltl_implication by blast

lemma af_G_prefix_lang:
  "w \<Turnstile>\<^sub>n af (G\<^sub>n \<phi>) (xs @ ys) \<Longrightarrow> w \<Turnstile>\<^sub>n af (G\<^sub>n \<phi>) ys"
  using af_G_prefix_prop ltl_prop_implication_implies_ltl_implication by blast

lemma af_F_prefix_const_equiv_true:
  "af (F\<^sub>n \<phi>) w \<sim>\<^sub>C true\<^sub>n \<Longrightarrow> af (F\<^sub>n \<phi>) (w' @ w) \<sim>\<^sub>C true\<^sub>n"
  using af_F_prefix_prop ltl_const_equiv_implies_prop_equiv(1) ltl_prop_equiv_true_implies_true by blast

lemma af_G_prefix_const_equiv_false:
  "af (G\<^sub>n \<phi>) w \<sim>\<^sub>C false\<^sub>n \<Longrightarrow> af (G\<^sub>n \<phi>) (w' @ w) \<sim>\<^sub>C false\<^sub>n"
  using af_G_prefix_prop ltl_const_equiv_implies_prop_equiv(2) ltl_prop_equiv_false_implied_by_false by blast

lemma af_F_prefix_lang_equiv_true:
  "af (F\<^sub>n \<phi>) w \<sim>\<^sub>L true\<^sub>n \<Longrightarrow> af (F\<^sub>n \<phi>) (w' @ w) \<sim>\<^sub>L true\<^sub>n"
  unfolding ltl_lang_equiv_def
  using af_F_prefix_lang by fastforce

lemma af_G_prefix_lang_equiv_false:
  "af (G\<^sub>n \<phi>) w \<sim>\<^sub>L false\<^sub>n \<Longrightarrow> af (G\<^sub>n \<phi>) (w' @ w) \<sim>\<^sub>L false\<^sub>n"
  unfolding ltl_lang_equiv_def
  using af_G_prefix_lang by fastforce

locale af_congruent = ltl_equivalence +
  assumes
    af_letter_congruent: "\<phi> \<sim> \<psi> \<Longrightarrow> af_letter \<phi> \<nu> \<sim> af_letter \<psi> \<nu>"
begin

lemma af_congruentness:
  "\<phi> \<sim> \<psi> \<Longrightarrow> af \<phi> xs \<sim> af \<psi> xs"
  by (induction xs arbitrary: \<phi> \<psi>) (insert af_letter_congruent, fastforce+)

lemma af_append_congruent:
  "af \<phi> w \<sim> af \<psi> w \<Longrightarrow> af \<phi> (w @ w') \<sim> af \<psi> (w @ w')"
  by (simp add: af_congruentness)

lemma af_append_true:
  "af \<phi> w \<sim> true\<^sub>n \<Longrightarrow> af \<phi> (w @ w') \<sim> true\<^sub>n"
  using af_congruentness by fastforce

lemma af_append_false:
  "af \<phi> w \<sim> false\<^sub>n \<Longrightarrow> af \<phi> (w @ w') \<sim> false\<^sub>n"
  using af_congruentness by fastforce

lemma prefix_append_subsequence:
  "i \<le> j \<Longrightarrow> (prefix i w) @ (w [i \<rightarrow> j]) = prefix j w"
  by (metis le_add_diff_inverse subsequence_append)

lemma af_prefix_congruent:
  "i \<le> j \<Longrightarrow> af \<phi> (prefix i w) \<sim> af \<psi> (prefix i w) \<Longrightarrow> af \<phi> (prefix j w) \<sim> af \<psi> (prefix j w)"
  by (metis af_congruentness foldl_append prefix_append_subsequence)+

lemma af_prefix_true:
  "i \<le> j \<Longrightarrow> af \<phi> (prefix i w) \<sim> true\<^sub>n \<Longrightarrow> af \<phi> (prefix j w) \<sim> true\<^sub>n"
  by (metis af_append_true prefix_append_subsequence)

lemma af_prefix_false:
  "i \<le> j \<Longrightarrow> af \<phi> (prefix i w) \<sim> false\<^sub>n \<Longrightarrow> af \<phi> (prefix j w) \<sim> false\<^sub>n"
  by (metis af_append_false prefix_append_subsequence)

end

interpretation lang_af_congruent: af_congruent "(\<sim>\<^sub>L)"
  by unfold_locales (rule af_letter_lang_congruent)

interpretation prop_af_congruent: af_congruent "(\<sim>\<^sub>P)"
  by unfold_locales (rule af_letter_prop_congruent)

interpretation const_af_congruent: af_congruent "(\<sim>\<^sub>C)"
  by unfold_locales (rule af_letter_const_congruent)

subsection \<open>After in @{term \<mu>LTL} and @{term \<nu>LTL}\<close>

lemma valid_prefix_implies_ltl:
  "af \<phi> (prefix i w) \<sim>\<^sub>L true\<^sub>n \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi>"
proof -
  assume "af \<phi> (prefix i w) \<sim>\<^sub>L true\<^sub>n"

  then have "suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)"
    unfolding ltl_lang_equiv_def using semantics_ltln.simps(1) by blast

  then show "w \<Turnstile>\<^sub>n \<phi>"
    using af_ltl_continuation by force
qed

lemma ltl_implies_satisfiable_prefix:
  "w \<Turnstile>\<^sub>n \<phi> \<Longrightarrow> \<not> (af \<phi> (prefix i w) \<sim>\<^sub>L false\<^sub>n)"
proof -
  assume "w \<Turnstile>\<^sub>n \<phi>"

  then have "suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)"
    using af_ltl_continuation by fastforce

  then show "\<not> (af \<phi> (prefix i w) \<sim>\<^sub>L false\<^sub>n)"
    unfolding ltl_lang_equiv_def using semantics_ltln.simps(2) by blast
qed

lemma \<mu>LTL_implies_valid_prefix:
  "\<phi> \<in> \<mu>LTL \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi> \<Longrightarrow> \<exists>i. af \<phi> (prefix i w) \<sim>\<^sub>C true\<^sub>n"
proof (induction \<phi> arbitrary: w)
  case True_ltln
  then show ?case
    using ltl_const_equiv_equivp equivp_reflp by fastforce
next
  case (Prop_ltln x)
  then show ?case
    by (metis af_letter.simps(3) foldl_Cons foldl_Nil ltl_const_equiv_equivp equivp_reflp semantics_ltln.simps(3) subsequence_singleton)
next
  case (Nprop_ltln x)
  then show ?case
    by (metis af_letter.simps(4) foldl_Cons foldl_Nil ltl_const_equiv_equivp equivp_reflp semantics_ltln.simps(4) subsequence_singleton)
next
  case (And_ltln \<phi>1 \<phi>2)

  then obtain i1 i2 where "af \<phi>1 (prefix i1 w) \<sim>\<^sub>C true\<^sub>n" and "af \<phi>2 (prefix i2 w) \<sim>\<^sub>C true\<^sub>n"
    by fastforce

  then have "af \<phi>1 (prefix (i1 + i2) w) \<sim>\<^sub>C true\<^sub>n" and "af \<phi>2 (prefix (i2 + i1) w) \<sim>\<^sub>C true\<^sub>n"
    using const_af_congruent.af_prefix_true le_add1 by blast+

  then have "af (\<phi>1 and\<^sub>n \<phi>2) (prefix (i1 + i2) w) \<sim>\<^sub>C true\<^sub>n"
    unfolding af_decompose by (simp add: add.commute)

  then show ?case
    by blast
next
  case (Or_ltln \<phi>1 \<phi>2)

  then obtain i where "af \<phi>1 (prefix i w) \<sim>\<^sub>C true\<^sub>n \<or> af \<phi>2 (prefix i w) \<sim>\<^sub>C true\<^sub>n"
    by auto

  then show ?case
    unfolding af_decompose by auto
next
  case (Next_ltln \<phi>)

  then obtain i where "af \<phi> (prefix i (suffix 1 w)) \<sim>\<^sub>C true\<^sub>n"
    by fastforce

  then show ?case
    by (metis (no_types, lifting) One_nat_def add.right_neutral af_simps(3) foldl_Nil foldl_append subsequence_append subsequence_shift subsequence_singleton)
next
  case (Until_ltln \<phi>1 \<phi>2)

  then obtain k where "suffix k w \<Turnstile>\<^sub>n \<phi>2" and "\<forall>j<k. suffix j w \<Turnstile>\<^sub>n \<phi>1"
    by fastforce

  then show ?case
  proof (induction k arbitrary: w)
    case 0

    then obtain i where "af \<phi>2 (prefix i w) \<sim>\<^sub>C true\<^sub>n"
      using Until_ltln by fastforce

    then have "af \<phi>2 (prefix (Suc i) w) \<sim>\<^sub>C true\<^sub>n"
      using const_af_congruent.af_prefix_true le_SucI by blast

    then have "af (\<phi>1 U\<^sub>n \<phi>2) (prefix (Suc i) w) \<sim>\<^sub>C true\<^sub>n"
      unfolding af_subsequence_U by simp

    then show ?case
      by blast
  next
    case (Suc k)

    then have "suffix k (suffix 1 w) \<Turnstile>\<^sub>n \<phi>2" and "\<forall>j<k. suffix j (suffix 1 w) \<Turnstile>\<^sub>n \<phi>1"
      by (simp add: Suc.prems)+

    then obtain i where i_def: "af (\<phi>1 U\<^sub>n \<phi>2) (prefix i (suffix 1 w)) \<sim>\<^sub>C true\<^sub>n"
      using Suc.IH by blast

    obtain j where "af \<phi>1 (prefix j w) \<sim>\<^sub>C true\<^sub>n"
      using Until_ltln Suc by fastforce

    then have "af \<phi>1 (prefix (Suc (j + i)) w) \<sim>\<^sub>C true\<^sub>n"
      using const_af_congruent.af_prefix_true le_SucI le_add1 by blast

    moreover

    from i_def have "af (\<phi>1 U\<^sub>n \<phi>2) (w [1 \<rightarrow> Suc (j + i)]) \<sim>\<^sub>C true\<^sub>n"
      by (metis One_nat_def const_af_congruent.af_prefix_true le_add2 plus_1_eq_Suc subsequence_shift)

    ultimately

    have "af (\<phi>1 U\<^sub>n \<phi>2) (prefix (Suc (j + i)) w) \<sim>\<^sub>C true\<^sub>n"
      unfolding af_subsequence_U by simp

    then show ?case
      by blast
  qed
next
  case (StrongRelease_ltln \<phi>1 \<phi>2)

  then obtain k where "suffix k w \<Turnstile>\<^sub>n \<phi>1" and "\<forall>j\<le>k. suffix j w \<Turnstile>\<^sub>n \<phi>2"
    by fastforce

  then show ?case
  proof (induction k arbitrary: w)
    case 0

    then obtain i1 i2 where "af \<phi>1 (prefix i1 w) \<sim>\<^sub>C true\<^sub>n" and "af \<phi>2 (prefix i2 w) \<sim>\<^sub>C true\<^sub>n"
      using StrongRelease_ltln by fastforce

    then have "af \<phi>1 (prefix (Suc (i1 + i2)) w) \<sim>\<^sub>C true\<^sub>n" and "af \<phi>2 (prefix (Suc (i2 + i1)) w) \<sim>\<^sub>C true\<^sub>n"
      using const_af_congruent.af_prefix_true le_SucI le_add1 by blast+

    then have "af (\<phi>1 M\<^sub>n \<phi>2) (prefix (Suc (i1 + i2)) w) \<sim>\<^sub>C true\<^sub>n"
      unfolding af_subsequence_M by (simp add: add.commute)

    then show ?case
      by blast
  next
    case (Suc k)

    then have "suffix k (suffix 1 w) \<Turnstile>\<^sub>n \<phi>1" and "\<forall>j\<le>k. suffix j (suffix 1 w) \<Turnstile>\<^sub>n \<phi>2"
      by (simp add: Suc.prems)+

    then obtain i where i_def: "af (\<phi>1 M\<^sub>n \<phi>2) (prefix i (suffix 1 w)) \<sim>\<^sub>C true\<^sub>n"
      using Suc.IH by blast

    obtain j where "af \<phi>2 (prefix j w) \<sim>\<^sub>C true\<^sub>n"
      using StrongRelease_ltln Suc by fastforce

    then have "af \<phi>2 (prefix (Suc (j + i)) w) \<sim>\<^sub>C true\<^sub>n"
      using const_af_congruent.af_prefix_true le_SucI le_add1 by blast

    moreover

    from i_def have "af (\<phi>1 M\<^sub>n \<phi>2) (w [1 \<rightarrow> Suc (j + i)]) \<sim>\<^sub>C true\<^sub>n"
      by (metis One_nat_def const_af_congruent.af_prefix_true le_add2 plus_1_eq_Suc subsequence_shift)

    ultimately

    have "af (\<phi>1 M\<^sub>n \<phi>2) (prefix (Suc (j + i)) w) \<sim>\<^sub>C true\<^sub>n"
      unfolding af_subsequence_M by simp

    then show ?case
      by blast
  qed
qed force+

lemma satisfiable_prefix_implies_\<nu>LTL:
  "\<phi> \<in> \<nu>LTL \<Longrightarrow> \<nexists>i. af \<phi> (prefix i w) \<sim>\<^sub>C false\<^sub>n \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi>"
proof (erule contrapos_np, induction \<phi> arbitrary: w)
  case False_ltln
  then show ?case
    using ltl_const_equiv_equivp equivp_reflp by fastforce
next
  case (Prop_ltln x)
  then show ?case
    by (metis af_letter.simps(3) foldl_Cons foldl_Nil ltl_const_equiv_equivp equivp_reflp semantics_ltln.simps(3) subsequence_singleton)
next
  case (Nprop_ltln x)
  then show ?case
    by (metis af_letter.simps(4) foldl_Cons foldl_Nil ltl_const_equiv_equivp equivp_reflp semantics_ltln.simps(4) subsequence_singleton)
next
  case (And_ltln \<phi>1 \<phi>2)

  then obtain i where "af \<phi>1 (prefix i w) \<sim>\<^sub>C false\<^sub>n \<or> af \<phi>2 (prefix i w) \<sim>\<^sub>C false\<^sub>n"
    by auto

  then show ?case
    unfolding af_decompose by auto
next
  case (Or_ltln \<phi>1 \<phi>2)

  then obtain i1 i2 where "af \<phi>1 (prefix i1 w) \<sim>\<^sub>C false\<^sub>n" and "af \<phi>2 (prefix i2 w) \<sim>\<^sub>C false\<^sub>n"
    by fastforce

  then have "af \<phi>1 (prefix (i1 + i2) w) \<sim>\<^sub>C false\<^sub>n" and "af \<phi>2 (prefix (i2 + i1) w) \<sim>\<^sub>C false\<^sub>n"
    using const_af_congruent.af_prefix_false le_add1 by blast+

  then have "af (\<phi>1 or\<^sub>n \<phi>2) (prefix (i1 + i2) w) \<sim>\<^sub>C false\<^sub>n"
    unfolding af_decompose by (simp add: add.commute)

  then show ?case
    by blast
next
  case (Next_ltln \<phi>)

  then obtain i where "af \<phi> (prefix i (suffix 1 w)) \<sim>\<^sub>C false\<^sub>n"
    by fastforce

  then show ?case
    by (metis (no_types, lifting) One_nat_def add.right_neutral af_simps(3) foldl_Nil foldl_append subsequence_append subsequence_shift subsequence_singleton)
next
  case (Release_ltln \<phi>1 \<phi>2)

  then obtain k where "\<not> suffix k w \<Turnstile>\<^sub>n \<phi>2" and "\<forall>j<k. \<not> suffix j w \<Turnstile>\<^sub>n \<phi>1"
    by fastforce

  then show ?case
  proof (induction k arbitrary: w)
    case 0

    then obtain i where "af \<phi>2 (prefix i w) \<sim>\<^sub>C false\<^sub>n"
      using Release_ltln by fastforce

    then have "af \<phi>2 (prefix (Suc i) w) \<sim>\<^sub>C false\<^sub>n"
      using const_af_congruent.af_prefix_false le_SucI by blast

    then have "af (\<phi>1 R\<^sub>n \<phi>2) (prefix (Suc i) w) \<sim>\<^sub>C false\<^sub>n"
      unfolding af_subsequence_R by simp

    then show ?case
      by blast
  next
    case (Suc k)

    then have "\<not> suffix k (suffix 1 w) \<Turnstile>\<^sub>n \<phi>2" and "\<forall>j<k. \<not> suffix j (suffix 1 w) \<Turnstile>\<^sub>n \<phi>1"
      by (simp add: Suc.prems)+

    then obtain i where i_def: "af (\<phi>1 R\<^sub>n \<phi>2) (prefix i (suffix 1 w)) \<sim>\<^sub>C false\<^sub>n"
      using Suc.IH by blast

    obtain j where "af \<phi>1 (prefix j w) \<sim>\<^sub>C false\<^sub>n"
      using Release_ltln Suc by fastforce

    then have "af \<phi>1 (prefix (Suc (j + i)) w) \<sim>\<^sub>C false\<^sub>n"
      using const_af_congruent.af_prefix_false le_SucI le_add1 by blast

    moreover

    from i_def have "af (\<phi>1 R\<^sub>n \<phi>2) (w [1 \<rightarrow> Suc (j + i)]) \<sim>\<^sub>C false\<^sub>n"
      by (metis One_nat_def const_af_congruent.af_prefix_false le_add2 plus_1_eq_Suc subsequence_shift)

    ultimately

    have "af (\<phi>1 R\<^sub>n \<phi>2) (prefix (Suc (j + i)) w) \<sim>\<^sub>C false\<^sub>n"
      unfolding af_subsequence_R by auto

    then show ?case
      by blast
  qed
next
  case (WeakUntil_ltln \<phi>1 \<phi>2)

  then obtain k where "\<not> suffix k w \<Turnstile>\<^sub>n \<phi>1" and "\<forall>j\<le>k. \<not> suffix j w \<Turnstile>\<^sub>n \<phi>2"
    by fastforce

  then show ?case
  proof (induction k arbitrary: w)
    case 0

    then obtain i1 i2 where "af \<phi>1 (prefix i1 w) \<sim>\<^sub>C false\<^sub>n" and "af \<phi>2 (prefix i2 w) \<sim>\<^sub>C false\<^sub>n"
      using WeakUntil_ltln by fastforce

    then have "af \<phi>1 (prefix (Suc (i1 + i2)) w) \<sim>\<^sub>C false\<^sub>n" and "af \<phi>2 (prefix (Suc (i2 + i1)) w) \<sim>\<^sub>C false\<^sub>n"
      using const_af_congruent.af_prefix_false le_SucI le_add1 by blast+

    then have "af (\<phi>1 W\<^sub>n \<phi>2) (prefix (Suc (i1 + i2)) w) \<sim>\<^sub>C false\<^sub>n"
      unfolding af_subsequence_W by (simp add: add.commute)

    then show ?case
      by blast
  next
    case (Suc k)

    then have "\<not> suffix k (suffix 1 w) \<Turnstile>\<^sub>n \<phi>1" and "\<forall>j\<le>k. \<not> suffix j (suffix 1 w) \<Turnstile>\<^sub>n \<phi>2"
      by (simp add: Suc.prems)+

    then obtain i where i_def: "af (\<phi>1 W\<^sub>n \<phi>2) (prefix i (suffix 1 w)) \<sim>\<^sub>C false\<^sub>n"
      using Suc.IH by blast

    obtain j where "af \<phi>2 (prefix j w) \<sim>\<^sub>C false\<^sub>n"
      using WeakUntil_ltln Suc by fastforce

    then have "af \<phi>2 (prefix (Suc (j + i)) w) \<sim>\<^sub>C false\<^sub>n"
      using const_af_congruent.af_prefix_false le_SucI le_add1 by blast

    moreover

    from i_def have "af (\<phi>1 W\<^sub>n \<phi>2) (w [1 \<rightarrow> Suc (j + i)]) \<sim>\<^sub>C false\<^sub>n"
      by (metis One_nat_def const_af_congruent.af_prefix_false le_add2 plus_1_eq_Suc subsequence_shift)

    ultimately

    have "af (\<phi>1 W\<^sub>n \<phi>2) (prefix (Suc (j + i)) w) \<sim>\<^sub>C false\<^sub>n"
      unfolding af_subsequence_W by simp

    then show ?case
      by blast
  qed
qed force+

context ltl_equivalence
begin

lemma valid_prefix_implies_ltl:
  "af \<phi> (prefix i w) \<sim> true\<^sub>n \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi>"
  using valid_prefix_implies_ltl eq_implies_lang by blast

lemma ltl_implies_satisfiable_prefix:
  "w \<Turnstile>\<^sub>n \<phi> \<Longrightarrow> \<not> (af \<phi> (prefix i w) \<sim> false\<^sub>n)"
  using ltl_implies_satisfiable_prefix eq_implies_lang by blast

lemma \<mu>LTL_implies_valid_prefix:
  "\<phi> \<in> \<mu>LTL \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi> \<Longrightarrow> \<exists>i. af \<phi> (prefix i w) \<sim> true\<^sub>n"
  using \<mu>LTL_implies_valid_prefix const_implies_eq by blast

lemma satisfiable_prefix_implies_\<nu>LTL:
  "\<phi> \<in> \<nu>LTL \<Longrightarrow> \<nexists>i. af \<phi> (prefix i w) \<sim> false\<^sub>n \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi>"
  using satisfiable_prefix_implies_\<nu>LTL const_implies_eq by blast

lemma af_\<mu>LTL:
  "\<phi> \<in> \<mu>LTL \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow> (\<exists>i. af \<phi> (prefix i w) \<sim> true\<^sub>n)"
  using valid_prefix_implies_ltl \<mu>LTL_implies_valid_prefix by blast

lemma af_\<nu>LTL:
  "\<phi> \<in> \<nu>LTL \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow> (\<forall>i. \<not> (af \<phi> (prefix i w) \<sim> false\<^sub>n))"
  using ltl_implies_satisfiable_prefix satisfiable_prefix_implies_\<nu>LTL by blast

lemma af_\<mu>LTL_GF:
  "\<phi> \<in> \<mu>LTL \<Longrightarrow> w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<phi>) \<longleftrightarrow> (\<forall>i. \<exists>j. af (F\<^sub>n \<phi>) (w[i \<rightarrow> j]) \<sim> true\<^sub>n)"
proof -
  assume "\<phi> \<in> \<mu>LTL"

  then have "F\<^sub>n \<phi> \<in> \<mu>LTL"
    by simp

  have "w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<phi>) \<longleftrightarrow> (\<forall>i. suffix i w \<Turnstile>\<^sub>n F\<^sub>n \<phi>)"
    by simp
  also have "\<dots> \<longleftrightarrow> (\<forall>i. \<exists>j. af (F\<^sub>n \<phi>) (prefix j (suffix i w)) \<sim> true\<^sub>n)"
    using af_\<mu>LTL[OF `F\<^sub>n \<phi> \<in> \<mu>LTL`] by blast
  also have "\<dots> \<longleftrightarrow> (\<forall>i. \<exists>j. af (F\<^sub>n \<phi>) (prefix (j - i) (suffix i w)) \<sim> true\<^sub>n)"
    by (metis diff_add_inverse)
  also have "\<dots> \<longleftrightarrow> (\<forall>i. \<exists>j. af (F\<^sub>n \<phi>) (w[i \<rightarrow> j]) \<sim> true\<^sub>n)"
    unfolding subsequence_prefix_suffix ..
  finally show ?thesis
    by blast
qed

lemma af_\<nu>LTL_FG:
  "\<phi> \<in> \<nu>LTL \<Longrightarrow> w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<phi>) \<longleftrightarrow> (\<exists>i. \<forall>j. \<not> (af (G\<^sub>n \<phi>) (w[i \<rightarrow> j]) \<sim> false\<^sub>n))"
proof -
  assume "\<phi> \<in> \<nu>LTL"

  then have "G\<^sub>n \<phi> \<in> \<nu>LTL"
    by simp

  have "w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<phi>) \<longleftrightarrow> (\<exists>i. suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<phi>)"
    by force
  also have "\<dots> \<longleftrightarrow> (\<exists>i. \<forall>j. \<not> (af (G\<^sub>n \<phi>) (prefix j (suffix i w)) \<sim> false\<^sub>n))"
    using af_\<nu>LTL[OF `G\<^sub>n \<phi> \<in> \<nu>LTL`] by blast
  also have "\<dots> \<longleftrightarrow> (\<exists>i. \<forall>j. \<not> (af (G\<^sub>n \<phi>) (prefix (j - i) (suffix i w)) \<sim> false\<^sub>n))"
    by (metis diff_add_inverse)
  also have "\<dots> \<longleftrightarrow> (\<exists>i. \<forall>j. \<not> (af (G\<^sub>n \<phi>) (w[i \<rightarrow> j]) \<sim> false\<^sub>n))"
    unfolding subsequence_prefix_suffix ..
  finally show ?thesis
    by blast
qed

end

text \<open>Bring Propositional Equivalence into scope\<close>

interpretation af_congruent "(\<sim>\<^sub>P)"
  by unfold_locales (rule af_letter_prop_congruent)

end


section {* \isaheader{Simple DFS Algorithm} *}
theory Simple_DFS
imports
  "../../Refine_Dflt"
begin

text {*
  This example presents the usage of the recursion combinator
  @{text "RECT"}. The usage of the partial correct version
  @{text "REC"} is similar.

  We define a simple DFS-algorithm, prove a simple correctness
  property, and do data refinement to an efficient implementation.
*}

subsection {* Definition *}
(* TODO: Warning, this is not exactly DFS, as V is not updated in FOREACH.
  Replace by more accurate example from ICFContainers paper draft! *)
text {* Recursive DFS-Algorithm.
  @{text "E"} is the edge relation of the graph, @{text "vd"} the node to
  search for, and @{text "v0"} the start node.
  Already explored nodes are
  stored in @{text "V"}.*}
definition dfs :: "('a \<Rightarrow>'a set) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool nres"
  where
  "dfs succ vd v0 \<equiv> REC\<^sub>T (\<lambda>D (V,v).
    if v=vd then RETURN True
    else if v\<in>V then RETURN False
    else do {
      let V=insert v V;
      FOREACH\<^sub>C (succ v) (op = False) (\<lambda>v' _. D (V,v')) False }
  ) ({},v0)"

subsection {* Correctness *}

text {* As simple correctness property, we show:
  If the algorithm returns true, then @{text "vd"} is reachable from
  @{text "v0"}.
*}
lemma dfs_sound:
  fixes succ
  defines "E \<equiv> {(v,v'). v'\<in>succ v}"
  assumes F: "finite {v. (v0,v)\<in>E\<^sup>*}"
  shows "dfs succ vd v0 \<le> SPEC (\<lambda>r. r \<longrightarrow> (v0,vd)\<in>E\<^sup>*)"
proof -
  have S: "\<And>v. succ v = E``{v}"
    by (auto simp: E_def)

  from F show ?thesis
    unfolding dfs_def S
    apply (refine_rcg refine_vcg impI
      RECT_rule[where
        pre="\<lambda>(V,v). (v0,v)\<in>E\<^sup>* \<and> V\<subseteq>{v. (v0,v)\<in>E\<^sup>*}" and
        V="finite_psupset ({v. (v0,v)\<in>E\<^sup>*}) <*lex*> {}"]
      FOREACHc_rule[where I="\<lambda>_ r. r \<longrightarrow> (v0, vd) \<in> E\<^sup>*"]
    )

    apply (auto intro: finite_subset[of _ "{v'. (v0,v')\<in>E\<^sup>*}"])
    apply rprems
    apply (auto simp: finite_psupset_def)
    done
qed

subsection {* Data Refinement and Determinization *}
text {*
  Next, we use automatic data refinement and transfer to generate an
  executable algorithm. The edges function
  is refined to a successor function returning a list-set.
*}
schematic_goal dfs_impl_refine_aux:
  fixes succi and succ :: "nat \<Rightarrow> nat set" and vd v0 :: nat
  assumes [autoref_rules]: "(succi,succ)\<in>Id\<rightarrow>\<langle>Id\<rangle>list_set_rel"
  notes [autoref_rules] = IdI[of v0] IdI[of vd]
  shows "(?f::?'c, dfs succ vd v0)\<in>?R"
  unfolding dfs_def[abs_def]
  apply (autoref_monadic)
  done

text {* We can configure our tool to use different implementations.
  Here, we use lists for sets of natural numbers. *}
schematic_goal dfs_impl_refine_aux2:
  fixes succi and succ :: "nat \<Rightarrow> nat set" and vd v0 :: nat
  assumes [autoref_rules]: "(succi,succ)\<in>Id\<rightarrow>\<langle>Id\<rangle>dflt_rs_rel"
  notes [autoref_rules] = IdI[of v0] IdI[of vd]
  notes [autoref_tyrel] = ty_REL[where 'a="nat set" and R="\<langle>Id\<rangle>list_set_rel"]
  shows "(?f::?'c, dfs succ vd v0)\<in>?R"
  unfolding dfs_def[abs_def]
  apply (autoref_monadic)
  done

text {* We can also leave the type of the nodes and its implementation
  unspecified. However, the implementation relation must be single-valued,
  and we need a comparison operator on nodes *}

(*schematic_lemma
  fixes vs vd :: 'a and Rv :: "('c\<times>'a) set"
  assumes [autoref_rules]: "(vsi,vs)\<in>Rv" "(vdi,vd)\<in>Rv"
  shows "(?f::?'c, vs = vd)\<in>?R"
  apply (autoref (keep_goal) phases: id_op rel_inf fix_rel)
*)

schematic_goal dfs_impl_refine_aux3:
  fixes succi and succ :: "'a::linorder \<Rightarrow> 'a set"
    and Rv :: "('ai\<times>'a) set"
  assumes [autoref_rules_raw]: "(cmpk, dflt_cmp op \<le> op <)\<in>(Rv\<rightarrow>Rv\<rightarrow>Id)"
  notes [autoref_tyrel] = ty_REL[where 'a="'a set" and R="\<langle>Rv\<rangle>dflt_rs_rel"]
  assumes P_REF[autoref_rules]:
    "(succi,succ)\<in>Rv\<rightarrow>\<langle>Rv\<rangle>list_set_rel"
    "(vdi,vd::'a)\<in>Rv"
    "(v0i,v0)\<in>Rv"
  shows "(?f::?'c, dfs succ vd v0)\<in>?R"
  unfolding dfs_def[abs_def]
  by autoref_monadic

text {* Next, we extract constants from the refinement lemmas,
  and prepare them for code-generation *}
concrete_definition dfs_impl for succi vd ?v0.0 uses dfs_impl_refine_aux
prepare_code_thms dfs_impl_def
concrete_definition dfs_impl2 for succi vd ?v0.0 uses dfs_impl_refine_aux2
prepare_code_thms dfs_impl2_def
concrete_definition dfs_impl3 for succi vd ?v0.0 uses dfs_impl_refine_aux3
prepare_code_thms dfs_impl3_def

text {* Finally, we export code using the code-generator *}
export_code dfs_impl dfs_impl2 dfs_impl3 in SML
export_code dfs_impl dfs_impl2 dfs_impl3 in OCaml
export_code dfs_impl dfs_impl2 dfs_impl3 in Haskell
export_code dfs_impl dfs_impl2 dfs_impl3 in Scala

text {* Derived correctness lemma for the generated function *}
lemma dfs_impl_correct:
  fixes succi succ
  defines "E \<equiv> {(s, s'). s' \<in> succ s}"
  assumes S: "(succi,succ) \<in> Id \<rightarrow> \<langle>Id\<rangle>list_set_rel"
  assumes F: "finite (E\<^sup>*``{v0})"
  assumes R: "dfs_impl succi vd v0"
  shows "(v0,vd)\<in>E\<^sup>*"
proof -
  note dfs_impl.refine[OF S, of vd v0, THEN nres_relD]
  also
  have F': "finite {v. (v0, v) \<in> {(v, v'). v' \<in> succ v}\<^sup>*}"
    using F
    apply (fo_rule back_subst, assumption)
    by (auto simp: E_def)
  note dfs_sound[OF F']
  finally show ?thesis using R
    by (auto simp: E_def)

qed

end


section \<open>A dedicated value type\<close>

theory Value
imports Term_as_Value
begin

datatype "value" =
  is_Vconstr: Vconstr name "value list" |
  Vabs "sclauses" "(name, value) fmap" |
  Vrecabs "(name, sclauses) fmap" name "(name, value) fmap"

type_synonym vrule = "name \<times> value"

setup \<open>Sign.mandatory_path "quickcheck"\<close>

(* FIXME: make private, prevented by bug in datatype_compat; workaround: mandatory path *)
datatype "value" =
  Vconstr name "value list" |
  Vabs "sclauses" "(name \<times> value) list" |
  Vrecabs "(name \<times> sclauses) list" name "(name \<times> value) list"

primrec "Value" :: "quickcheck.value \<Rightarrow> value" where
"Value (quickcheck.Vconstr s vs) = Vconstr s (map Value vs)" |
"Value (quickcheck.Vabs cs \<Gamma>) = Vabs cs (fmap_of_list (map (map_prod id Value) \<Gamma>))" |
"Value (quickcheck.Vrecabs css name \<Gamma>) = Vrecabs (fmap_of_list css) name (fmap_of_list (map (map_prod id Value) \<Gamma>))"

setup \<open>Sign.parent_path\<close>

quickcheck_generator "value"
  constructors: quickcheck.Value

fun vmatch :: "pat \<Rightarrow> value \<Rightarrow> (name, value) fmap option" where
"vmatch (Patvar name) v = Some (fmap_of_list [(name, v)])" |
"vmatch (Patconstr name ps) (Vconstr name' vs) =
  (if name = name' \<and> length ps = length vs then
    map_option (foldl (++\<^sub>f) fmempty) (those (map2 vmatch ps vs))
  else
    None)" |
"vmatch _ _ = None"

lemmas vmatch_induct = vmatch.induct[case_names var constr]

locale value_pred =
  fixes P :: "(name, value) fmap \<Rightarrow> sclauses \<Rightarrow> bool"
  fixes Q :: "name \<Rightarrow> bool"
  fixes R :: "name fset \<Rightarrow> bool"
begin

primrec pred :: "value \<Rightarrow> bool" where
"pred (Vconstr name vs) \<longleftrightarrow> Q name \<and> list_all id (map pred vs)" |
"pred (Vabs cs \<Gamma>) \<longleftrightarrow> pred_fmap id (fmmap pred \<Gamma>) \<and> P \<Gamma> cs" |
"pred (Vrecabs css name \<Gamma>) \<longleftrightarrow>
    pred_fmap id (fmmap pred \<Gamma>) \<and>
    pred_fmap (P \<Gamma>) css \<and>
    name |\<in>| fmdom css \<and>
    R (fmdom css)"

declare pred.simps[simp del]

lemma pred_alt_def[simp, code]:
  "pred (Vconstr name vs) \<longleftrightarrow> Q name \<and> list_all pred vs"
  "pred (Vabs cs \<Gamma>) \<longleftrightarrow> fmpred (\<lambda>_. pred) \<Gamma> \<and> P \<Gamma> cs"
  "pred (Vrecabs css name \<Gamma>) \<longleftrightarrow> fmpred (\<lambda>_. pred) \<Gamma> \<and> pred_fmap (P \<Gamma>) css \<and> name |\<in>| fmdom css \<and> R (fmdom css)"
by (auto simp: list_all_iff pred.simps)

text \<open>
  For technical reasons, we don't introduce an abbreviation for @{prop \<open>fmpred (\<lambda>_. pred) env\<close>}
  here. This locale is supposed to be interpreted with @{command global_interpretation} (or
  @{command sublocale} and a @{theory_text \<open>defines\<close>} clause. However, this does not affect
  abbreviations: the abbreviation would still refer to the locale constant, not the constant
  introduced by the interpretation.
\<close>

lemma vmatch_env:
  assumes "vmatch pat v = Some env" "pred v"
  shows "fmpred (\<lambda>_. pred) env"
using assms proof (induction pat v arbitrary: env rule: vmatch_induct)
  case (constr name ps name' vs)
  hence
    "map_option (foldl (++\<^sub>f) fmempty) (those (map2 vmatch ps vs)) = Some env"
    "name = name'" "length ps = length vs"
    by (auto split: if_splits)
  then obtain envs where "env = foldl (++\<^sub>f) fmempty envs" "map2 vmatch ps vs = map Some envs"
    by (blast dest: those_someD)

  moreover have "fmpred (\<lambda>_. pred) env" if "env \<in> set envs" for env
    proof -
      from that have "Some env \<in> set (map2 vmatch ps vs)"
        unfolding \<open>map2 _ _ _ = _\<close> by simp
      then obtain p v where "p \<in> set ps" "v \<in> set vs" "vmatch p v = Some env"
        apply (rule map2_elemE)
        by auto
      hence "pred v"
        using constr by (simp add: list_all_iff)
      show ?thesis
        by (rule constr; safe?) fact+
    qed

    ultimately show ?case
      by auto
qed auto

end

primrec value_to_sterm :: "value \<Rightarrow> sterm" where
"value_to_sterm (Vconstr name vs) = name $$ map value_to_sterm vs" |
"value_to_sterm (Vabs cs \<Gamma>) = Sabs (map (\<lambda>(pat, t). (pat, subst t (fmdrop_fset (frees pat) (fmmap value_to_sterm \<Gamma>)))) cs)" |
"value_to_sterm (Vrecabs css name \<Gamma>) =
  Sabs (map (\<lambda>(pat, t). (pat, subst t (fmdrop_fset (frees pat) (fmmap value_to_sterm \<Gamma>)))) (the (fmlookup css name)))"

text \<open>
  This locale establishes a connection between a predicate on @{typ value}s with the corresponding
  predicate on @{typ sterm}s, by means of @{const value_to_sterm}.
\<close>

locale pre_value_sterm_pred = value_pred +
  fixes S
  assumes value_to_sterm: "pred v \<Longrightarrow> S (value_to_sterm v)"
begin

corollary value_to_sterm_env:
  assumes "fmpred (\<lambda>_. pred) \<Gamma>"
  shows "fmpred (\<lambda>_. S) (fmmap value_to_sterm \<Gamma>)"
unfolding fmpred_map proof
  fix name v
  assume "fmlookup \<Gamma> name = Some v"
  with assms have "pred v" by (metis fmpredD)
  thus "S (value_to_sterm v)" by (rule value_to_sterm)
qed

end

locale value_sterm_pred = value_pred + S: simple_syntactic_and S for S +
  assumes const: "\<And>name. Q name \<Longrightarrow> S (const name)"
  assumes abs: "\<And>\<Gamma> cs.
    (\<And>n v. fmlookup \<Gamma> n = Some v \<Longrightarrow> pred v \<Longrightarrow> S (value_to_sterm v)) \<Longrightarrow>
    fmpred (\<lambda>_. pred) \<Gamma> \<Longrightarrow>
    P \<Gamma> cs \<Longrightarrow>
    S (Sabs (map (\<lambda>(pat, t). (pat, subst t (fmmap value_to_sterm (fmdrop_fset (frees pat) \<Gamma>)))) cs))"
begin

sublocale pre_value_sterm_pred
proof
  fix v
  assume "pred v"
  then show "S (value_to_sterm v)"
    proof (induction v)
      case (Vconstr x1 x2)
      show ?case
        apply simp
        unfolding S.list_comb
        apply rule
         apply (rule const)
        using Vconstr by (auto simp: list_all_iff)
    next
      case (Vabs x1 x2)
      show ?case
        apply auto
        apply (rule abs)
        using Vabs
        by (auto intro: fmran'I)
    next
      case (Vrecabs x1 x2 x3)
      show ?case
        apply auto
        apply (rule abs)
        using Vrecabs
        by (auto simp: fmlookup_dom_iff fmpred_iff intro: fmran'I)
    qed
qed

end

global_interpretation vwellformed:
  value_sterm_pred
    "\<lambda>_. wellformed_clauses"
    "\<lambda>_. True"
    "\<lambda>_. True"
    wellformed
  defines vwellformed = vwellformed.pred
proof (standard, goal_cases)
  case (2 \<Gamma> cs)
  hence "cs \<noteq> []"
    by simp

  moreover have "wellformed (subst rhs (fmdrop_fset (frees pat) (fmmap value_to_sterm \<Gamma>)))"
    if "(pat, rhs) \<in> set cs" for pat rhs
    proof -
      show ?thesis
        apply (rule subst_wellformed)
        subgoal using 2 that by (force simp: list_all_iff)
        apply (rule fmpred_drop_fset)
        using 2 by auto
    qed

  moreover have "distinct (map (fst \<circ> (\<lambda>(pat, t). (pat, subst t (fmmap value_to_sterm (fmdrop_fset (frees pat) \<Gamma>))))) cs)"
    apply (subst map_cong[OF refl, where g = fst])
    using 2 by auto

  ultimately show ?case
    using 2 by (auto simp: list_all_iff)
qed (auto simp: const_sterm_def)

abbreviation "wellformed_venv \<equiv> fmpred (\<lambda>_. vwellformed)"

global_interpretation vclosed:
  value_sterm_pred
    "\<lambda>\<Gamma> cs. list_all (\<lambda>(pat, t). closed_except t (fmdom \<Gamma> |\<union>| frees pat)) cs"
    "\<lambda>_. True"
    "\<lambda>_. True"
    closed
  defines vclosed = vclosed.pred
proof (standard, goal_cases)
  case (2 \<Gamma> cs)
  show ?case
    apply (simp add: list_all_iff case_prod_twice Sterm.closed_except_simps)
    apply safe
    apply (subst closed_except_def)
    apply (subst subst_frees)
     apply simp
    subgoal
      apply (rule fmpred_drop_fset)
      apply (rule fmpredI)
      apply (rule 2)
       apply assumption
      using 2 by auto
    subgoal
      using 2 by (auto simp: list_all_iff closed_except_def)
    done
qed simp

abbreviation "closed_venv \<equiv> fmpred (\<lambda>_. vclosed)"

context pre_constants begin

sublocale vwelldefined:
  value_sterm_pred
    "\<lambda>_ cs. list_all (\<lambda>(_, t). welldefined t) cs"
    "\<lambda>name. name |\<in>| C"
    "\<lambda>dom. dom |\<subseteq>| heads"
    welldefined
  defines vwelldefined = vwelldefined.pred
proof (standard, goal_cases)
  case (2 \<Gamma> cs)
  note fset_of_list_map[simp del]

  show ?case
    apply simp
    apply (rule ffUnion_least)
    apply (rule fBallI)
    apply (subst (asm) fset_of_list_elem)
    apply simp
    apply (erule imageE)
    apply (simp add: case_prod_twice)
    subgoal for _ x
      apply (cases x)
      apply simp
      apply (rule subst_consts)
      subgoal
        using 2 by (fastforce simp: list_all_iff)
      subgoal
        apply simp
        apply (rule fmpred_drop_fset)
        unfolding fmpred_map
        apply (rule fmpredI)
        using 2 by auto
      done
    done
qed (simp add: all_consts_def)

lemmas vwelldefined_alt_def = vwelldefined.pred_alt_def

end

declare pre_constants.vwelldefined_alt_def[code]

context constructors begin

sublocale vconstructor_value:
  pre_value_sterm_pred
    "\<lambda>_ _. True"
    "\<lambda>name. name |\<in>| C"
    "\<lambda>_. True"
    is_value
  defines vconstructor_value = vconstructor_value.pred
proof
  fix v
  assume "value_pred.pred (\<lambda>_ _. True) (\<lambda>name. name |\<in>| C) (\<lambda>_. True) v"
  then show "is_value (value_to_sterm v)"
    proof (induction v)
      case (Vconstr name vs)
      hence "list_all is_value (map value_to_sterm vs)"
        by (fastforce simp: list_all_iff value_pred.pred_alt_def)
      show ?case
        unfolding value_to_sterm.simps
        apply (rule is_value.constr)
         apply fact
        using Vconstr by (simp add: value_pred.pred_alt_def)
    qed (auto simp: disjnt_def intro: is_value.intros)
qed

lemmas vconstructor_value_alt_def = vconstructor_value.pred_alt_def

abbreviation "vconstructor_value_env \<equiv> fmpred (\<lambda>_. vconstructor_value)"

definition vconstructor_value_rs :: "vrule list \<Rightarrow> bool" where
"vconstructor_value_rs rs \<longleftrightarrow>
  list_all (\<lambda>(_, rhs). vconstructor_value rhs) rs \<and>
  fdisjnt (fset_of_list (map fst rs)) C"

end

declare constructors.vconstructor_value_alt_def[code]
declare constructors.vconstructor_value_rs_def[code]

context pre_constants begin

sublocale not_shadows_vconsts:
  value_sterm_pred
    "\<lambda>_ cs. list_all (\<lambda>(pat, t). fdisjnt all_consts (frees pat) \<and> \<not> shadows_consts t) cs"
    "\<lambda>_. True"
    "\<lambda>_. True"
    "\<lambda>t. \<not> shadows_consts t"
  defines not_shadows_vconsts = not_shadows_vconsts.pred
proof (standard, goal_cases)
  case (2 \<Gamma> cs)
  show ?case
    apply (simp add: list_all_iff list_ex_iff case_prod_twice)
    apply (rule ballI)
    subgoal for x
      apply (cases x, simp)
      apply (rule conjI)
      subgoal
        using 2 by (force simp: list_all_iff)
      apply (rule subst_shadows)
      subgoal
        using 2 by (force simp: list_all_iff)
      apply simp
      apply (rule fmpred_drop_fset)
      apply (rule fmpredI)
      using 2 by auto
    done
qed (auto simp: const_sterm_def app_sterm_def)

lemmas not_shadows_vconsts_alt_def = not_shadows_vconsts.pred_alt_def

abbreviation "not_shadows_vconsts_env \<equiv> fmpred (\<lambda>_ s. not_shadows_vconsts s)"

end

declare pre_constants.not_shadows_vconsts_alt_def[code]

fun term_to_value :: "sterm \<Rightarrow> value" where
"term_to_value t =
  (case strip_comb t of
    (Sconst name, args) \<Rightarrow> Vconstr name (map term_to_value args)
  | (Sabs cs, []) \<Rightarrow> Vabs cs fmempty)"

lemma (in constructors) term_to_value_to_sterm:
  assumes "is_value t"
  shows "value_to_sterm (term_to_value t) = t"
using assms proof induction
  case (constr vs name)

  have "map (value_to_sterm \<circ> term_to_value) vs = map id vs"
    proof (rule list.map_cong0, unfold comp_apply id_apply)
      fix v
      assume "v \<in> set vs"
      with constr show "value_to_sterm (term_to_value v) = v"
        by (simp add: list_all_iff)
    qed
  thus ?case
    apply (simp add: strip_list_comb_const)
    apply (subst const_sterm_def)
    by simp
qed simp

lemma vmatch_dom:
  assumes "vmatch pat v = Some env"
  shows "fmdom env = patvars pat"
using assms proof (induction pat v arbitrary: env rule: vmatch_induct)
  case (constr name ps name' vs)
  hence
    "map_option (foldl (++\<^sub>f) fmempty) (those (map2 vmatch ps vs)) = Some env"
    "name = name'" "length ps = length vs"
    by (auto split: if_splits)
  then obtain envs where "env = foldl (++\<^sub>f) fmempty envs" "map2 vmatch ps vs = map Some envs"
    by (blast dest: those_someD)

  moreover have "fset_of_list (map fmdom envs) = fset_of_list (map patvars ps)"
    proof safe
      fix names
      assume "names |\<in>| fset_of_list (map fmdom envs)"
      hence "names \<in> set (map fmdom envs)"
        unfolding fset_of_list_elem .
      then obtain env where "env \<in> set envs" "names = fmdom env"
        by auto
      hence "Some env \<in> set (map2 vmatch ps vs)"
        unfolding \<open>map2 _ _ _ = _\<close> by simp
      then obtain p v where "p \<in> set ps" "v \<in> set vs" "vmatch p v = Some env"
        by (auto elim: map2_elemE)
      moreover hence "fmdom env = patvars p"
        using constr by fastforce
      ultimately have "names \<in> set (map patvars ps)"
        unfolding \<open>names = _\<close> by simp
      thus "names |\<in>| fset_of_list (map patvars ps)"
        unfolding fset_of_list_elem .
    next
      fix names
      assume "names |\<in>| fset_of_list (map patvars ps)"
      hence "names \<in> set (map patvars ps)"
        unfolding fset_of_list_elem .
      then obtain p where "p \<in> set ps" "names = patvars p"
        by auto
      then obtain v where "v \<in> set vs" "vmatch p v \<in> set (map2 vmatch ps vs)"
        using \<open>length ps = length vs\<close> by (auto elim!: map2_elemE1)
      then obtain env where "env \<in> set envs" "vmatch p v = Some env"
        unfolding \<open>map2 vmatch ps vs = _\<close> by auto
      moreover hence "fmdom env = patvars p"
        using constr \<open>name = name'\<close> \<open>length ps = length vs\<close> \<open>p \<in> set ps\<close> \<open>v \<in> set vs\<close>
        by fastforce
      ultimately have "names \<in> set (map fmdom envs)"
        unfolding \<open>names = _\<close> by auto
      thus "names |\<in>| fset_of_list (map fmdom envs)"
        unfolding fset_of_list_elem .
    qed

  ultimately show ?case
    by (auto simp: fmdom_foldl_add)
qed auto

fun vfind_match :: "sclauses \<Rightarrow> value \<Rightarrow> ((name, value) fmap \<times> term \<times> sterm) option" where
"vfind_match [] _ = None" |
"vfind_match ((pat, rhs) # cs) t =
  (case vmatch (mk_pat pat) t of
    Some env \<Rightarrow> Some (env, pat, rhs)
  | None \<Rightarrow> vfind_match cs t)"

lemma vfind_match_elem:
  assumes "vfind_match cs t = Some (env, pat, rhs)"
  shows "(pat, rhs) \<in> set cs" "vmatch (mk_pat pat) t = Some env"
using assms
by (induct cs) (auto split: option.splits)

inductive veq_structure :: "value \<Rightarrow> value \<Rightarrow> bool" where
abs_abs: "veq_structure (Vabs _ _) (Vabs _ _)" |
recabs_recabs: "veq_structure (Vrecabs _ _ _) (Vrecabs _ _ _)" |
constr_constr: "list_all2 veq_structure ts us \<Longrightarrow> veq_structure (Vconstr name ts) (Vconstr name us)"

lemma veq_structure_simps[code, simp]:
  "veq_structure (Vabs cs\<^sub>1 \<Gamma>\<^sub>1) (Vabs cs\<^sub>2 \<Gamma>\<^sub>2)"
  "veq_structure (Vrecabs css\<^sub>1 name\<^sub>1 \<Gamma>\<^sub>1) (Vrecabs css\<^sub>2 name\<^sub>2 \<Gamma>\<^sub>2)"
  "veq_structure (Vconstr name\<^sub>1 ts) (Vconstr name\<^sub>2 us) \<longleftrightarrow> name\<^sub>1 = name\<^sub>2 \<and> list_all2 veq_structure ts us"
by (auto intro: veq_structure.intros elim: veq_structure.cases)

lemma veq_structure_refl[simp]: "veq_structure t t"
by (induction t) (auto simp: list.rel_refl_strong)

global_interpretation vno_abs: value_pred "\<lambda>_ _. False" "\<lambda>_. True" "\<lambda>_. False"
  defines vno_abs = vno_abs.pred .

lemma veq_structure_eq_left:
  assumes "veq_structure t u" "vno_abs t"
  shows "t = u"
using assms proof (induction rule: veq_structure.induct)
  case (constr_constr ts us name)
  have "ts = us" if "list_all vno_abs ts"
    using constr_constr.IH that
    by induction auto
  with constr_constr show ?case
    by auto
qed auto

lemma veq_structure_eq_right:
  assumes "veq_structure t u" "vno_abs u"
  shows "t = u"
using assms proof (induction rule: veq_structure.induct)
  case (constr_constr ts us name)
  have "ts = us" if "list_all vno_abs us"
    using constr_constr.IH that
    by induction auto
  with constr_constr show ?case
    by auto
qed auto

fun vmatch' :: "pat \<Rightarrow> value \<Rightarrow> (name, value) fmap option" where
"vmatch' (Patvar name) v = Some (fmap_of_list [(name, v)])" |
"vmatch' (Patconstr name ps) v =
  (case v of
    Vconstr name' vs \<Rightarrow>
      (if name = name' \<and> length ps = length vs then
        map_option (foldl (++\<^sub>f) fmempty) (those (map2 vmatch' ps vs))
      else
        None)
  | _ \<Rightarrow> None)"

lemma vmatch_vmatch'_eq: "vmatch p v = vmatch' p v"
proof (induction rule: vmatch.induct)
  case (2 name ps name' vs)
  then show ?case
    apply auto
    apply (rule map_option_cong[OF _ refl])
    apply (rule arg_cong[where f = those])
    apply (rule map2_cong[OF refl refl])
    apply blast
    done
qed auto

locale value_struct_rel =
  fixes Q :: "value \<Rightarrow> value \<Rightarrow> bool"
  assumes Q_impl_struct: "Q t\<^sub>1 t\<^sub>2 \<Longrightarrow> veq_structure t\<^sub>1 t\<^sub>2"
  assumes Q_def[simp]: "Q (Vconstr name ts) (Vconstr name' us) \<longleftrightarrow> name = name' \<and> list_all2 Q ts us"
begin

lemma eq_left: "Q t u \<Longrightarrow> vno_abs t \<Longrightarrow> t = u"
using Q_impl_struct by (metis veq_structure_eq_left)

lemma eq_right: "Q t u \<Longrightarrow> vno_abs u \<Longrightarrow> t = u"
using Q_impl_struct by (metis veq_structure_eq_right)

context begin

private lemma vmatch'_rel:
  assumes "Q t\<^sub>1 t\<^sub>2"
  shows "rel_option (fmrel Q) (vmatch' p t\<^sub>1) (vmatch' p t\<^sub>2)"
using assms(1) proof (induction p arbitrary: t\<^sub>1 t\<^sub>2)
  case (Patconstr name ps)
  with Q_impl_struct have "veq_structure t\<^sub>1 t\<^sub>2"
    by blast

  thus ?case
    proof (cases rule: veq_structure.cases)
      case (constr_constr ts us name')

      {
        assume "length ps = length ts"

        have "list_all2 (rel_option (fmrel Q)) (map2 vmatch' ps ts) (map2 vmatch' ps us)"
          using \<open>list_all2 veq_structure ts us\<close> Patconstr \<open>length ps = length ts\<close>
          unfolding \<open>t\<^sub>1 = _\<close> \<open>t\<^sub>2 = _\<close>
          proof (induction arbitrary: ps)
            case (Cons t ts u us ps0)
            then obtain p ps where "ps0 = p # ps"
              by (cases ps0) auto

            have "length ts = length us"
              using Cons by (auto dest: list_all2_lengthD)

            hence "Q t u"
              using \<open>Q (Vconstr name' (t # ts)) (Vconstr name' (u # us))\<close>
              by (simp add: list_all_iff)
            hence "rel_option (fmrel Q) (vmatch' p t) (vmatch' p u)"
              using Cons unfolding \<open>ps0 = _\<close> by simp

            moreover have "list_all2 (rel_option (fmrel Q)) (map2 vmatch' ps ts) (map2 vmatch' ps us)"
              apply (rule Cons)
              subgoal
                apply (rule Cons)
                unfolding \<open>ps0 = _\<close> apply simp
                by assumption
              subgoal
                using \<open>Q (Vconstr name' (t # ts)) (Vconstr name' (u # us))\<close> \<open>length ts = length us\<close>
                by (simp add: list_all_iff)
              subgoal
                using \<open>length ps0 = length (t # ts)\<close>
                unfolding \<open>ps0 = _\<close> by simp
              done

            ultimately show ?case
              unfolding \<open>ps0 = _\<close>
              by auto
          qed auto

        hence "rel_option (list_all2 (fmrel Q)) (those (map2 vmatch' ps ts)) (those (map2 vmatch' ps us))"
          by (rule rel_funD[OF those_transfer])

        have
          "rel_option (fmrel Q)
            (map_option (foldl (++\<^sub>f) fmempty) (those (map2 vmatch' ps ts)))
            (map_option (foldl (++\<^sub>f) fmempty) (those (map2 vmatch' ps us)))"
          apply (rule rel_funD[OF rel_funD[OF option.map_transfer]])
           apply transfer_prover
          by fact
      }
      note * = this

      have "length ts = length us"
        using constr_constr by (auto dest: list_all2_lengthD)

      thus ?thesis
        unfolding \<open>t\<^sub>1 = _\<close> \<open>t\<^sub>2 = _\<close>
        apply auto
        apply (rule *)
        by simp
    qed auto
qed auto

lemma vmatch_rel: "Q t\<^sub>1 t\<^sub>2 \<Longrightarrow> rel_option (fmrel Q) (vmatch p t\<^sub>1) (vmatch p t\<^sub>2)"
unfolding vmatch_vmatch'_eq by (rule vmatch'_rel)

lemma vfind_match_rel:
  assumes "list_all2 (rel_prod (=) R) cs\<^sub>1 cs\<^sub>2"
  assumes "Q t\<^sub>1 t\<^sub>2"
  shows "rel_option (rel_prod (fmrel Q) (rel_prod (=) R)) (vfind_match cs\<^sub>1 t\<^sub>1) (vfind_match cs\<^sub>2 t\<^sub>2)"
using assms(1) proof induction
  case (Cons c\<^sub>1 cs\<^sub>1 c\<^sub>2 cs\<^sub>2)
  moreover obtain pat\<^sub>1 rhs\<^sub>1 where "c\<^sub>1 = (pat\<^sub>1, rhs\<^sub>1)" by fastforce
  moreover obtain pat\<^sub>2 rhs\<^sub>2 where "c\<^sub>2 = (pat\<^sub>2, rhs\<^sub>2)" by fastforce

  ultimately have "pat\<^sub>1 = pat\<^sub>2" "R rhs\<^sub>1 rhs\<^sub>2"
    by auto

  have "rel_option (fmrel Q) (vmatch (mk_pat pat\<^sub>1) t\<^sub>1) (vmatch (mk_pat pat\<^sub>1) t\<^sub>2)"
    by (rule vmatch_rel) fact
  thus ?case
    proof cases
      case None
      thus ?thesis
        unfolding \<open>c\<^sub>1 = _\<close> \<open>c\<^sub>2 = _\<close> \<open>pat\<^sub>1 = _\<close>
        using Cons by auto
    next
      case (Some \<Gamma>\<^sub>1 \<Gamma>\<^sub>2)
      thus ?thesis
        unfolding \<open>c\<^sub>1 = _\<close> \<open>c\<^sub>2 = _\<close> \<open>pat\<^sub>1 = _\<close>
        using \<open>R rhs\<^sub>1 rhs\<^sub>2\<close>
        by auto
    qed
qed simp

lemmas vfind_match_rel' =
  vfind_match_rel[
    where R = "(=)" and cs\<^sub>1 = cs and cs\<^sub>2 = cs for cs,
    unfolded prod.rel_eq,
    OF list.rel_refl, OF refl]

end end

hide_fact vmatch_vmatch'_eq
hide_const vmatch'

global_interpretation veq_structure: value_struct_rel veq_structure
by standard auto

abbreviation env_eq where
"env_eq \<equiv> fmrel (\<lambda>v t. t = value_to_sterm v)"

lemma env_eq_eq:
  assumes "env_eq venv senv"
  shows "senv = fmmap value_to_sterm venv"
proof (rule fmap_ext, unfold fmlookup_map)
  fix name
  from assms have "rel_option (\<lambda>v t. t = value_to_sterm v) (fmlookup venv name) (fmlookup senv name)"
    by auto
  thus "fmlookup senv name = map_option value_to_sterm (fmlookup venv name)"
    by cases auto
qed

context constructors begin

context begin

private lemma vmatch_eq0: "rel_option env_eq (vmatch p v) (smatch' p (value_to_sterm v))"
proof (induction p v rule: vmatch_induct)
  case (constr name ps name' vs)

  have
    "rel_option env_eq
      (map_option (foldl (++\<^sub>f) \<Gamma>) (those (map2 vmatch ps vs)))
      (map_option (foldl (++\<^sub>f) \<Gamma>') (those (map2 smatch' ps (map value_to_sterm vs))))"
    if "length ps = length vs" and "name = name'" and "env_eq \<Gamma> \<Gamma>'" for \<Gamma> \<Gamma>'
    using that constr
    proof (induction arbitrary: \<Gamma> \<Gamma>' rule: list_induct2)
      case (Cons p ps v vs)
      hence "rel_option env_eq (vmatch p v) (smatch' p (value_to_sterm v))"
        by auto
      thus ?case
        proof cases
          case (Some \<Gamma>\<^sub>1 \<Gamma>\<^sub>2)
          thus ?thesis
            apply (simp add: option.map_comp comp_def)
            apply (rule Cons)
            using Cons by auto
        qed simp
    qed fastforce

  thus ?case
    apply (auto simp: strip_list_comb_const)
    apply (subst const_sterm_def, simp)+
    done
qed auto

corollary vmatch_eq:
  assumes "linear p" "vconstructor_value v"
  shows "rel_option env_eq (vmatch (mk_pat p) v) (match p (value_to_sterm v))"
using assms
by (metis smatch_smatch'_eq vmatch_eq0 vconstructor_value.value_to_sterm)

end

end

abbreviation match_related where
"match_related \<equiv> (\<lambda>(\<Gamma>\<^sub>1, pat\<^sub>1, rhs\<^sub>1) (\<Gamma>\<^sub>2, pat\<^sub>2, rhs\<^sub>2). rhs\<^sub>1 = rhs\<^sub>2 \<and> pat\<^sub>1 = pat\<^sub>2 \<and> env_eq \<Gamma>\<^sub>1 \<Gamma>\<^sub>2)"

lemma (in constructors) find_match_eq:
  assumes "list_all (linear \<circ> fst) cs" "vconstructor_value v"
  shows "rel_option match_related (vfind_match cs v) (find_match cs (value_to_sterm v))"
using assms proof (induct cs)
  case (Cons c cs)
  then obtain p t where "c = (p, t)" by fastforce
  hence "rel_option env_eq (vmatch (mk_pat p) v) (match p (value_to_sterm v))"
    using Cons by (fastforce intro: vmatch_eq)
  thus ?case
    using Cons unfolding \<open>c = _\<close>
    by cases auto
qed auto

inductive erelated :: "value \<Rightarrow> value \<Rightarrow> bool" ("_ \<approx>\<^sub>e _") where
constr: "list_all2 erelated ts us \<Longrightarrow> Vconstr name ts \<approx>\<^sub>e Vconstr name us" |
abs: "fmrel_on_fset (ids (Sabs cs)) erelated \<Gamma>\<^sub>1 \<Gamma>\<^sub>2 \<Longrightarrow> Vabs cs \<Gamma>\<^sub>1 \<approx>\<^sub>e Vabs cs \<Gamma>\<^sub>2" |
rec_abs:
  "pred_fmap (\<lambda>cs. fmrel_on_fset (ids (Sabs cs)) erelated \<Gamma>\<^sub>1 \<Gamma>\<^sub>2) css \<Longrightarrow>
     Vrecabs css name \<Gamma>\<^sub>1 \<approx>\<^sub>e Vrecabs css name \<Gamma>\<^sub>2"

code_pred erelated .

global_interpretation erelated: value_struct_rel erelated
proof
  fix v\<^sub>1 v\<^sub>2
  assume "v\<^sub>1 \<approx>\<^sub>e v\<^sub>2"
  thus "veq_structure v\<^sub>1 v\<^sub>2"
    by induction (auto intro: list.rel_mono_strong)
next
  fix name name' and ts us :: "value list"
  show "Vconstr name ts \<approx>\<^sub>e Vconstr name' us \<longleftrightarrow> (name = name' \<and> list_all2 erelated ts us)"
    by (auto intro: erelated.intros elim: erelated.cases)
qed

lemma erelated_refl[intro]: "t \<approx>\<^sub>e t"
proof (induction t)
  case Vrecabs
  thus ?case
    apply (auto intro!: erelated.intros fmpredI fmrel_on_fset_refl_strong)
    apply (auto intro: fmran'I)
    done
qed (auto intro!: erelated.intros list.rel_refl_strong fmrel_on_fset_refl_strong fmran'I)

export_code
  value_to_sterm vmatch vwellformed vclosed erelated_i_i pre_constants.vwelldefined
  constructors.vconstructor_value_rs pre_constants.not_shadows_vconsts term_to_value
  vfind_match veq_structure vno_abs
  checking Scala

end