Require Import Sail.Values Sail.Operators_mwords Sail.Hoare bbv.Word Mword.
Require Import aarch64_types aarch64.
Local Open Scope Z.
(*
  imports "Sail-AArch64.Aarch64_lemmas" Sail.Sail2_operators_mwords_lemmas Word_Extra Proof_methods
begin
(*>*)

text \<open>Various helper lemmas for simplifying proof obligations arising in the computation of
preconditions, e.g. if-then-else-distributivity rules for the datatypes in the model.\<close>

abbreviation
  "CreateFaultRecord typ1 ipaddress level acctype write1 extflag errortype secondstage s2fs1walk \<equiv>
     \<lparr>FaultRecord_typ = typ1, FaultRecord_acctype = acctype, FaultRecord_ipaddress = ipaddress,
      FaultRecord_s2fs1walk = s2fs1walk, FaultRecord_write = write1, FaultRecord_level = level,
      FaultRecord_extflag = extflag, FaultRecord_secondstage = secondstage, FaultRecord_domain = 0,
      FaultRecord_errortype = errortype, FaultRecord_debugmoe = 0\<rparr>"

abbreviation
  "AccessDescriptor acctype ptwalk secondstage s2fs2walk level \<equiv>
     \<lparr>AccessDescriptor_acctype = acctype,
      AccessDescriptor_page_table_walk = ptwalk,
      AccessDescriptor_secondstage = secondstage,
      AccessDescriptor_s2fs1walk = s2fs2walk,
      AccessDescriptor_level = level\<rparr>"

lemma CreateFaultRecord_if_distrib:
  "(if c then CreateFaultRecord typ1 ipaddress1 level1 acctype1 write1 extflag1 errortype1 secondstage1 s2fs1walk1
    else CreateFaultRecord typ2 ipaddress2 level2 acctype2 write2 extflag2 errortype2 secondstage2 s2fs1walk2) =
    CreateFaultRecord (if c then typ1 else typ2) (if c then ipaddress1 else ipaddress2)
      (if c then level1 else level2) (if c then acctype1 else acctype2) (if c then write1 else write2)
      (if c then extflag1 else extflag2) (if c then errortype1 else errortype2)
      (if c then secondstage1 else secondstage2) (if c then s2fs1walk1 else s2fs1walk2)"
  by auto

lemma fun2_if_distrib:
  "(if c then f x1 y1 else f x2 y2) = f (if c then x1 else x2) (if c then y1 else y2)"
  by auto

lemmas fun2_if_distribs =
  if_distrib[where f = f for f :: "'a \<Rightarrow> 'b \<Rightarrow> 'c", symmetric]
  fun2_if_distrib
  fun2_if_distrib[where f = Pair]
  fun2_if_distrib[where f = "(\<and>)"]
  fun2_if_distrib[where f = "(\<or>)"]

lemmas prod_if_distrib = fun2_if_distrib[where f = Pair]
lemmas conj_if_distrib = fun2_if_distrib[where f = "(\<and>)"]
lemmas disj_if_distrib = fun2_if_distrib[where f = "(\<or>)"]

lemmas all_if_distrib = if_distrib[where f = "\<lambda>c. \<forall>b. c b", symmetric]

lemmas AddressDescriptor_memattrs_update_if_distrib =
  if_distrib[where f = "\<lambda>c. addrdesc\<lparr>AddressDescriptor_memattrs := c\<rparr>" for addrdesc, symmetric]
  if_distrib[where f = "\<lambda>c. c\<lparr>AddressDescriptor_memattrs := z\<rparr>" for z]

lemma MemoryAttributes_if_distrib:
  "(if c then
      \<lparr>MemoryAttributes_typ = typ1, MemoryAttributes_device = device1,
       MemoryAttributes_inner = inner1, MemoryAttributes_outer = outer1,
       MemoryAttributes_shareable = shareable1, MemoryAttributes_outershareable = outershareable1\<rparr>
    else
      \<lparr>MemoryAttributes_typ = typ2, MemoryAttributes_device = device2,
       MemoryAttributes_inner = inner2, MemoryAttributes_outer = outer2,
       MemoryAttributes_shareable = shareable2, MemoryAttributes_outershareable = outershareable2\<rparr>) =
    \<lparr>MemoryAttributes_typ = if c then typ1 else typ2,
     MemoryAttributes_device = if c then device1 else device2,
     MemoryAttributes_inner = if c then inner1 else inner2,
     MemoryAttributes_outer = if c then outer1 else outer2,
     MemoryAttributes_shareable = if c then shareable1 else shareable2,
     MemoryAttributes_outershareable = if c then outershareable1 else outershareable2\<rparr>"
  by auto

lemma MemoryAttributes_cong:
  assumes "typ1 = typ2" and "device1 = device2" and "inner1 = inner2" and "outer1 = outer2"
    and "shareable1 = shareable2" and "outershareable1 = outershareable2"
  shows
    "\<lparr>MemoryAttributes_typ = typ1, MemoryAttributes_device = device1,
      MemoryAttributes_inner = inner1, MemoryAttributes_outer = outer1,
      MemoryAttributes_shareable = shareable1, MemoryAttributes_outershareable = outershareable1\<rparr> =
     \<lparr>MemoryAttributes_typ = typ2, MemoryAttributes_device = device2,
      MemoryAttributes_inner = inner2, MemoryAttributes_outer = outer2,
      MemoryAttributes_shareable = shareable2, MemoryAttributes_outershareable = outershareable2\<rparr>"
  using assms by auto

lemma MemAttrHints_if_distrib:
  "(if c
    then \<lparr>MemAttrHints_attrs = attrs1, MemAttrHints_hints = hints1, MemAttrHints_transient = transient1\<rparr>
    else \<lparr>MemAttrHints_attrs = attrs2, MemAttrHints_hints = hints2, MemAttrHints_transient = transient2\<rparr>) =
   \<lparr>MemAttrHints_attrs = if c then attrs1 else attrs2,
    MemAttrHints_hints = if c then hints1 else hints2,
    MemAttrHints_transient = if c then transient1 else transient2\<rparr>"
  by auto

lemma MemAttrHints_cong:
  assumes "attrs1 = attrs2" and "hints1 = hints2" and "transient1 = transient2"
  shows "\<lparr>MemAttrHints_attrs = attrs1, MemAttrHints_hints = hints1, MemAttrHints_transient = transient1\<rparr> =
         \<lparr>MemAttrHints_attrs = attrs2, MemAttrHints_hints = hints2, MemAttrHints_transient = transient2\<rparr>"
  using assms by auto

lemma case_option_if_distrib:
  "(if b then (case x1 of Some y \<Rightarrow> f1 y | None \<Rightarrow> g1) else (case x2 of Some y \<Rightarrow> f2 y | None \<Rightarrow> g2)) =
   (case (if b then x1 else x2) of Some y \<Rightarrow> if b then f1 y else f2 y | None \<Rightarrow> if b then g1 else g2)"
  by (auto split: option.splits)

lemma case_prod_if_distrib:
  "(if b then (case x1 of (y1, z1) \<Rightarrow> f1 y1 z1) else (case x2 of (y2, z2) \<Rightarrow> f2 y2 z2)) =
   (case (if b then x1 else x2) of (y, z) \<Rightarrow> if b then f1 y z else f2 y z)"
  by auto

lemma app_let_distrib: "(let x = y in f x) z = (let x = y in f x z)"
  by auto

lemmas TLBRecord_if_distribs[simp] =
  if_distrib[where f = TLBRecord_descupdate] if_distrib[where f = TLBRecord_descupdate_update]
  if_distrib[where f = "\<lambda>x. r\<lparr>TLBRecord_descupdate := x\<rparr>" for r]
  if_distrib[where f = TLBRecord_addrdesc]
lemmas DescriptorUpdate_if_distribs[simp] =
  if_distrib[where f = DescriptorUpdate_descaddr_update]
lemmas MemAttrHints_if_distribs[simp] =
  if_distrib[where f = MemAttrHints_attrs]
lemmas [simp] =
  if_distrib[where f = FullAddress_physicaladdress]
  if_distrib[where f = AddressDescriptor_paddress]
  if_distrib[where f = "\<lambda>i. x < i" for x]
  if_distrib[where f = "\<lambda>i. i < x" for x]
  if_distrib[where f = "\<lambda>i. x - i" for x]
  if_distrib[where f = "\<lambda>i. i = x" for x]

lemmas PrePost_if_distribs = app_if_distrib prod_if_distrib conj_if_distrib disj_if_distrib all_if_distrib
  AddressDescriptor_memattrs_update_if_distrib MemoryAttributes_if_distrib MemAttrHints_if_distrib
  (*TLBRecord_descupdate_update_if_distrib DescriptorUpdate_descaddr_update_if_distrib*)
  if_distrib[where f = "\<lambda>c. z \<le> c" for z] if_distrib[where f = "\<lambda>c. c \<le> z" for z]
  if_distrib[where f = "\<lambda>c. z < c" for z] if_distrib[where f = "\<lambda>c. c < z" for z]
  if_distrib[where f = returnS, symmetric]
  if_distrib[where f = return, symmetric]
  case_option_if_distrib case_prod_if_distrib
  if_distrib[where f = "\<lambda>c. let a = b in c a" for b, symmetric]
  if_distrib[where f = "\<lambda>c. a \<longrightarrow> c" for a, symmetric]
  (*if_distrib[where f = "\<lambda>c. z = c" for z] if_distrib[where f = "\<lambda>c. c = z" for z]*)
  (*if_distrib[where f = "\<lambda>c. c' \<and> c" for c'] if_distrib[where f = "\<lambda>c. c \<and> c'" for c']*)

lemmas app_case_distribs =
  sum.case_distrib[where h = "\<lambda>c. c z" for z]
  ex.case_distrib[where h = "\<lambda>c. c z" for z]
  option.case_distrib[where h = "\<lambda>c. c z" for z]
  app_let_distrib

lemma if_True_False_simps[simp]:
  "(if c then True else False) = c"
  "(if c then False else True) = (\<not>c)"
  "(if c1 then True else c2) = (c1 \<or> c2)"
  "(if c1 then c2 else True) = (c1 \<longrightarrow> c2)"
  "(if c1 then c2 else False) = (c1 \<and> c2)"
  by auto

lemma conj_imp_cond_absorb[simp]: "(b \<longrightarrow> c1) \<and> (b \<longrightarrow> c2) \<longleftrightarrow> (b \<longrightarrow> c1 \<and> c2)"
  by auto

lemma if_then_imp_distrib:
  "(if c then x \<longrightarrow> y else z) = ((c \<and> \<not>x) \<or> (if c then y else z))"
  "(if c then x \<or> y else z) = ((c \<and> x) \<or> (if c then y else z))"
  "(if c then x else y \<longrightarrow> z) = ((\<not>c \<and> \<not>y) \<or> (if c then x else z))"
  "(if c then x else y \<or> z) = ((\<not>c \<and> y) \<or> (if c then x else z))"
  by auto

lemma if_then_all_distrib:
  "\<And>c f g. (if c then \<forall>x. f x else g) = (\<forall>x. if c then f x else g)"
  "\<And>c f g. (if c then f else \<forall>x. g x) = (\<forall>x. if c then f else g x)"
  by auto

lemma if_then_conj_distrib:
  "(if c then x \<and> y else z) = ((c \<longrightarrow> x) \<and> (if c then y else z))"
  "(if c then x else y \<and> z) = ((\<not>c \<longrightarrow> y) \<and> (if c then x else z))"
  by auto

lemma nested_if_merges[simp]:
  "(if c1 then x else if c2 then x else y) = (if c1 \<or> c2 then x else y)"
  "(if c1 then x else if c2 then y else x) = (if c1 \<or> \<not>c2 then x else y)"
  "(if c1 then x else (if c2 then y else (if c3 then x else z))) = (if c1 \<or> (\<not>c2 \<and> c3) then x else if c2 then y else z)"
  "(if c1 then x else (if c2 then (if c3 then x else y) else z)) = (if c1 \<or> (c2 \<and> c3) then x else if c2 then y else z)"
  "(if c1 then (if c2 then x else y) else (if c3 then x else z)) = (if (c1 \<and> c2) \<or> (\<not>c1 \<and> c3) then x else if c1 then y else z)"
  "(if (if a then b else c) then x else y) \<longleftrightarrow> (if (\<not>a \<or> b) \<and> (a \<or> c) then x else y)"
  "(if a then b \<and> c else c) \<longleftrightarrow> (\<not>a \<or> b) \<and> c"
  "(if a then (if b then x else y) else y) \<longleftrightarrow> (if (a \<and> b) then x else y)"
  "(if a then (if b then x else y) else (if c then x else y)) \<longleftrightarrow> (if (\<not>a \<or> b) \<and> (a \<or> c) then x else y)"
  "(\<forall>a. if a \<or> b then x else y) \<longleftrightarrow> x \<and> (if b then x else y)"
  by auto

lemma conj_disj_absorbs[simp]:
  "A \<and> B \<or> A \<longleftrightarrow> A"
  "A \<and> B \<or> B \<longleftrightarrow> B"
  "(A \<and> B) \<or> (\<not>A \<and> B) \<longleftrightarrow> B"
  "(\<not>A \<and> B) \<or> (A \<and> B) \<longleftrightarrow> B"
  by auto

lemma quant_singleton_bool_simps[simp]:
  "(\<forall>b. b) \<longleftrightarrow> False" "(\<forall>b. \<not>b) \<longleftrightarrow> False" "(\<exists>b. b) \<longleftrightarrow> True" "(\<exists>b. \<not>b) \<longleftrightarrow> True"
  by auto

lemmas MemAttr_defs[simp] = MemAttr_WT_def MemAttr_WB_def MemAttr_NC_def

lemma case_prod15_split:
  "(case vars of (accdesc, addrselectbottom, addrselecttop, ap_table, baseaddress, blocktranslate, desc, descaddr, descaddr2, hwupdatewalk, level,
                     ns_table, pxn_table, result, xn_table) \<Rightarrow>
      f accdesc addrselectbottom addrselecttop ap_table baseaddress blocktranslate desc descaddr descaddr2 hwupdatewalk level
                     ns_table pxn_table result xn_table) =
   (\<forall>accdesc addrselectbottom addrselecttop ap_table baseaddress blocktranslate desc descaddr descaddr2 hwupdatewalk level
                     ns_table pxn_table result xn_table.
      vars = (accdesc, addrselectbottom, addrselecttop, ap_table, baseaddress, blocktranslate, desc, descaddr, descaddr2, hwupdatewalk, level,
                     ns_table, pxn_table, result, xn_table) \<longrightarrow>
      f accdesc addrselectbottom addrselecttop ap_table baseaddress blocktranslate desc descaddr descaddr2 hwupdatewalk level
                     ns_table pxn_table result xn_table)"
  by auto

lemma prod15_cases:
  obtains accdesc addrselectbottom addrselecttop ap_table baseaddress blocktranslate desc descaddr descaddr2 hwupdatewalk level
                     ns_table pxn_table result xn_table
                   where "x = (accdesc, addrselectbottom, addrselecttop, ap_table, baseaddress, blocktranslate, desc, descaddr, descaddr2, hwupdatewalk, level,
                     ns_table, pxn_table, result, xn_table)"
  by (cases x) auto

lemma TLBRecord_if_distrib:
  "(if c then
      \<lparr>TLBRecord_perms =
         \<lparr>Permissions_ap = ap1, Permissions_xn = xn1, Permissions_xxn = xxn1, Permissions_pxn = pxn1\<rparr>,
       TLBRecord_nG = nG1, TLBRecord_domain = domain1, TLBRecord_contiguous = contiguous1,
       TLBRecord_level = level1, TLBRecord_blocksize = blocksize1,
       TLBRecord_descupdate =
         \<lparr>DescriptorUpdate_AF = af1, DescriptorUpdate_AP = descupd_ap1,
          DescriptorUpdate_descaddr = descaddr1 \<rparr>,
       TLBRecord_CnP = cnp1,
       TLBRecord_addrdesc =
         \<lparr>AddressDescriptor_fault = fault1, AddressDescriptor_memattrs = memattrs1,
          AddressDescriptor_paddress = \<lparr>FullAddress_physicaladdress = paddress1, FullAddress_NS = ns1\<rparr>,
          AddressDescriptor_vaddress = vaddress1\<rparr> \<rparr>
    else
      \<lparr>TLBRecord_perms =
         \<lparr>Permissions_ap = ap2, Permissions_xn = xn2, Permissions_xxn = xxn2, Permissions_pxn = pxn2\<rparr>,
       TLBRecord_nG = nG2, TLBRecord_domain = domain2, TLBRecord_contiguous = contiguous2,
       TLBRecord_level = level2, TLBRecord_blocksize = blocksize2,
       TLBRecord_descupdate =
         \<lparr>DescriptorUpdate_AF = af2, DescriptorUpdate_AP = descupd_ap2, DescriptorUpdate_descaddr = descaddr2 \<rparr>,
       TLBRecord_CnP = cnp2,
       TLBRecord_addrdesc =
         \<lparr>AddressDescriptor_fault = fault2, AddressDescriptor_memattrs = memattrs2,
          AddressDescriptor_paddress = \<lparr>FullAddress_physicaladdress = paddress2, FullAddress_NS = ns2\<rparr>,
          AddressDescriptor_vaddress = vaddress2\<rparr> \<rparr>) =
       \<lparr>TLBRecord_perms =
          \<lparr>Permissions_ap = if c then ap1 else ap2,
           Permissions_xn = if c then xn1 else xn2,
           Permissions_xxn = if c then xxn1 else xxn2,
           Permissions_pxn = if c then pxn1 else pxn2\<rparr>,
        TLBRecord_nG = if c then nG1 else nG2,
        TLBRecord_domain = if c then domain1 else domain2,
        TLBRecord_contiguous = if c then contiguous1 else contiguous2,
        TLBRecord_level = if c then level1 else level2,
        TLBRecord_blocksize = if c then blocksize1 else blocksize2,
        TLBRecord_descupdate =
          \<lparr>DescriptorUpdate_AF = if c then af1 else af2,
           DescriptorUpdate_AP = if c then descupd_ap1 else descupd_ap2,
           DescriptorUpdate_descaddr = if c then descaddr1 else descaddr2 \<rparr>,
        TLBRecord_CnP = if c then cnp1 else cnp2,
        TLBRecord_addrdesc =
          \<lparr>AddressDescriptor_fault = if c then fault1 else fault2,
           AddressDescriptor_memattrs = if c then memattrs1 else memattrs2,
           AddressDescriptor_paddress =
              \<lparr>FullAddress_physicaladdress = if c then paddress1 else paddress2,
               FullAddress_NS = if c then ns1 else ns2\<rparr>,
           AddressDescriptor_vaddress = if c then vaddress1 else vaddress2\<rparr> \<rparr>"
  by auto

lemma DescriptorUpdate_if_distrib:
  "(if c
    then \<lparr>DescriptorUpdate_AF = af1, DescriptorUpdate_AP = ap1, DescriptorUpdate_descaddr = addr1\<rparr>
    else \<lparr>DescriptorUpdate_AF = af2, DescriptorUpdate_AP = ap2, DescriptorUpdate_descaddr = addr2\<rparr>) =
   \<lparr>DescriptorUpdate_AF = if c then af1 else af2,
    DescriptorUpdate_AP = if c then ap1 else ap2,
    DescriptorUpdate_descaddr = if c then addr1 else addr2\<rparr>"
  by auto

(* Add some lemmas for automatically splitting TLBRecords into their components during precondition
   computation.  This seems to make simplification of record updates more efficient. *)

lemma TLBRecord_cases:
  fixes x :: TLBRecord
  obtains ap xn xxn pxn nG domain contiguous level blocksize af descupd_ap descaddr cnp fault memattrs paddress ns vaddress
  where "x = \<lparr>TLBRecord_perms =
                \<lparr>Permissions_ap = ap, Permissions_xn = xn, Permissions_xxn = xxn, Permissions_pxn = pxn\<rparr>,
              TLBRecord_nG = nG, TLBRecord_domain = domain, TLBRecord_contiguous = contiguous,
              TLBRecord_level = level, TLBRecord_blocksize = blocksize,
              TLBRecord_descupdate =
                \<lparr>DescriptorUpdate_AF = af, DescriptorUpdate_AP = descupd_ap,
                 DescriptorUpdate_descaddr = descaddr \<rparr>,
              TLBRecord_CnP = cnp,
              TLBRecord_addrdesc =
                \<lparr>AddressDescriptor_fault = fault, AddressDescriptor_memattrs = memattrs,
                 AddressDescriptor_paddress = \<lparr>FullAddress_physicaladdress = paddress, FullAddress_NS = ns\<rparr>,
                 AddressDescriptor_vaddress = vaddress\<rparr> \<rparr>"
proof -
  obtain perms nG domain contiguous level blocksize descupdate cnp addrdesc where
    "x = \<lparr>TLBRecord_perms = perms, TLBRecord_nG = nG, TLBRecord_domain = domain,
          TLBRecord_contiguous = contiguous, TLBRecord_level = level,
          TLBRecord_blocksize = blocksize, TLBRecord_descupdate = descupdate,
          TLBRecord_CnP = cnp, TLBRecord_addrdesc = addrdesc \<rparr>"
    by (cases x)
  moreover obtain ap xn xxn pxn where
    "perms = \<lparr>Permissions_ap = ap, Permissions_xn = xn, Permissions_xxn = xxn, Permissions_pxn = pxn\<rparr>"
    by (cases perms)
  moreover obtain af descupd_ap descaddr where
    "descupdate = \<lparr>DescriptorUpdate_AF = af, DescriptorUpdate_AP = descupd_ap,
                   DescriptorUpdate_descaddr = descaddr \<rparr>"
    by (cases descupdate)
  moreover obtain fault memattrs paddress' vaddress where
    "addrdesc = \<lparr>AddressDescriptor_fault = fault, AddressDescriptor_memattrs = memattrs,
                  AddressDescriptor_paddress = paddress', AddressDescriptor_vaddress = vaddress\<rparr>"
    by (cases addrdesc)
  moreover obtain paddress ns where
    "paddress' = \<lparr>FullAddress_physicaladdress = paddress, FullAddress_NS = ns\<rparr>"
    by (cases paddress')
  ultimately show thesis using that by blast
qed

lemma PrePostE_bindS_TLBRecord:
  assumes f:
    "\<And>ap xn xxn pxn nG domain contiguous level blocksize af descupd_ap descaddr cnp fault memattrs paddress ns vaddress.
        PrePostE (P' ap xn xxn pxn nG domain contiguous level blocksize af descupd_ap descaddr
                     cnp fault memattrs paddress ns vaddress)
                 (f (\<lparr>TLBRecord_perms =
                        \<lparr>Permissions_ap = ap, Permissions_xn = xn, Permissions_xxn = xxn, Permissions_pxn = pxn\<rparr>,
                      TLBRecord_nG = nG, TLBRecord_domain = domain, TLBRecord_contiguous = contiguous,
                      TLBRecord_level = level, TLBRecord_blocksize = blocksize,
                      TLBRecord_descupdate =
                        \<lparr>DescriptorUpdate_AF = af, DescriptorUpdate_AP = descupd_ap,
                         DescriptorUpdate_descaddr = descaddr \<rparr>,
                      TLBRecord_CnP = cnp,
                      TLBRecord_addrdesc =
                        \<lparr>AddressDescriptor_fault = fault, AddressDescriptor_memattrs = memattrs,
                         AddressDescriptor_paddress =
                            \<lparr>FullAddress_physicaladdress = paddress,
                             FullAddress_NS = ns\<rparr>,
                         AddressDescriptor_vaddress = vaddress\<rparr> \<rparr>)) Q E"
    and m: "PrePostE P m
                     (\<lambda>r s. \<forall>ap xn xxn pxn nG domain contiguous level blocksize af descupd_ap descaddr
                             cnp fault memattrs paddress ns vaddress.
                          \<lparr>TLBRecord_perms =
                             \<lparr>Permissions_ap = ap, Permissions_xn = xn, Permissions_xxn = xxn, Permissions_pxn = pxn\<rparr>,
                           TLBRecord_nG = nG, TLBRecord_domain = domain, TLBRecord_contiguous = contiguous,
                           TLBRecord_level = level, TLBRecord_blocksize = blocksize,
                           TLBRecord_descupdate =
                             \<lparr>DescriptorUpdate_AF = af, DescriptorUpdate_AP = descupd_ap,
                              DescriptorUpdate_descaddr = descaddr \<rparr>,
                           TLBRecord_CnP = cnp,
                           TLBRecord_addrdesc =
                             \<lparr>AddressDescriptor_fault = fault, AddressDescriptor_memattrs = memattrs,
                              AddressDescriptor_paddress =
                                 \<lparr>FullAddress_physicaladdress = paddress,
                                  FullAddress_NS = ns\<rparr>,
                              AddressDescriptor_vaddress = vaddress\<rparr> \<rparr> = r \<longrightarrow>
                          P' ap xn xxn pxn nG domain contiguous level blocksize af descupd_ap descaddr
                             cnp fault memattrs paddress ns vaddress s) E"
        (is "PrePostE P m ?R E")
  shows "PrePostE P (bindS m f) Q E"
proof (intro PrePostE_bindS_any)
  fix a
  show "PrePostE (?R a) (f a) Q E"
    by (cases a rule: TLBRecord_cases) (auto intro: f)
  show "PrePostE P m ?R E" using m .
qed

lemma PrePostE_bindS_prod15_TLBRecord14:
  assumes
    "\<And>x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x15 ap xn xxn pxn nG domain contiguous level
      blocksize af descupd_ap descaddr cnp fault memattrs paddress ns vaddress.
       PrePostE (P' x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 ap xn xxn pxn nG domain contiguous level
                    blocksize af descupd_ap descaddr cnp fault memattrs paddress ns vaddress x15)
                (f (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13,
                    \<lparr>TLBRecord_perms =
                      \<lparr>Permissions_ap = ap, Permissions_xn = xn, Permissions_xxn = xxn, Permissions_pxn = pxn\<rparr>,
                     TLBRecord_nG = nG, TLBRecord_domain = domain, TLBRecord_contiguous = contiguous,
                     TLBRecord_level = level, TLBRecord_blocksize = blocksize,
                     TLBRecord_descupdate =
                       \<lparr>DescriptorUpdate_AF = af, DescriptorUpdate_AP = descupd_ap,
                        DescriptorUpdate_descaddr = descaddr \<rparr>,
                     TLBRecord_CnP = cnp,
                     TLBRecord_addrdesc =
                       \<lparr>AddressDescriptor_fault = fault, AddressDescriptor_memattrs = memattrs,
                        AddressDescriptor_paddress =
                           \<lparr>FullAddress_physicaladdress = paddress, FullAddress_NS = ns\<rparr>,
                        AddressDescriptor_vaddress = vaddress\<rparr> \<rparr>, x15)) Q E"
    and "PrePostE P m
                  (\<lambda>r s. case r of (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15) \<Rightarrow>
                         (\<forall>ap xn xxn pxn nG domain contiguous level blocksize af descupd_ap
                           descaddr cnp fault memattrs paddress ns vaddress.
                         (\<lparr>TLBRecord_perms =
                             \<lparr>Permissions_ap = ap, Permissions_xn = xn, Permissions_xxn = xxn,
                              Permissions_pxn = pxn\<rparr>,
                           TLBRecord_nG = nG, TLBRecord_domain = domain, TLBRecord_contiguous = contiguous,
                           TLBRecord_level = level, TLBRecord_blocksize = blocksize,
                           TLBRecord_descupdate =
                             \<lparr>DescriptorUpdate_AF = af, DescriptorUpdate_AP = descupd_ap,
                              DescriptorUpdate_descaddr = descaddr \<rparr>,
                           TLBRecord_CnP = cnp,
                           TLBRecord_addrdesc =
                             \<lparr>AddressDescriptor_fault = fault, AddressDescriptor_memattrs = memattrs,
                              AddressDescriptor_paddress =
                                 \<lparr>FullAddress_physicaladdress = paddress, FullAddress_NS = ns\<rparr>,
                              AddressDescriptor_vaddress = vaddress\<rparr> \<rparr>) = x14 \<longrightarrow>
                          P' x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 ap xn xxn pxn nG domain
                             contiguous level blocksize af descupd_ap descaddr cnp fault memattrs
                             paddress ns vaddress x15 s)) E"
    (is "PrePostE P m ?R E")
  shows "PrePostE P (bindS m f) Q E"
proof (intro PrePostE_bindS_any)
  fix a :: "'a \<times> 'b \<times> 'c \<times> 'd \<times> 'e \<times> 'f \<times> 'g \<times> 'h \<times> 'i \<times> 'j \<times> 'k \<times> 'l \<times> 'm \<times> TLBRecord \<times> 'n"
  obtain x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15
    where "a = (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15)"
    by (cases a rule: prod15_cases)
  then show "PrePostE (?R a) (f a) Q E"
    by (cases x14 rule: TLBRecord_cases) (auto intro: assms)
  show "PrePostE P m ?R E" using assms(2) .
qed

lemmas PrePostE_bindS_TLBRecords = PrePostE_bindS_TLBRecord PrePostE_bindS_prod15_TLBRecord14

lemma option_case_prod_9_None_False_elim:
  assumes "case x of None \<Rightarrow> False
             | Some (x1, x2, x3, x4, x5, x6, x7, x8, x9) \<Rightarrow> P x1 x2 x3 x4 x5 x6 x7 x8 x9"
  obtains x1 x2 x3 x4 x5 x6 x7 x8 x9
  where "Some (x1, x2, x3, x4, x5, x6, x7, x8, x9) = x"
    and "P x1 x2 x3 x4 x5 x6 x7 x8 x9"
  using assms by (cases x) auto

lemma GetSlice_int_get_slice_int[simp]:
  "GetSlice_int (len :: 'a::len itself) n i = get_slice_int (int LENGTH('a)) n i"
  by (auto simp: GetSlice_int_def)

lemmas [simp] = ex_int_def ex_nat_def

declare extzv_def[simp]

lemma slice_mask_mask: "slice_mask outlen i l = (mask (nat l)) << (nat i)"
  by (auto simp: slice_mask_def mask_def)

lemma HasArchVersion_True: "HasArchVersion v = True"
  by (cases v; auto simp: HasArchVersion_def)

lemma HaveEL_True: "HaveEL el = True"
  by (auto simp: HaveEL_def)

lemmas Have_simps[simp] = HaveEL_True HasArchVersion_True Have52BitPAExt_def Have52BitVAExt_def
  HaveAccessFlagUpdateExt_def HaveAtomicExt_def HaveCommonNotPrivateTransExt_def
  HaveDirtyBitModifierExt_def HaveExtendedExecuteNeverExt_def HaveFJCVTZSExt_def HaveNVExt_def
  HavePACExt_def HavePANExt_def HavePrivATExt_def HaveStatisticalProfiling_def
  HaveTrapLoadStoreMultipleDeviceExt_def HaveUAOExt_def HaveVirtHostExt_def HaveRASExt_def
  HaveCRCExt_def AArch64_HaveHPDExt_def

lemma PAMax_simp: "PAMax () = 52" by (auto simp: PAMax_def IMPDEF_integer_def)

lemma Zeros__0_0[simp]: "Zeros__0 n = 0" by (auto simp: Zeros__0_def)
lemma IsZero_iff_eq0[simp]: "IsZero w \<longleftrightarrow> w = 0" by (auto simp: IsZero_def Zeros__0_def)

lemma ZeroExtend_simps[simp]:
  "\<And>N w. LENGTH('a) \<le> LENGTH('b) \<Longrightarrow> ZeroExtend__0 w N = return (ucast (w :: 'a::len word) :: 'b::len word)"
  "\<And>N w. LENGTH('c) \<le> LENGTH('d) \<Longrightarrow> ZeroExtend__1 N w = return (ucast (w :: 'c::len word) :: 'd::len word)"
  by (auto simp: ZeroExtend__1_def ZeroExtend__0_def)

lemma ZeroExtend__1_64_64_return: "ZeroExtend__1 64 (w :: 64 word) = return w"
  by auto

lemma undefined_bitvector_simp[simp]: "undefined_bitvector n = return 0"
  by (auto simp add: undefined_bitvector_def simp del: repeat.simps)

lemma hex_slice_13000000[simp]: "hex_slice ''0x13000000'' 52 0 = return (0x13000000 :: 52 word)"
  by (auto simp: hex_slice_def hexstring_to_bools_def hexchar_to_bool_list_def ext_list_def maybe_fail_def
                 subrange_list_def subrange_list_dec_def subrange_list_inc_def split_at_def)
*)
Definition aligned {m} (w : mword m) (n : Z) : Prop :=
  exists x, x * n = projT1 (uint w).
(*
Lemma aligned_8_mask_3 :
  aligned w 8 -> wand w (mask 3) = 0.
  using and_mask_dvd[where n = 3]
  by (auto simp: aligned_def)

lemma aligned8_OR_distrib: "aligned (x OR y) 8 \<longleftrightarrow> aligned x 8 \<and> aligned y 8"
  by (auto simp: aligned_8_mask_3 word_bool_alg.conj_disj_distrib2)

lemma aligned8_ucast:
  fixes a :: "'a::len word"
  defines "b \<equiv> ucast a :: 'b::len word"
  assumes b: "3 \<le> LENGTH('b)"
  shows "aligned b 8 \<longleftrightarrow> aligned a 8"
  using b test_bit_size[of b] unfolding b_def
  by (auto simp: aligned_8_mask_3 word_and_mask_0_iff_not_testbits nth_ucast)

lemma aligned8_shiftl_3: "i \<ge> 3 \<Longrightarrow> aligned (x << i) 8"
  by (auto simp: aligned_8_mask_3 word_and_mask_0_iff_not_testbits nth_shiftl)
*)
Lemma mword_elim (P : forall n, mword n -> Prop) :
  (forall n (w : mword (Z.of_nat n)), P (Z.of_nat n) w) ->
  forall n w, P n w.

intros H n w.
specialize (ArithFact_mword _ w).
intros [GE]. apply Z_geb_ge in GE.  apply Z.ge_le in GE.
revert w.
rewrite <- (Z2Nat.id n GE).
apply H.
Qed.

Lemma wordToN_eq_dep m n w v :
  EqdepFacts.eq_dep nat word m w n v ->
  wordToN w = wordToN v.
intros [].
reflexivity.
Qed.

Lemma uint_concat_vec m n (a : mword m) (b : mword n) :
  uint_plain (concat_vec a b) = uint_plain b + 2 ^ n * uint_plain a.
unfold uint_plain, concat_vec.
replace (2 ^ n) with (Z.of_N (2 ^ Z.to_N n)). 2: {
  rewrite N2Z.inj_pow.
  rewrite Z2N.id.
  reflexivity.
  apply ArithFact_mword in b.
  prepare_for_solver.
  assumption.
}
rewrite <- N2Z.inj_mul.
rewrite <- N2Z.inj_add.
f_equal.
replace (2 ^ Z.to_N n)%N with (Npow2 (Z.to_nat n)). 2: {
  rewrite <- Z_nat_N, Npow2_pow.
  reflexivity.
}
rewrite <- wordToN_combine.
apply wordToN_eq_dep.
eapply EqdepFacts.eq_dep_trans.
apply Mword.get_cast_to_mword.
constructor.
Qed.

Require Import Lia Psatz.

Lemma aligned8_word_cat m n (a : mword m) (b : mword n) :
  3 <= n ->
  aligned (concat_vec a b) 8 <-> aligned b 8.
apply mword_elim with (n := m) (w := a).
apply mword_elim with (n := n) (w := b).
clear.
intros m w n v LE.
unfold aligned.
simpl (projT1 _).
split.
* intros [x EQ].
  rewrite uint_concat_vec in EQ.
  exists (x - 2 ^ (Z.of_nat m - 3) * uint_plain v).
  rewrite Z.mul_sub_distr_r.
  change 8 with (2 ^ 3) at 2.
  rewrite <- Z.mul_assoc.
  rewrite (Z.mul_comm (uint_plain v) (2 ^ 3)).
  rewrite Z.mul_assoc.
  rewrite <- Z.pow_add_r.
  + rewrite Z.sub_add.
    omega.
  + omega.
  + omega.
* intros [x EQ].
  rewrite uint_concat_vec.
  rewrite <- EQ.
  rewrite <- Z.sub_add with (n := 3) (m := Z.of_nat m).
  exists (x + 2 ^ (Z.of_nat m - 3) * uint_plain v).
  rewrite Z.pow_add_r.
  + rewrite Z.mul_add_distr_r.
    change (2^3) with 8.
    rewrite <- Z.mul_assoc.
    rewrite (Z.mul_comm (uint_plain v) 8).
    rewrite Z.mul_assoc.
    reflexivity.
  + omega.
  + omega.
Qed.
(*
lemma slice_zeros_concat_slice_and_mask[simp]:
  fixes xs :: "'a::len word"
  shows "slice_zeros_concat outlen xs i l l' = (Word.slice (nat i) xs AND mask (nat l)) << nat l'"
proof -
  have "n - nat l' < LENGTH('a) \<and> n + nat i - nat l' < LENGTH('a)"
    if "xs !! (n + nat i - nat l')" for n
    using that by (auto dest: test_bit_size[of xs])
  then show ?thesis
    unfolding slice_zeros_concat_def slice_mask_mask
    by (intro word_eqI) (auto simp: ucast_shiftr word_ao_nth nth_shiftl nth_slice)
qed

lemmas aligned8_simps = aligned8_OR_distrib aligned8_shiftl_3 aligned8_word_cat aligned8_ucast

lemma place_slice_grainsize:
  assumes "grainsize \<ge> 0"
  shows "(place_slice 52 (w :: 64 word) grainsize (48 - grainsize) grainsize :: 52 word) =
         word_cat (0 :: 4 word) ((Word.slice (nat grainsize) w << nat grainsize) :: 48 word)"
  using assms
  by (intro word_eqI)
     (auto simp: place_slice_def slice_mask_mask nth_shiftl nth_shiftr nth_slice word_ao_nth nth_ucast)

lemma set_slice_of_bl_drop_take:
  fixes out :: "'a::len word" and bs :: "bool list"
  (*defines "v \<equiv> of_bl bs :: 'b::len word"*)
  assumes "n \<ge> 0" and "slice_len > 0" and "n + slice_len \<le> int LENGTH('a)" (*and "length bs = LENGTH('b)"*)
  shows "set_slice out_len slice_len (out :: 'a::len word) n v =
           of_bl (take (LENGTH('a) - nat n - nat slice_len) (to_bl out) @
                  to_bl v @
                  drop (LENGTH('a) - nat n) (to_bl out))"
  using assms unfolding set_slice_def
  by (auto simp: update_subrange_vec_dec_update_subrange_list_dec update_subrange_list_dec_drop_take nat_add_distrib)

lemma NOT_of_bl[simp]:
  fixes bs :: "bool list"
  defines "w \<equiv> of_bl bs :: 'a::len word"
  assumes "length bs = LENGTH('a)"
  shows "NOT w = of_bl (map Not bs)"
  using assms by (intro word_eqI) (auto simp: word_ops_nth_size test_bit_of_bl rev_map)

lemma of_bl_AND_of_bl:
  assumes "length l = length r"
  shows "(of_bl l) AND (of_bl r) = of_bl (map2 (\<and>) l r)"
  using assms
  by (intro word_eqI) (auto simp: word_ops_nth_size test_bit_of_bl map2_def rev_map zip_rev[symmetric])

lemma True_OR_1word_absorb: "1 OR (w :: 1 word) = 1"
  by (intro word_eqI) (auto simp: word_ao_nth)

lemma to_bl_1_1word: "to_bl (1 :: 1 word) = [True]"
  by eval

lemma of_bl_test_bit_1word[simp]: "of_bl [w !! 0] = (w :: 1 word)"
  by (intro word_eqI) (auto simp: test_bit_of_bl)

lemma all_bool_neq_or_iff: "(\<forall>b. x = (\<not>b) \<or> P b) = P x"
  by (cases x) (auto simp: all_bool_eq)

lemma arg_cong5:
  assumes "a = a'" and "b = b'" and "c = c'" and "d = d'" and "e = e'"
  shows "f a b c d e = f a' b' c' d' e'"
  using assms by auto

lemma Suc_Suc_0_eq_2: "Suc (Suc 0) = 2"
  by auto

lemma nth_rev_drop: "i < length xs - n \<Longrightarrow> rev (drop n xs) ! i = rev xs ! i"
  by (auto simp: rev_drop)

lemma nth_rev_to_bl:
  fixes w :: "'a::len word"
  assumes "i < LENGTH('a)"
  shows "rev (to_bl w) ! i = w !! i"
  using assms by (auto simp: test_bit_bl)

lemma Let_const[simp]: "(let x = y in f) = f"
  by auto

lemma word_slice_if_distrib: "(Word.slice n (if c then x else y) = z) \<longleftrightarrow> (if c then Word.slice n x = z else Word.slice n y = z)"
  by auto

lemma [simp]: "(if c then False else x) \<longleftrightarrow> (\<not>c \<and> x)"
  by auto

lemma word4_and3_exhaust:
  fixes x :: "4 word"
  shows "x AND 3 = 0 \<longrightarrow> x = 0 \<or> x = 4 \<or> x = 8 \<or> x = 12"
  by (cases x rule: exhaustive_4_word) auto

lemma word4_and3_exhaust':
  fixes x :: "4 word"
  assumes "x AND 3 = 0" and "x \<noteq> 0" and "x \<noteq> 4" and "x \<noteq> 8"
  shows "x = 12"
  using assms by (cases x rule: exhaustive_4_word) auto

lemma [simp]:
  "bitU_of_bool b = B0 \<longleftrightarrow> \<not>b"
  "bitU_of_bool b = B1 \<longleftrightarrow> b"
  by (auto simp: bitU_of_bool_def)

lemma word1_OR_of_bl_disj[simp]:
  fixes w :: "1 word"
  shows "w OR of_bl [b] = of_bl [w !! 0 \<or> b]" and "of_bl [b] OR w = of_bl [b \<or> w !! 0]"
  by (intro word_eqI; auto simp: word_ao_nth test_bit_of_bl)+

lemma nat_lt_2_cases:
  fixes n :: nat
  assumes "n < 2" and "P 0" and "P 1"
  shows "P n"
  using assms by (cases n) auto

lemma word2_OR_of_bl_disj[simp]:
  fixes w :: "2 word"
  shows "w OR of_bl [b1, b0] = of_bl [w !! 1 \<or> b1, w !! 0 \<or> b0]"
    and "of_bl [b1, b0] OR w = of_bl [b1 \<or> w !! 1, b0 \<or> w !! 0]"
  by (intro word_eqI; auto elim!: nat_lt_2_cases simp: word_ao_nth test_bit_of_bl)+

lemma word2_of_bl_test_bits_eq[simp]:
  "of_bl [w !! Suc 0, w !! 0] = (w :: 2 word)"
  by (intro word_eqI; auto elim!: nat_lt_2_cases simp: test_bit_of_bl)

lemma set_slice_2_1_of_bl[simp]:
  "set_slice 2 1 (out :: 2 word) 1 (v :: 1 word) = of_bl [v !! 0, out !! 0]"
  "set_slice 2 1 (out :: 2 word) 0 (v :: 1 word) = of_bl [out !! 1, v !! 0]"
  by (intro word_eqI;
      auto simp: set_slice_def update_subrange_vec_dec_update_subrange_list_dec
                 update_subrange_list_dec_drop_take test_bit_of_bl nth_rev nth_append to_bl_nth
                 elim!: nat_lt_2_cases)+

lemma case_prod_elims:
  "\<And>Q P z thesis. Q (case z of (a, b, c, d, e, f, g) \<Rightarrow> P a b c d e f g) \<Longrightarrow> (\<And>a b c d e f g. z = (a, b, c, d, e, f, g) \<Longrightarrow> Q (P a b c d e f g) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  "\<And>Q P z thesis. Q (case z of (a, b, c, d, e, f) \<Rightarrow> P a b c d e f) \<Longrightarrow> (\<And>a b c d e f. z = (a, b, c, d, e, f) \<Longrightarrow> Q (P a b c d e f) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  "\<And>Q P z thesis. Q (case z of (a, b, c, d, e) \<Rightarrow> P a b c d e) \<Longrightarrow> (\<And>a b c d e. z = (a, b, c, d, e) \<Longrightarrow> Q (P a b c d e) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  "\<And>Q P z thesis. Q (case z of (a, b, c, d) \<Rightarrow> P a b c d) \<Longrightarrow> (\<And>a b c d. z = (a, b, c, d) \<Longrightarrow> Q (P a b c d) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  "\<And>Q P z thesis. Q (case z of (a, b, c) \<Rightarrow> P a b c) \<Longrightarrow> (\<And>a b c. z = (a, b, c) \<Longrightarrow> Q (P a b c) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  "\<And>Q P z thesis. Q (case z of (a, b) \<Rightarrow> P a b) \<Longrightarrow> (\<And>a b. z = (a, b) \<Longrightarrow> Q (P a b) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  by auto

lemmas Run_case_prodE = case_prod_elims[where Q = "\<lambda>c. Run c t a" for t a]

lemma set_slice_set_bit[simp]:
  assumes "nat i < LENGTH('a)"
  shows "set_slice len 1 (w :: 'a::len word) i (b :: 1 word) = set_bit w (nat i) (b !! 0)"
  using assms
  by (intro word_eqI)
     (auto simp: set_slice_def test_bit_set_gen update_subrange_vec_dec_def
                word_update_def Let_def test_bit_of_bl nth_append nth_rev to_bl_nth)

lemma slice_set_bit_below:
  shows "m > n \<Longrightarrow> Word.slice m (set_bit w n x) = Word.slice m w"
  by (intro word_eqI) (auto simp: nth_slice test_bit_set_gen)

lemma slice_set_bit_above:
  fixes w :: "'a::len word" and m :: nat
  defines "w' \<equiv> Word.slice m w :: 'b::len word"
  assumes "m + LENGTH('b) < n"
  shows "Word.slice m (set_bit w n x) = w'"
  using assms by (intro word_eqI) (auto simp: nth_slice test_bit_set_gen)

lemma set_bit_3_word:
  fixes w :: "3 word"
  shows "set_bit w 0 x = of_bl [w !! 2, w !! (Suc 0), x]"
        "set_bit w (Suc 0) x = of_bl [w !! 2, x, w !! 0]"
        "set_bit w 2 x = of_bl [x, w !! (Suc 0), w !! 0]"
  by (cases w rule: exhaustive_3_word; cases x; auto)+

lemma case_None_False_exists_Some:
  "(case x of None \<Rightarrow> False | Some y \<Rightarrow> P y) \<longleftrightarrow> (\<exists>y. Some y = x \<and> P y)"
  by (auto split: option.splits)

lemma case_None_Not_exists_Some:
  "\<not>P f1 \<Longrightarrow> (P (case x of None \<Rightarrow> f1 | Some y \<Rightarrow> f2 y)) = (\<exists>y. Some y = x \<and> P (f2 y))"
  by (auto split: option.splits)

lemma Some_eq_if_Some_None_iff_eq:
  "(Some x = (if c then Some y else None)) \<longleftrightarrow> (c \<and> x = y)"
  by auto

lemma Align__1_8_iff_aligned_8[simp]: "(w = Align__1 w 8) \<longleftrightarrow> aligned (w :: 52 word) 8"
proof
  assume "w = Align__1 w 8"
  then have w: "w = word_of_int (8 * (uint w div 8))"
    by (auto simp: Align__1_def Align__0_def of_bl_bin_word_of_int)
  have 8: "(8 :: int) dvd 2 ^ 52" by eval
  show "aligned w 8"
    using dvd_mod_iff[OF 8]
    by (subst w) (auto simp: aligned_def uint_word_of_int)
next
  assume "aligned w 8"
  then show "w = Align__1 w 8"
    by (auto simp: Align__1_def Align__0_def aligned_def of_bl_bin_word_of_int)
qed

end
*)


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

 *)

Require Import approx_star0.

Lemma isprog_vars_iff_isprogram_bt {o} :
  forall vs (t : @NTerm o),
    isprog_vars vs t <=> isprogram_bt (bterm vs t).
Proof.
  introv.
  rw @isprog_vars_eq.
  unfold isprogram_bt; simpl.
  rw @bt_wf_iff.
  rw @closed_bt_bterm; sp.
Qed.

Lemma isprog_vars_implies_isprogram_bt {o} :
  forall vs (t : @NTerm o),
    isprog_vars vs t -> isprogram_bt (bterm vs t).
Proof.
  introv isp.
  apply isprog_vars_iff_isprogram_bt; auto.
Qed.
Hint Resolve isprog_vars_implies_isprogram_bt : slow.

Lemma alpha_eq_bterm_implies_eq_length {o} :
  forall vs1 vs2 (t1 t2 : @NTerm o),
    alpha_eq_bterm (bterm vs1 t1) (bterm vs2 t2)
    -> length vs1 = length vs2.
Proof.
  introv aeq.
  inversion aeq; subst; auto.
Qed.

Lemma isprogram_lsubst_aux_implies {o} :
  forall (t : @NTerm o) sub,
    disjoint_bv_sub t sub
    -> isprogram (lsubst_aux t sub)
    -> isprogram_bt (bterm (dom_sub sub) t).
Proof.
  introv d isp.
  apply isprog_vars_iff_isprogram_bt.
  apply isprog_vars_eq.
  destruct isp as [c w].
  apply lsubst_aux_nt_wf in w; dands; auto.
  rw subvars_prop; introv i.
  unfold closed in c.
  rw <- null_iff_nil in c.
  unfold null in c.
  destruct (in_deq _ deq_nvar x (dom_sub sub)) as [j|j]; auto.
  provefalse.
  pose proof (c x) as h; destruct h.
  pose proof (eqvars_free_vars_disjoint_aux2 t sub d) as h; auto.
  rw eqvars_prop in h; apply h; clear h.
  rw in_app_iff; rw in_remove_nvars; sp.
Qed.

Lemma isprogram_lsubst_implies {o} :
  forall (t : @NTerm o) sub,
    isprogram (lsubst t sub)
    -> isprogram_bt (bterm (dom_sub sub) t).
Proof.
  introv isp.
  pose proof (unfold_lsubst sub t) as h; exrepnd; rw h0 in isp.
  apply isprogram_lsubst_aux_implies in isp; auto.
  - allunfold @isprogram_bt.
    allunfold @closed_bt; allsimpl.
    applydup @alphaeq_preserves_free_vars in h1 as fv.
    rw fv; repnd; dands; auto.
    allrw @bt_wf_iff.
    apply alphaeq_preserves_wf in h1; apply h1; auto.
  - unfold disjoint_bv_sub, sub_range_sat; introv i j k.
    apply h2 in k; destruct k.
    apply in_sub_free_vars_iff.
    exists v t0; dands; auto.
Qed.

Lemma isprogram_subst_implies {o} :
    forall (t : @NTerm o) (v : NVar) (a : NTerm),
      isprogram (subst t v a)
      -> isprogram_bt (bterm [v] t).
Proof.
  introv isp.
  apply isprogram_lsubst_implies in isp; allsimpl; auto.
Qed.

Definition get_op {o} (t : @NTerm o) : Opid :=
  match t with
    | vterm _ => Exc
    | sterm _ => Exc
    | oterm op _ => op
  end.

Inductive same_value_like {o} lib : @NTerm o -> @NTerm o -> Type :=
| svl_c : forall c bs1 bs2, same_value_like lib (oterm (Can c) bs1) (oterm (Can c) bs2)
| svl_e : forall bs1 bs2, same_value_like lib (oterm Exc bs1) (oterm Exc bs2)
| svl_s :
    forall f1 f2,
      (*(forall n, alpha_eq (f1 n) (f2 n))*)
      (forall n, approx_star lib (f1 n) (f2 n))
      -> same_value_like lib (sterm f1) (sterm f2).
Hint Constructors same_value_like.

Lemma approx_starbts_nil {o} :
  forall lib (op : @Opid o), approx_starbts lib op [] [].
Proof.
  introv; unfold approx_starbts, lblift_sub; simpl; dands; tcsp.
Qed.
Hint Resolve approx_starbts_nil : slow.

Lemma howe_lemma2_implies_same_value_like {o} :
  forall lib (t u : @NTerm o),
    isprogram t
    -> isprogram u
    -> isvalue_like t
    -> approx_star lib t u
    -> {v : NTerm
        & same_value_like lib t v
        # approx_starbts lib (get_op t) (get_bterms t) (get_bterms v)
        # reduces_to lib u v}.
Proof.
  introv ispt ispu isv ap.
  unfold isvalue_like in isv; repndors.
  - apply iscan_implies in isv; repndors; exrepnd; subst.

    + pose proof (howe_lemma2 lib c bterms u) as h; simpl in h.
      repeat (autodimp h hyp).
      exrepnd.
      exists (oterm (Can c) lbt'); dands; eauto.
      unfold computes_to_value in h0; repnd; auto.

    + apply howe_lemma2_seq in ap; auto; exrepnd.
      exists (sterm f'); dands; simpl; eauto 3 with slow; tcsp.

  - apply isexc_implies2 in isv; exrepnd; subst.
    applydup @isprogram_exception_implies in ispt; exrepnd; subst.
    pose proof (howe_lemma2_exc lib a t u) as h; simpl in h.
    repeat (autodimp h hyp).
    exrepnd.
    exists (oterm Exc [bterm [] a', bterm [] e']); simpl; dands; auto.
    unfold approx_starbts, lblift_sub; simpl; dands; auto.
    introv k; repeat (destruct n; cpx).
    + unfold selectbt; simpl; eauto with slow.
    + unfold selectbt; simpl; eauto with slow.
Qed.

Lemma same_value_like_alpha_eq_r {o} :
  forall lib (t u v : @NTerm o),
    same_value_like lib t u
    -> alpha_eq u v
    -> same_value_like lib t v.
Proof.
  introv svl aeq.
  inversion svl as [| |? ? imp1]; clear svl; subst;
  inversion aeq as [|? ? imp2|]; clear aeq; subst; auto.
  constructor; introv; eauto 3 with slow.
Qed.

Lemma same_value_like_alpha_eq_l {o} :
  forall lib (t u v : @NTerm o),
    same_value_like lib t u
    -> alpha_eq t v
    -> same_value_like lib v u.
Proof.
  introv svl aeq.
  inversion svl as [| |? ? imp1]; clear svl; subst;
  inversion aeq as [|? ? imp2|]; clear aeq; subst; auto.
  constructor; introv; eauto 3 with slow.
Qed.

Lemma approx_starbts_get_bterms_alpha_eq {o} :
  forall lib op (t u v : @NTerm o),
    approx_starbts lib op (get_bterms t) (get_bterms u)
    -> alpha_eq u v
    -> approx_starbts lib op (get_bterms t) (get_bterms v).
Proof.
  introv ap aeq.
  destruct t as [v1|f1|op1 bs1]; destruct u as [v2|f2|op2 bs2]; allsimpl; auto;
  try (complete (inversion aeq; subst; allsimpl; tcsp)).
  - unfold approx_starbts, lblift_sub in ap; allsimpl; repnd; cpx.
    inversion aeq; subst; allsimpl; cpx; auto.
    unfold approx_starbts, lblift_sub; simpl; sp.
  - unfold approx_starbts, lblift_sub in ap; allsimpl; repnd; cpx.
    inversion aeq; subst; allsimpl; cpx; auto.
    unfold approx_starbts, lblift_sub; simpl; sp.
  - inversion aeq as [|?|? ? ? len imp]; subst; simpl.
    allunfold @approx_starbts.
    allunfold @lblift_sub; repnd; dands; auto; try omega.
    introv i.
    pose proof (ap n) as h1; autodimp h1 hyp.
    pose proof (imp n) as h2; autodimp h2 hyp; try omega.
    eapply approx_star_bterm_alpha_fun_r; eauto.
Qed.

(*
Lemma approx_star_congruence_same_value_like {o} :
  forall lib (t u : @NTerm o),
    isprogram t
    -> isprogram u
    -> same_value_like t u
    -> approx_starbts lib (get_op t) (get_bterms t) (get_bterms u)
    -> approx_star lib t u.
Proof.
  introv ispt ispu svl ap.
  destruct t as [v1|f1|op1 bs1]; destruct u as [v2|f2|op2 bs2]; allsimpl;
  try (complete (apply isprogram_vterm in ispt; sp));
  try (complete (apply isprogram_vterm in ispu; sp));
  try (complete (inversion svl)).
  - apply (apss _ _ _ f2); eauto 3 with slow.
  - inversion svl; subst; apply approx_star_congruence3; auto.
Qed.
*)

Lemma closed_axiom {o} :
  @closed o mk_axiom.
Proof. sp. Qed.
Hint Resolve closed_axiom : slow.

Lemma alpha_eq_subst_utoken_not_in_implies2 {o} :
  forall (t1 t2 : @NTerm o) v a,
    !LIn a (get_utokens t1)
    -> !LIn a (get_utokens t2)
    -> alpha_eq (subst t1 v (mk_utoken a)) (subst t2 v (mk_utoken a))
    -> alpha_eq t1 t2.
Proof.
  introv ni1 ni2 aeq.
  pose proof (change_bvars_alpha_wspec [v] t1) as k1.
  pose proof (change_bvars_alpha_wspec [v] t2) as k2.
  exrepnd.
  allrw disjoint_singleton_l.
  pose proof (lsubst_alpha_congr2 ntcv0 t1 [(v,mk_utoken a)]) as p1.
  pose proof (lsubst_alpha_congr2 ntcv t2 [(v,mk_utoken a)]) as p2.
  autodimp p1 hyp; autodimp p2 hyp; eauto 3 with slow.
  allrw @fold_subst.
  assert (alpha_eq (subst ntcv0 v (mk_utoken a)) (subst ntcv v (mk_utoken a))) as h' by eauto with slow.
  apply alpha_eq_subst_utoken_not_in_implies in h'; eauto with slow.
  { intro j; destruct ni1; apply alphaeq_preserves_utokens in k3; rw k3; auto. }
  { intro j; destruct ni2; apply alphaeq_preserves_utokens in k0; rw k0; auto. }
Qed.

Lemma isprogram_pushdown_fresh {o} :
  forall v (t : @NTerm o),
    isprogram (pushdown_fresh v t) <=> isprog_vars [v] t.
Proof.
  introv; split; intro k.
  - destruct k as [c w].
    rw @isprog_vars_eq.
    apply nt_wf_pushdown_fresh in w; dands; auto.
    unfold closed in c.
    rw @free_vars_pushdown_fresh in c.
    rw subvars_prop; introv i.
    rw <- null_iff_nil in c.
    rw null_remove_nvars in c; apply c in i; sp.
  - rw @isprog_vars_eq in k; repnd.
    split; allrw @nt_wf_pushdown_fresh; auto.
    unfold closed; rw @free_vars_pushdown_fresh.
    rw <- null_iff_nil.
    rw null_remove_nvars; introv i.
    rw subvars_prop in k0; apply k0; auto.
Qed.

Lemma same_value_like_implies_same_op {o} :
  forall lib op1 op2 (bs1 bs2 : list (@BTerm o)),
    same_value_like lib (oterm op1 bs1) (oterm op2 bs2)
    -> op1 = op2.
Proof.
  introv s; inversion s; auto.
Qed.

Lemma fresh_id_approx_any {o} :
  forall lib (t : @NTerm o) x,
    isprogram t
    -> approx lib (mk_fresh x (mk_var x)) t.
Proof.
  introv Hpr.
  apply approx_assume_hasvalue; auto.
  { apply isprogram_fresh; apply isprog_vars_var. }

  introv Hv.
  unfold hasvalue_like in Hv; exrepnd.
  apply (not_fresh_id_reduces_to_is_value_like _ _ x) in Hv1; tcsp.
Qed.

Lemma change_bvars_alpha_norep {o} :
  forall (t : @NTerm o) (lv : list NVar),
    {u : NTerm
     $ disjoint lv (bound_vars u)
     # alpha_eq t u
     # no_repeats (bound_vars u)}.
Proof.
  nterm_ind1s t as [v|f ind|op bs ind] Case; introv.

  - Case "vterm".
    exists (@mk_var o v); simpl; dands; auto.

  - Case "sterm".
    exists (sterm f); simpl; dands; eauto 3 with slow.

  - Case "oterm".

    assert (forall lv, {bs' : list BTerm
            $ disjoint lv (bound_vars_bterms bs')
            # alpha_eq_bterms bs bs'
            # no_repeats (bound_vars_bterms bs') }) as ibs.
    { clear lv; induction bs; introv; allsimpl.
      - exists ([] : list (@BTerm o)); simpl; dands; eauto with slow.
      - autodimp IHbs hyp.
        { introv i s; eapply ind; eauto. }
        pose proof (IHbs lv) as ibs; clear IHbs; exrepnd.
        destruct a as [l t].

        pose proof (fresh_vars (length l)
                               (lv ++ l
                                   ++ all_vars t
                                   ++ bound_vars_bterms bs'))
             as fvs; exrepnd.
        allrw disjoint_app_r; exrepnd.

        pose proof (ind t (lsubst t (var_ren l lvn)) l) as ih; clear ind; repeat (autodimp ih hyp).
        { rw @lsubst_allvars_preserves_osize2; eauto 3 with slow. }

        pose proof (ih (lv ++ lvn ++ bound_vars_bterms bs')) as ht; clear ih.
        exrepnd.
        allrw disjoint_app_l; repnd.

        exists (bterm lvn u :: bs'); simpl.
        allrw no_repeats_app.
        allrw disjoint_app_l; allrw disjoint_app_r.
        dands; eauto 3 with slow.
        apply alpha_eq_bterms_cons; dands; auto.
        eapply alpha_eq_bterm_trans;[|apply alpha_eq_bterm_congr;exact ht2].
        apply alpha_bterm_change; auto.
        allrw disjoint_app_l; dands; eauto with slow.
    }

    pose proof (ibs lv) as h; clear ibs; exrepnd.
    exists (oterm op bs'); simpl; dands; auto.
    apply alpha_eq_oterm_combine; auto.
Qed.

Lemma blift_sub_diff {o} :
  forall vs lib op (b1 b2 : @BTerm o),
    blift_sub op (approx_star lib) b1 b2
    -> {lv : list NVar
        $ {nt1,nt2 : NTerm
        $ (
            (op <> NCan NFresh # approx_star lib nt1 nt2)
            [+]
            {sub : Sub
             & op = NCan NFresh
             # approx_star lib (lsubst nt1 sub) (lsubst nt2 sub)
             # nrut_sub (get_utokens nt1 ++ get_utokens nt2) sub
             # lv = dom_sub sub}
          )
        # alpha_eq_bterm b1 (bterm lv nt1)
        # alpha_eq_bterm b2 (bterm lv nt2)
        # disjoint vs lv
        # disjoint vs (bound_vars nt1)
        # disjoint vs (bound_vars nt2)
        # disjoint lv (bound_vars nt1)
        # disjoint lv (bound_vars nt2)
        # no_repeats lv
        # no_repeats (bound_vars nt1)
        # no_repeats (bound_vars nt2) }}.
Proof.
  introv bl.
  unfold blift_sub in bl; exrepnd.

  pose proof (alpha_bterm_pair_change b1 b2 lv nt1 nt2 vs) as h.
  repeat (autodimp h hyp); exrepnd.
  allrw disjoint_app_r; allrw disjoint_app_l; repnd.

  pose proof (change_bvars_alpha_norep nt1n (vs ++ lvn)) as ch1; exrepnd.
  assert (alpha_eq nt1 u) as h2' by eauto with slow.
  assert (alpha_eq_bterm b1 (bterm lvn (lsubst u (var_ren lv lvn)))) as h4'.
  { eapply alpha_eq_bterm_trans;[exact h4|].
    apply alpha_eq_bterm_congr.
    apply lsubst_alpha_congr2; auto. }
  allrw disjoint_app_l; repnd.
  rename ch3 into h9'.
  rename ch1 into h13'.
  clear dependent nt1n.
  rename h2' into h2; rename h4' into h4; rename h9' into h9; rename h13' into h13.
  rename u into nt1n.

  pose proof (change_bvars_alpha_norep nt2n (vs ++ lvn)) as ch'1; exrepnd.
  assert (alpha_eq nt2 u) as h3' by eauto with slow.
  assert (alpha_eq_bterm b2 (bterm lvn (lsubst u (var_ren lv lvn)))) as h5'.
  { eapply alpha_eq_bterm_trans;[exact h5|].
    apply alpha_eq_bterm_congr.
    apply lsubst_alpha_congr2; auto. }
  allrw disjoint_app_l; repnd.
  rename ch'3 into h0'.
  rename ch'1 into h7'.
  clear dependent nt2n.
  rename h3' into h3; rename h5' into h5; rename h7' into h7; rename h0' into h0.
  rename u into nt2n.

  exists lvn (lsubst nt1n (var_ren lv lvn)) (lsubst nt2n (var_ren lv lvn)).
  dands; eauto 3 with slow; try (complete (rw @boundvars_lsubst_vars; auto)).

  repndors; exrepnd.

  - left; dands; auto.
    apply approx_star_lsubst_vars; eauto 3 with slow.

  - right.
    exists (combine lvn (range sub)); dands; auto.

    + pose proof (lsubst_nest_same_alpha2 nt1n lv lvn (range sub)) as nest1.
      allrw @length_dom; allrw @length_range.
      repeat (autodimp nest1 hyp); try omega; eauto 3 with slow.
      { subst; allrw @length_dom; auto. }
      { apply alphaeq_preserves_free_vars in h2; rw <- h2.
        apply disjoint_remove_nvars_weak_r; auto. }
      eapply approx_star_alpha_fun_l;[|apply alpha_eq_sym; exact nest1].

      pose proof (lsubst_nest_same_alpha2 nt2n lv lvn (range sub)) as nest2.
      allrw @length_dom; allrw @length_range.
      repeat (autodimp nest2 hyp); try omega; eauto 3 with slow.
      { subst; allrw @length_dom; auto. }
      { apply alphaeq_preserves_free_vars in h3; rw <- h3.
        apply disjoint_remove_nvars_weak_r; auto. }
      eapply approx_star_alpha_fun_r;[|apply alpha_eq_sym; exact nest2].

      subst.
      rw <- @sub_eta; auto.

      apply (lsubst_alpha_congr2 _ _ sub) in h2.
      apply (lsubst_alpha_congr2 _ _ sub) in h3.
      eauto with slow.

    + repeat (rw @get_utokens_lsubst_allvars; eauto with slow).
      apply alphaeq_preserves_utokens in h2.
      apply alphaeq_preserves_utokens in h3.
      rw <- h2; rw <- h3.
      eapply nrut_sub_change_sub_same_range;[|exact bl5].
      rw @range_combine; auto.
      rw @length_range; auto.
      subst; allrw @length_dom; auto.

    + rw @dom_sub_combine; auto.
      rw @length_range; auto.
      subst; allrw @length_dom; auto.
Qed.

Lemma bt_wf_mk_fresh_bterm_if {o} :
  forall (b : @BTerm o) v,
    bt_wf b
    -> bt_wf (mk_fresh_bterm v b).
Proof.
  introv wf.
  destruct b as [l t]; allsimpl.
  allrw @bt_wf_iff.
  apply nt_wf_fresh; auto.
Qed.

Lemma alpha_eq_bterm_ren_1side {o} :
  forall (t1 t2 : @NTerm o) l1 l2,
    disjoint l1 (bound_vars t1)
    -> disjoint l1 (bound_vars t2)
    -> alpha_eq_bterm (bterm l1 t1) (bterm l2 t2)
    -> alpha_eq_bterm (bterm l1 t1) (bterm l1 (lsubst t2 (var_ren l2 l1))).
Proof.
  introv disj1 disj2 aeq.
  inversion aeq as [? ? ? ? ? disj len1 len2 norep a]; subst.
  apply (lsubst_alpha_congr2 _ _ (var_ren lv l1)) in a.
  allrw disjoint_app_r; repnd.

  pose proof (lsubst_nest_vars_same t1 l1 lv l1) as h1.
  allrw disjoint_app_l.
  repeat (autodimp h1 hyp); dands; eauto 3 with slow.
  rw h1 in a.

  pose proof (lsubst_nest_vars_same t2 l2 lv l1) as h2.
  allrw disjoint_app_l.
  repeat (autodimp h2 hyp); dands; try omega; eauto 3 with slow.
  rw h2 in a.

  pose proof (lsubst_trivial_alpha t1 l1) as h.
  eauto with slow.
Qed.

Lemma alpha_eq_bterm_ren_1side2 {o} :
  forall (t1 t2 : @NTerm o) l1 l2,
    disjoint l1 (bound_vars t1)
    -> disjoint l1 (bound_vars t2)
    -> alpha_eq_bterm (bterm l1 t1) (bterm l2 t2)
    -> alpha_eq t1 (lsubst t2 (var_ren l2 l1)).
Proof.
  introv disj1 disj2 aeq.
  inversion aeq as [? ? ? ? ? disj len1 len2 norep a]; subst.
  apply (lsubst_alpha_congr2 _ _ (var_ren lv l1)) in a.
  allrw disjoint_app_r; repnd.

  pose proof (lsubst_nest_vars_same t1 l1 lv l1) as h1.
  allrw disjoint_app_l.
  repeat (autodimp h1 hyp); dands; eauto 3 with slow.
  rw h1 in a.

  pose proof (lsubst_nest_vars_same t2 l2 lv l1) as h2.
  allrw disjoint_app_l.
  repeat (autodimp h2 hyp); dands; try omega; eauto 3 with slow.
  rw h2 in a.

  pose proof (lsubst_trivial_alpha t1 l1) as h.
  eauto with slow.
Qed.

Lemma alpha_eq_lsubst_aux_pull_out_token {o} :
  forall (t : @NTerm o) l sub t',
    disjoint (dom_sub sub) (bound_vars t)
    -> disjoint (dom_sub sub) (bound_vars t')
    -> disjoint (bound_vars t) (bound_vars t')
    -> no_repeats (bound_vars t)
    -> nrut_sub l sub
    -> subset (get_utokens t') l
    -> no_repeats (dom_sub sub)
    -> wf_term t
    -> alpha_eq t (lsubst_aux t' sub)
    -> {u : NTerm $ t = lsubst_aux u sub # disjoint (get_utokens u) (get_utokens_sub sub)}.
Proof.
  nterm_ind t as [x|f ind|op bs ind] Case;
  introv disj1 disj2 disj3 norep nrut ss nrs wf aeq;
  allsimpl; GC.

  - Case "vterm".
    destruct t' as [z|f|op' bs']; allsimpl;
    try (complete (inversion aeq)).

    remember (sub_find sub z) as sf; symmetry in Heqsf; destruct sf.

    + apply sub_find_some in Heqsf.
      eapply in_nrut_sub in Heqsf; eauto; exrepnd; subst; inversion aeq.
    + inversion aeq; subst.
      exists (@mk_var o z); simpl; boolvar; tcsp.
      rw Heqsf; auto.

  - Case "sterm".
    exists (sterm f); simpl; dands; auto.

  - Case "oterm".
    destruct t' as [z|f|op' bs']; allsimpl; try (complete (inversion aeq)).

    + remember (sub_find sub z) as sf; symmetry in Heqsf; destruct sf;
      try (complete (inversion aeq)).

      apply sub_find_some in Heqsf.
      eapply in_nrut_sub in Heqsf; eauto; exrepnd; subst; inversion aeq; subst.
      allsimpl; cpx; allsimpl; fold_terms.

      pose proof (in_nrut_sub_or l a sub) as ora.
      repeat (autodimp ora hyp); repndors; exrepnd.

      { exists (@mk_var o v); simpl; allrw; dands; auto. }

      { exists (mk_utoken a); simpl; auto.
        rw disjoint_singleton_l; dands; auto. }

    + allrw @alpha_eq_oterm_combine2; repnd; subst.
      allrw map_length.

      rw @wf_oterm_iff in wf; repnd.

      assert {bs'' : list BTerm
              & bs = lsubst_bterms_aux bs'' sub
              # disjoint (get_utokens_bs bs'') (get_utokens_sub sub)} as hbs.
      { clear wf0.
        revert dependent bs'.
        revert dependent bs.
        induction bs as [|b bs]; introv ind disj1 norep wf disj2 disj3 ss len imp; allsimpl; cpx; GC.

        - exists ([] : list (@BTerm o)); simpl; auto.

        - destruct bs' as [|b' bs']; allsimpl; cpx.
          allrw in_app_iff; allrw not_over_or; repnd.
          allrw no_repeats_app; repnd.
          allrw disjoint_app_r; allrw disjoint_app_l; repnd.
          repeat (autodimp IHbs hyp).
          { introv i j k; eapply ind; eauto. }
          pose proof (IHbs bs') as ih; clear IHbs.
          repeat (autodimp ih IHbs); exrepnd.
          { allrw subset_app; repnd; dands; auto. }
          pose proof (imp b (lsubst_bterm_aux b' sub)) as h.
          repeat (autodimp h hyp).
          destruct b as [l1 t1].
          destruct b' as [l2 t2].
          allsimpl; allrw in_app_iff; allrw not_over_or; repnd.
          allrw disjoint_app_l; repnd.
          allrw no_repeats_app; repnd.
          allrw disjoint_app_r; allrw disjoint_app_l; repnd.
          applydup @alpha_eq_bterm_lenbvars in h.

          apply alpha_eq_bterm_ren_1side2 in h; auto;
          [|introv i j; apply subset_bound_vars_lsubst_aux in j; allsimpl;
            allrw in_app_iff; repndors; tcsp;
            [apply disj8 in i; sp|];
            rw (sub_bound_vars_nrut_sub (sub_filter sub l2) l) in j; allsimpl; tcsp;
            complete (eauto with slow)].
          pose proof (ind t1 l1) as k; clear ind; autodimp k hyp.

          rw @lsubst_lsubst_aux in h;
            [|rw <- @sub_free_vars_is_flat_map_free_vars_range;
               rw @sub_free_vars_var_ren; auto;
               introv i j; apply subset_bound_vars_lsubst_aux in i; allsimpl;
               allrw in_app_iff; applydup disj8 in j; repndors; tcsp;
               apply subset_sub_bound_vars_sub_filter in i;
               erewrite sub_bound_vars_nrut_sub in i; eauto].

          rw (sub_filter_disjoint1 sub) in h; eauto 3 with slow.

          pose proof (simple_lsubst_aux_lsubst_aux_sub_disj
                        t2 sub (var_ren l2 l1)) as e.
          allsimpl; rw @sub_free_vars_var_ren in e; auto.
          rw (sub_bound_vars_nrut_sub sub l) in e; eauto 3 with slow.
          rw (sub_free_vars_nrut_sub sub l) in e; eauto 3 with slow.
          rw @cl_lsubst_aux_sub_trivial in e; eauto 3 with slow.
          repeat (autodimp e hyp); eauto with slow.
          rw <-  e in h; clear e.

          pose proof (k l sub (lsubst_aux t2 (sub_filter (var_ren l2 l1) (dom_sub sub))))
            as ih; clear k.
          repeat (autodimp ih hyp); eauto 3 with slow.
          { introv i j; apply subset_bound_vars_lsubst_aux in j.
            rw @sub_bound_vars_allvars_sub in j; eauto 3 with slow.
            allrw app_nil_r; apply disj7 in i; sp. }
          { introv i j; apply subset_bound_vars_lsubst_aux in j.
            rw @sub_bound_vars_allvars_sub in j; eauto 3 with slow.
            allrw app_nil_r; apply disj5 in i; sp. }
          { allrw subset_app; repnd; rw @get_utokens_lsubst_aux_allvars; eauto 3 with slow. }
          { pose proof (wf (bterm l1 t1)) as w; autodimp w hyp. }

          exrepnd.
          exists (bterm l1 u :: bs''); simpl.
          allrw disjoint_app_l; dands; eauto 3 with slow.
          f_equal; auto.
          f_equal; auto.
          rw (sub_filter_disjoint1 sub); eauto 3 with slow.
      }

      exrepnd.

      remember (get_utok op') as guo; symmetry in Heqguo; destruct guo.

      { apply get_utok_some in Heqguo; subst; allsimpl.
        destruct bs''; allsimpl; cpx; GC; fold_terms.
        allrw subset_cons_l; repnd; allsimpl.
        exists (mk_utoken g); simpl; fold_terms; rw disjoint_singleton_l; dands; auto.
        unfold nrut_sub in nrut; repnd.
        apply nrut in ss0; sp.
      }

      { exists (oterm op' bs''); simpl; subst.
        allrw subset_app; repnd.
        allrw disjoint_app_l; dands; eauto 3 with slow.
        unfold lsubst_bterms_aux; auto.
        destruct op'; allsimpl; tcsp.
        destruct c; allsimpl; tcsp.
      }
Qed.

Lemma alpha_eq_subst_bterm_aux_pull_out_token {o} :
  forall b v a l (t : @NTerm o),
    !LIn v l
    -> !LIn v (bound_vars t)
    -> disjoint l (bound_vars t)
    -> no_repeats (bound_vars t)
    -> !LIn a (get_utokens_b b)
    -> wf_term t
    -> alpha_eq_bterm (subst_bterm_aux b v (mk_utoken a)) (bterm l t)
    -> {u : NTerm & t = subst u v (mk_utoken a) # !LIn a (get_utokens u)}.
Proof.
  introv ni1 ni2 disj1 norep niab wf aeq.

  pose proof (ex_change_bvars_bterm_alpha (v :: l ++ bound_vars t) b) as ch; exrepnd.
  allrw disjoint_cons_l; allrw disjoint_app_l; repnd.
  pose proof (lsubst_aux_alphabt_congr_cl b bt' [(v,mk_utoken a)] [(v,mk_utoken a)]) as aeqb.
  repeat (autodimp aeqb hyp); eauto with slow.
  eapply alpha_eq_bterm_trans in aeq;[|apply alpha_eq_bterm_sym; exact aeqb].
  assert (!LIn a (get_utokens_b bt')) as niabt'.
  { apply alpha_eq_bterm_preserves_utokens in ch0; rw <- ch0; auto. }
  clear dependent b; rename bt' into b.
  rename ch3 into disj2; rename ch2 into disj3; rename ch1 into ni3; rename niabt' into niab.

  destruct b as [l1 u1]; allsimpl.
  allrw disjoint_app_r; repnd.
  allunfold @subst_bterm_aux; allsimpl; boolvar.
  - allrw @lsubst_aux_nil.
    exists t.
    applydup @alpha_eq_bterm_preserves_utokens in aeq as eu; allsimpl; rw <- eu.
    apply alpha_eq_bterm_preserves_free_vars in aeq; allsimpl.
    rw @cl_subst_trivial; eauto with slow.
    introv i.
    assert (LIn v (remove_nvars l (free_vars t))) as j.
    { rw in_remove_nvars; sp. }
    rw <- aeq in j.
    rw in_remove_nvars in j; sp.
  - (* change the l1 into l when inverting aeq *)
    apply alpha_eq_bterm_sym in aeq.
    applydup @alpha_eq_bterm_lenbvars in aeq.
    apply alpha_eq_bterm_ren_1side2 in aeq; auto;
    [|introv i j; apply subset_bound_vars_lsubst_aux in j; allsimpl;
      allrw app_nil_r; apply disj2 in i; sp].
    rw @lsubst_lsubst_aux in aeq;
      [|rw <- @sub_free_vars_is_flat_map_free_vars_range;
         rw @sub_free_vars_var_ren; auto;
         introv i j; apply subset_bound_vars_lsubst_aux in i; allsimpl;
         allrw app_nil_r; apply disj2 in j; sp].

    pose proof (simple_lsubst_aux_lsubst_aux_sub_disj u1 [(v,mk_utoken a)] (var_ren l1 l)) as h.
    allsimpl.
    rw @sub_free_vars_var_ren in h; auto.
    allrw disjoint_singleton_l; fold_terms.
    repeat (autodimp h hyp); eauto 3 with slow.
    rw <-  h in aeq; clear h.

    pose proof (alpha_eq_lsubst_aux_pull_out_token
                  t (get_utokens u1) [(v,mk_utoken a)]
                  (lsubst_aux u1 (sub_filter (var_ren l1 l) [v]))) as h.
    allsimpl; allrw disjoint_singleton_l.
    repeat (autodimp h hyp); eauto 3 with slow.

    { intro i; apply subset_bound_vars_lsubst_aux in i; allrw in_app_iff.
      rw @sub_bound_vars_allvars_sub in i; eauto 3 with slow.
      allsimpl; repndors; tcsp. }

    { introv i j; apply subset_bound_vars_lsubst_aux in j; allrw in_app_iff.
      rw @sub_bound_vars_allvars_sub in j; eauto 3 with slow.
      allsimpl; repndors; tcsp.
      apply disj3 in i; sp. }

    { apply nrut_sub_cons; eexists; simpl; dands; eauto; tcsp; eauto with slow. }

    { rw @get_utokens_lsubst_aux_allvars; eauto with slow. }

    exrepnd; allsimpl.
    unfold get_utokens_sub in h0; allsimpl; allrw disjoint_singleton_r.
    exists u.
    unfsubst; dands; auto.
Qed.

Lemma alpha_eq_bterm_ren_1side3 {o} :
  forall (t1 t2 : @NTerm o) l1 l2,
    disjoint l1 (all_vars t2)
    -> length l1 = length l2
    -> no_repeats l1
    -> alpha_eq t1 (lsubst t2 (var_ren l2 l1))
    -> alpha_eq_bterm (bterm l1 t1) (bterm l2 t2).
Proof.
  introv disj1 len norep aeq.
  pose proof (fresh_vars (length l1) (l1 ++ l2
                                         ++ all_vars t1
                                         ++ all_vars t2))
    as fvs; exrepnd; allrw disjoint_app_r; repnd.
  apply (al_bterm _ _ lvn); allrw disjoint_app_r; auto.
  apply (lsubst_alpha_congr2 _ _ (var_ren l1 lvn)) in aeq.
  pose proof (lsubst_nest_vars_same t2 l2 l1 lvn) as h.
  repeat (autodimp h hyp); allrw disjoint_app_l; dands; auto.
  rw h in aeq; eauto with slow.
Qed.

Definition maybe_new_var_b {o} (v : NVar) (b : @BTerm o) :=
  match b with
    | bterm l t => maybe_new_var v l t
  end.

Lemma in_nrut_sub_eq {o} :
  forall (sub: @Sub o) v1 v2 t l,
    nrut_sub l sub
    -> LIn (v1, t) sub
    -> LIn (v2, t) sub
    -> v1 = v2.
Proof.
  induction sub; introv nrut ni1 ni2; allsimpl; tcsp.
  destruct a as [v u].
  allrw @nrut_sub_cons; exrepnd; subst.
  repndors; subst; tcsp; cpx.
  - destruct nrut2; rw lin_flat_map.
    apply in_sub_eta in ni2; repnd.
    eexists; dands; eauto; simpl; tcsp.
  - destruct nrut2; rw lin_flat_map.
    apply in_sub_eta in ni1; repnd.
    eexists; dands; eauto; simpl; tcsp.
  - eapply IHsub; eauto.
Qed.

Lemma eqset_preserves_null {T} :
  forall (s1 s2 : list T),
    eqset s1 s2
    -> null s1
    -> null s2.
Proof.
  introv eqs n i.
  apply eqs in i.
  apply n in i; sp.
Qed.

Lemma null_get_utokens_sub_keep_first_free_vars_eq {o} :
  forall l (t : @NTerm o) sub,
    nrut_sub l sub
    -> null (get_utokens_sub (sub_keep_first sub (free_vars t)))
    -> lsubst_aux t sub = t.
Proof.
  nterm_ind t as [v|f ind|op bs ind] Case; introv nrut nu; allsimpl; auto.

  - Case "vterm".
    remember (sub_find sub v) as sf; symmetry in Heqsf; destruct sf; auto.
    unfold get_utokens_sub in nu.
    allrw @null_flat_map.
    applydup @sub_find_some in Heqsf.
    pose proof (nu n) as h; clear nu.
    eapply in_nrut_sub in nrut; eauto; exrepnd; subst; allsimpl.
    autodimp h hyp.

    + apply in_range_iff; exists v.
      apply in_sub_keep_first; simpl; tcsp.

    + pose proof (h a) as q; allsimpl; destruct q; tcsp.

  - Case "oterm".
    f_equal.
    apply eq_map_l; introv i.
    destruct x as [vs t]; allsimpl.
    f_equal.
    eapply ind;[eauto| |]; eauto 3 with slow.
    introv j.
    allrw @in_get_utokens_sub; exrepnd.
    allrw @in_sub_keep_first; repnd.
    allrw @sub_find_sub_filter_eq; boolvar; ginv.
    destruct (nu x).
    apply in_get_utokens_sub.
    exists v t0; dands; auto.
    apply in_sub_keep_first; dands; auto.
    apply lin_flat_map.
    eexists; dands; eauto.
    simpl; rw in_remove_nvars; sp.
Qed.

Lemma alpha_eq_lsubst_aux_nrut_sub_implies {o} :
  forall (t1 t2 : @NTerm o) sub l,
    nrut_sub l sub
    -> subset (get_utokens t1) l
    -> subset (get_utokens t2) l
    -> disjoint (dom_sub sub) (bound_vars t1)
    -> disjoint (dom_sub sub) (bound_vars t2)
    -> alpha_eq (lsubst_aux t1 sub) (lsubst_aux t2 sub)
    -> alpha_eq t1 t2.
Proof.
  nterm_ind1s t1 as [v1|f1 ind1|op1 bs1 ind1] Case;
  introv nrut ss1 ss2 disj1 disj2 aeq; allsimpl.

  - Case "vterm".
    remember (sub_find sub v1) as sf; symmetry in Heqsf; destruct sf.

    + apply sub_find_some in Heqsf.
      dup Heqsf as i.
      eapply in_nrut_sub in i; eauto; exrepnd; subst.
      destruct t2 as [v2|f2|op2 bs2]; allsimpl;
      try (complete (inversion aeq)).

      * remember (sub_find sub v2) as sf'; symmetry in Heqsf'; destruct sf'.

        { apply sub_find_some in Heqsf'.
          dup Heqsf' as j.
          eapply in_nrut_sub in j; eauto; exrepnd; subst.
          inversion aeq; subst; allsimpl; GC.
          apply (in_nrut_sub_eq sub v1 v2 (mk_utoken a0) l) in nrut; auto; subst; auto. }

        { inversion aeq. }

      * inversion aeq; subst; allsimpl; cpx; destruct bs2; allsimpl; cpx; GC; fold_terms.
        allrw singleton_subset; tcsp.

    + apply sub_find_none2 in Heqsf.
      destruct t2 as [v2|f2|op2 bs2]; allsimpl;
      try (complete (inversion aeq)).

      remember (sub_find sub v2) as sf'; symmetry in Heqsf'; destruct sf'.

      { apply sub_find_some in Heqsf'.
        dup Heqsf' as j.
        eapply in_nrut_sub in j; eauto; exrepnd; subst.
        inversion aeq. }

      { inversion aeq; subst; auto. }

  - Case "sterm".
    applydup @alphaeq_preserves_utokens in aeq; allsimpl.
    symmetry in aeq0; apply null_iff_nil in aeq0.
    eapply eqset_preserves_null in aeq0;[|apply get_utokens_lsubst_aux].
    allrw @null_app; repnd.
    erewrite null_get_utokens_sub_keep_first_free_vars_eq in aeq; eauto.

  - Case "oterm".
    allrw subset_app; repnd.
    destruct t2 as [v2|f2|op2 bs2]; allsimpl; try (complete (inversion aeq)).

    + remember (sub_find sub v2) as sf'; symmetry in Heqsf'; destruct sf'.

      { apply sub_find_some in Heqsf'.
        dup Heqsf' as j.
        eapply in_nrut_sub in j; eauto; exrepnd; subst.
        inversion aeq; subst; allsimpl; destruct bs1; allsimpl; cpx; GC; fold_terms.
        allrw singleton_subset; tcsp. }

      { inversion aeq. }

    + apply alpha_eq_oterm_combine2 in aeq; allrw map_length; repnd; subst.
      apply alpha_eq_oterm_combine; dands; auto.
      introv i.
      pose proof (aeq (lsubst_bterm_aux b1 sub) (lsubst_bterm_aux b2 sub)) as aeqb; clear aeq.
      rw <- @map_combine in aeqb.
      rw in_map_iff in aeqb.
      autodimp aeqb hyp.
      { eexists; dands; eauto. }
      applydup in_combine in i; repnd; disj_flat_map.
      destruct b1 as [l1 t1]; destruct b2 as [l2 t2]; allsimpl.
      allrw disjoint_app_r; repnd.
      allrw subset_app; repnd.

      repeat (rw @sub_filter_disjoint1 in aeqb; eauto 3 with slow).

      pose proof (fresh_vars
                    (length l1)
                    (all_vars (lsubst_aux t1 sub)
                              ++ all_vars (lsubst_aux t2 sub)
                              ++ dom_sub sub
                              ++ bound_vars t1
                              ++ bound_vars t2
                              ++ free_vars t1
                              ++ free_vars t2))
        as fvs; exrepnd; allrw disjoint_app_r; repnd.

      pose proof (alphabt_change_var_aux
                    (lsubst_aux t1 sub) (lsubst_aux t2 sub) l1 l2) lvn
        as a.
      allrw disjoint_app_r; repeat (autodimp a hyp); dands; eauto 3 with slow.
      repnd.

      pose proof (simple_lsubst_aux_lsubst_aux_sub_disj
                    t1 sub (var_ren l1 lvn)) as e1.
      rw @sub_free_vars_var_ren in e1; auto.
      rw @cl_lsubst_aux_sub_trivial in e1; eauto 3 with slow.
      erewrite sub_bound_vars_nrut_sub in e1; eauto 3 with slow.
      erewrite sub_free_vars_nrut_sub in e1; eauto 3 with slow.
      rw @sub_filter_disjoint1 in e1;[|rw @dom_sub_var_ren; eauto with slow]; auto.
      repeat (autodimp e1 hyp); eauto 3 with slow.

      pose proof (simple_lsubst_aux_lsubst_aux_sub_disj
                    t2 sub (var_ren l2 lvn)) as e2.
      rw @sub_free_vars_var_ren in e2; auto; try omega.
      rw @cl_lsubst_aux_sub_trivial in e2; eauto 3 with slow.
      erewrite sub_bound_vars_nrut_sub in e2; eauto 3 with slow.
      erewrite sub_free_vars_nrut_sub in e2; eauto 3 with slow.
      rw @sub_filter_disjoint1 in e2;[|rw @dom_sub_var_ren; eauto with slow]; auto; try omega.
      repeat (autodimp e2 hyp); eauto 3 with slow.

      rw <- e1 in a0; rw <- e2 in a0; clear e1 e2.

      pose proof (ind1 t1 (lsubst_aux t1 (var_ren l1 lvn)) l1) as q; clear ind1.
      repeat (autodimp q hyp).
      { rw @lsubst_aux_allvars_preserves_osize2; eauto 2 with slow. }
      pose proof (q (lsubst_aux t2 (var_ren l2 lvn)) sub l) as ih; clear q.
      repeat (rw @get_utokens_lsubst_aux_allvars in ih; eauto 3 with slow).
      repeat (rw @boundvars_lsubst_aux_vars in ih; auto; try omega).
      repeat (autodimp ih hyp); eauto 3 with slow.
      { introv z1; apply ss1; rw lin_flat_map; eexists; dands; eauto. }
      { introv z1; apply ss2; rw lin_flat_map; eexists; dands; eauto. }
      apply (al_bterm _ _ lvn); allrw disjoint_app_r; dands; auto.

      repeat (rw @lsubst_lsubst_aux); auto;
      rw <- @sub_free_vars_is_flat_map_free_vars_range;
      rw @computation2.sub_free_vars_var_ren; eauto 3 with slow; try omega.
Qed.

Lemma alpha_eq_bterm_mk_fresh_bterm_berm {o} :
  forall (b : @BTerm o) v a l t,
    disjoint l (all_vars_bterm b)
    -> disjoint l (bound_vars t)
    -> !LIn v l
    -> !LIn (maybe_new_var_b v b) l
    -> no_repeats l
    -> !LIn a (get_utokens t)
    -> !LIn a (get_utokens_b b)
    -> alpha_eq_bterm (subst_bterm_aux b v (mk_utoken a))
                      (bterm l (subst t v (mk_utoken a)))
    -> alpha_eq_bterm (mk_fresh_bterm v b) (bterm l (mk_fresh v t)).
Proof.
  introv disj1 disj2 ni1 ni2 norep nia1 nia2 aeqb.
  destruct b as [l' t'].
  unfold mk_fresh_bterm.
  apply alpha_eq_bterm_sym.
  allsimpl; allrw disjoint_app_r; repnd.
  applydup @alphaeqbt_numbvars in aeqb as len.
  unfold num_bvars in len; allsimpl.

  apply alpha_eq_bterm_sym in aeqb.
  unfold subst_bterm_aux in aeqb; allsimpl.
  apply alpha_eq_bterm_ren_1side2 in aeqb;
    [|unfold subst; rw @cl_lsubst_lsubst_aux; eauto 3 with slow;
      rw (@bound_vars_lsubst_aux_nrut_sub o t [(v,mk_utoken a)] []);
      eauto 3 with slow;
      apply nrut_sub_cons; eexists; dands; simpl; eauto with slow; tcsp
     |boolvar; allrw @lsubst_aux_nil; auto;
      rw (@bound_vars_lsubst_aux_nrut_sub o t' [(v,mk_utoken a)] []);
      eauto 3 with slow;
      apply nrut_sub_cons; eexists; dands; simpl; eauto with slow; tcsp].

  apply alpha_eq_bterm_ren_1side3; auto.
  { unfold all_vars; simpl; allrw app_nil_r.
    allrw disjoint_app_r; allrw disjoint_cons_r; dands; auto.
    apply disjoint_remove_nvars_weak_r; auto. }

  rw @lsubst_lsubst_aux; simpl; fold_terms;
  [|rw app_nil_r; rw <- @sub_free_vars_is_flat_map_free_vars_range;
    rw @sub_free_vars_var_ren; auto;
    apply disjoint_cons_l; dands; complete (eauto with slow)].

  allunfold @maybe_new_var.
  boolvar.

  - allrw @lsubst_aux_nil.
    assert (!LIn v (free_vars t)) as nivt.
    { intro i; apply alphaeq_preserves_utokens in aeqb.
      rw (get_utokens_lsubst_allvars t') in aeqb; eauto 3 with slow.
      rw <- aeqb in nia2; destruct nia2.
      apply get_utokens_lsubst; rw in_app_iff; sp; simpl.
      boolvar; tcsp. }
    rw @cl_subst_trivial in aeqb; eauto 3 with slow.
    rw @lsubst_aux_sub_filter_aux; simpl;
    [|introv i j; repndors; tcsp; subst;
      rw @dom_sub_var_ren; auto;
      apply newvar_prop in i; complete sp].

    dup aeqb as aeq.
    apply (implies_alpha_eq_mk_fresh v) in aeqb.
    rw <- @lsubst_lsubst_aux;
      [|rw <- @sub_free_vars_is_flat_map_free_vars_range;
         rw @sub_free_vars_var_ren; complete (eauto with slow)].
    eapply alpha_eq_trans;[exact aeqb|].

    pose proof (ex_fresh_var (all_vars (lsubst t' (var_ren l' l)))) as fv; exrepnd.
    apply (implies_alpha_eq_mk_fresh_sub v0); allrw in_app_iff; allrw not_over_or; repnd; tcsp.
    repeat (rw (lsubst_trivial3 (lsubst t' (var_ren l' l)))); auto.

    { introv i; apply in_var_ren in i; allsimpl; exrepnd; repndors; tcsp; subst; allsimpl.
      rw disjoint_singleton_l; dands; auto.
      intro j.
      pose proof (eqvars_free_vars_disjoint t' (var_ren l' l)) as e.
      rw eqvars_prop in e; apply e in j; clear e.
      rw @dom_sub_var_ren in j; auto.
      rw in_app_iff in j; rw in_remove_nvars in j; repndors; exrepnd; tcsp.
      - apply newvar_prop in j0; sp.
      - apply in_sub_free_vars in j; exrepnd.
        apply in_sub_keep_first in j0; repnd.
        apply sub_find_some in j2.
        apply in_var_ren in j2; exrepnd; subst; allsimpl; repndors; tcsp; subst; tcsp.
    }

    { introv i; apply in_var_ren in i; allsimpl; exrepnd; repndors; tcsp; subst; allsimpl.
      rw disjoint_singleton_l; dands; auto.
      intro j.
      pose proof (eqvars_free_vars_disjoint t' (var_ren l' l)) as e.
      rw eqvars_prop in e; apply e in j; clear e.
      rw @dom_sub_var_ren in j; auto.
      rw in_app_iff in j; rw in_remove_nvars in j; repndors; exrepnd; tcsp.
      apply in_sub_free_vars in j; exrepnd.
      apply in_sub_keep_first in j0; repnd.
      apply sub_find_some in j2.
      apply in_var_ren in j2; exrepnd; subst; allsimpl; repndors; tcsp; subst; tcsp.
    }

  - rw @lsubst_lsubst_aux in aeqb;
    [|rw <- @sub_free_vars_is_flat_map_free_vars_range;
       rw @sub_free_vars_var_ren; try (complete (eauto 3 with slow));
       rw (@bound_vars_lsubst_aux_nrut_sub o t' [(v,mk_utoken a)] []);
       eauto 3 with slow;
       apply nrut_sub_cons; eexists; dands; simpl; eauto with slow; tcsp].

    pose proof (simple_lsubst_aux_lsubst_aux_sub_disj
                  t' [(v,mk_utoken a)] (var_ren l' l)) as e; allsimpl.
    allrw disjoint_singleton_l.
    rw @sub_free_vars_var_ren in e; try (complete (eauto 3 with slow)).
    repeat (autodimp e hyp); eauto 2 with slow; fold_terms.
    rw <- e in aeqb; clear e.
    apply implies_alpha_eq_mk_fresh.
    remember (lsubst_aux t' (sub_filter (var_ren l' l) [v])) as t''.
    unfold subst in aeqb; rw @cl_lsubst_lsubst_aux in aeqb; eauto 2 with slow.

    assert (!LIn a (get_utokens t'')) as niat''.
    { subst; intro i.
      apply get_utokens_lsubst_aux in i; allrw in_app_iff; repndors; tcsp.
      rw @get_utokens_sub_allvars_sub in i; allsimpl; eauto with slow.
    }

    clear Heqt''.

    pose proof (change_bvars_alpha_wspec [v] t) as aeqt; exrepnd.
    pose proof (change_bvars_alpha_wspec [v] t'') as aeqt'; exrepnd.
    allrw disjoint_singleton_l.

    assert (alpha_eq (lsubst_aux t [(v, mk_utoken a)])
                     (lsubst_aux ntcv [(v, mk_utoken a)])) as aeq1.
    { apply computation2.lsubst_aux_alpha_congr_same_cl_sub; eauto 3 with slow. }

    assert (alpha_eq (lsubst_aux t'' [(v, mk_utoken a)])
                     (lsubst_aux ntcv0 [(v, mk_utoken a)])) as aeq2.
    { apply computation2.lsubst_aux_alpha_congr_same_cl_sub; eauto 3 with slow. }

    assert (alpha_eq (lsubst_aux ntcv [(v, mk_utoken a)])
                     (lsubst_aux ntcv0 [(v, mk_utoken a)])) as aeq3.
    { eapply alpha_eq_trans;[apply alpha_eq_sym; exact aeq1|].
      eapply alpha_eq_trans;[exact aeqb|].
      eauto with slow. }
    clear aeq1 aeq2.

    assert (alpha_eq ntcv ntcv0) as aeq;[|eauto 4 with slow];[].

    apply (alpha_eq_lsubst_aux_nrut_sub_implies
             _ _ _ (get_utokens ntcv ++ get_utokens ntcv0)) in aeq3;
      simpl; eauto 3 with slow; allrw disjoint_singleton_l; auto.

    apply alphaeq_preserves_utokens in aeqt0.
    apply alphaeq_preserves_utokens in aeqt'0.
    rw aeqt0 in nia1.
    rw aeqt'0 in niat''.
    apply nrut_sub_cons; eexists; dands; simpl; eauto; tcsp; eauto 3 with slow.
    rw in_app_iff; tcsp.
Qed.

Lemma alpha_eq_bterm_preserves_isprog_vars {o} :
  forall l1 l2 (t1 t2 : @NTerm o),
    alpha_eq_bterm (bterm l1 t1) (bterm l2 t2)
    -> isprog_vars l1 t1
    -> isprog_vars l2 t2.
Proof.
  introv aeq isp.
  allrw @isprog_vars_eq; repnd.
  applydup @alphaeqbt_preserves_nt_wf in aeq as w.
  rw w; dands; auto.
  apply alphaeqbt_preserves_fvars in aeq; allsimpl.
  rw eqvars_prop in aeq.
  allrw subvars_prop.
  introv i.
  destruct (in_deq _ deq_nvar x l2) as [d|d]; auto.
  assert (LIn x (remove_nvars l2 (free_vars t2))) as j.
  { rw in_remove_nvars; sp. }
  apply aeq in j.
  rw in_remove_nvars in j; repnd.
  apply isp0 in j0; sp.
Qed.

Lemma approx_starbts_get_bterms_alpha_eq_l {o} :
  forall lib op (t u v : @NTerm o),
    approx_starbts lib op (get_bterms t) (get_bterms u)
    -> alpha_eq t v
    -> approx_starbts lib op (get_bterms v) (get_bterms u).
Proof.
  introv ap aeq.
  destruct t as [v1|f1|op1 bs1]; destruct u as [v2|f2|op2 bs2]; allsimpl; auto;
  try (complete (inversion aeq; subst; allsimpl; auto)).
  - unfold approx_starbts, lblift_sub in ap; allsimpl; repnd; cpx.
    inversion aeq; subst; allsimpl; cpx; auto.
    unfold approx_starbts, lblift_sub; simpl; sp.
  - unfold approx_starbts, lblift_sub in ap; allsimpl; repnd; cpx.
    inversion aeq; subst; allsimpl; cpx; auto.
    unfold approx_starbts, lblift_sub; simpl; sp.
  - inversion aeq as [|?|? ? ? len imp]; subst; simpl.
    allunfold @approx_starbts.
    allunfold @lblift_sub; repnd; dands; auto; try omega.
    introv i.
    pose proof (ap n) as h1; autodimp h1 hyp; try omega.
    pose proof (imp n) as h2; autodimp h2 hyp; try omega.
    eapply approx_star_bterm_alpha_fun_l;[apply alpha_eq_bterm_sym; exact h2|]; auto.
Qed.

Lemma subst_sterm {o} :
  forall (f : @ntseq o) v t,
    subst (sterm f) v t = sterm f.
Proof.
  introv; unfold subst; autorewrite with slow; auto.
Qed.
Hint Rewrite @subst_sterm : slow.

(*
Lemma same_value_like_sterm_implies_approx_star {o} :
  forall lib (f1 f2 : @ntseq o),
    nt_wf (sterm f2)
    -> same_value_like (sterm f1) (sterm f2)
    -> approx_star lib (sterm f1) (sterm f2).
Proof.
  introv wf svl.
  inversion svl; subst; clear svl.
  econstructor; eauto.
  apply approx_open_refl; auto.
Qed.
Hint Resolve same_value_like_sterm_implies_approx_star : slow.
*)

Lemma approx_star_pushdown_fresh_if_subst {o} :
  forall lib (t1 t2 : @NTerm o) v1 v2 a,
    !LIn a (get_utokens t1)
    -> !LIn a (get_utokens t2)
    -> isprog_vars [v1] t1
    -> isprog_vars [v2] t2
    -> same_value_like lib (subst t1 v1 (mk_utoken a)) (subst t2 v2 (mk_utoken a))
    -> approx_starbts lib (get_op t1) (get_bterms (subst t1 v1 (mk_utoken a))) (get_bterms (subst t2 v2 (mk_utoken a)))
    -> approx_star lib (pushdown_fresh v1 t1) (pushdown_fresh v2 t2).
Proof.
  introv ni1 ni2 isp1 isp2 svl ap.

  pose proof (ex_fresh_var (all_vars t1
                                     ++ all_vars t2))
    as fv; exrepnd.
  allrw in_app_iff; allrw not_over_or; repnd.

  pose proof (alpha_bterm_change
                (bterm [v1] t1) [v1] t1 [v]) as aeqbt1.
  allrw disjoint_singleton_r.
  allrw in_app_iff; allrw not_over_or.
  allsimpl.
  repeat (autodimp aeqbt1 hyp).

  pose proof (alpha_bterm_change
                (bterm [v2] t2) [v2] t2 [v]) as aeqbt2.
  allrw disjoint_singleton_r.
  allrw in_app_iff; allrw not_over_or.
  allsimpl.
  repeat (autodimp aeqbt2 hyp).

  remember (lsubst t1 (var_ren [v1] [v])) as nt1.
  remember (lsubst t2 (var_ren [v2] [v])) as nt2.

  applydup @alpha_eq_bterm_preserves_utokens in aeqbt1 as ut1; allsimpl.
  rw ut1 in ni1.
  applydup @alpha_eq_bterm_preserves_utokens in aeqbt2 as ut2; allsimpl.
  rw ut2 in ni2.

  pose proof (lsubst_alpha_congr4 [v1] [v] t1 nt1 [(v1,mk_utoken a)] [(v,mk_utoken a)]) as c1.
  allsimpl.
  repeat (autodimp c1 hyp); eauto 3 with slow.

  pose proof (lsubst_alpha_congr4 [v2] [v] t2 nt2 [(v2,mk_utoken a)] [(v,mk_utoken a)]) as c2.
  allsimpl.
  repeat (autodimp c2 hyp); eauto 3 with slow.

  allrw @fold_subst.

  eapply same_value_like_alpha_eq_r in svl;[|exact c2].
  eapply same_value_like_alpha_eq_l in svl;[|exact c1].

  eapply alpha_eq_bterm_preserves_isprog_vars in isp1;[|exact aeqbt1].
  eapply alpha_eq_bterm_preserves_isprog_vars in isp2;[|exact aeqbt2].

  assert (get_op t1 = get_op nt1) as go.
  { subst; rw @lsubst_lsubst_aux; allrw <- @sub_free_vars_is_flat_map_free_vars_range;
    allsimpl; allrw disjoint_singleton_r; auto.
    destruct t1; simpl; boolvar; simpl; tcsp. }
  rw go in ap.

  eapply approx_starbts_get_bterms_alpha_eq in ap;[|exact c2].
  eapply approx_starbts_get_bterms_alpha_eq_l in ap;[|exact c1].

  applydup @implies_alpha_eq_pushdown_fresh in aeqbt1 as apf1.
  applydup @implies_alpha_eq_pushdown_fresh in aeqbt2 as apf2.

  eapply approx_star_alpha_fun_l;[|apply alpha_eq_sym; exact apf1].
  eapply approx_star_alpha_fun_r;[|apply alpha_eq_sym; exact apf2].

  clear dependent t1.
  clear dependent t2.
  rename nt1 into t1.
  rename nt2 into t2.

  repeat (unfsubst in svl); repeat (unfsubst in ap); allsimpl.
  destruct t1 as [x|f|op bs]; allsimpl; tcsp; GC.

  - boolvar.

    + apply approx_open_implies_approx_star.
      apply approx_implies_approx_open.
      apply (approx_trans _ _ (mk_fresh x (mk_var x))).

      * apply reduces_to_implies_approx2.
        { apply isprogram_fresh.
          apply isprog_vars_var. }
        apply reduces_to_if_step.
        csunf; simpl; boolvar; auto.

      * apply fresh_id_approx_any.
        apply isprogram_pushdown_fresh; auto.

    + inversion svl.

  - autorewrite with slow in *.
    destruct t2 as [v2|f2|op bs]; allsimpl; boolvar; allsimpl;
    try (complete (inversion svl)); eauto 4 with slow.
    inversion svl; subst; clear svl.
    allrw @isprog_vars_eq; repnd.
    econstructor;[| |eauto|]; eauto 3 with slow.

  - allsimpl.
    destruct t2 as [x|f|op' bs']; allsimpl; GC; try (complete (inversion svl)).

    + boolvar; try (complete (inversion svl)).
      inversion svl; subst; allsimpl.
      allrw not_over_or; sp.

    + applydup @same_value_like_implies_same_op in svl; subst.

      assert (length bs = length bs') as e.
      {  unfold approx_starbts, lblift_sub in ap; repnd; allrw map_length.
         unfold mk_fresh_bterms; allrw map_length; auto. }

      apply (apso _ _ _ _ (mk_fresh_bterms v bs')); auto;
      try (apply approx_open_refl);
      [unfold mk_fresh_bterms; allrw map_length; auto
       |idtac
       |apply isprog_vars_eq in isp2; repnd;
       allrw @nt_wf_oterm_iff; repnd;
       rw <- isp3;
       unfold mk_fresh_bterms; allrw map_map; unfold compose; dands;
       [ apply eq_maps; introv i; destruct x; unfold num_bvars; simpl; auto|];
       introv i; allrw in_map_iff; exrepnd; subst;
       apply isp2 in i1; apply bt_wf_mk_fresh_bterm_if; complete auto].

      unfold lblift_sub, mk_fresh_bterms; dands; allrw map_length; auto.
      introv i.
      repeat (rw @selectbt_map; auto; try omega).
      unfold approx_starbts, lblift_sub in ap; repnd; allrw map_length; GC.
      pose proof (ap n i) as k; clear ap.
      repeat (rw @selectbt_map in k; auto; try omega).
      allunfold @selectbt.

      pose proof (in_nth_combine _ _ bs bs' n default_bt default_bt) as h.
      repeat (autodimp h hyp).
      remember (nth n bs default_bt)  as b1; clear Heqb1.
      remember (nth n bs' default_bt) as b2; clear Heqb2.
      allrw in_app_iff; allrw not_over_or; repnd.
      applydup in_combine in h; repnd.
      assert (!LIn a (get_utokens_b b1)) as niab1.
      { introv q; destruct ni1; rw lin_flat_map; eexists; dands; eauto. }
      assert (!LIn a (get_utokens_b b2)) as niab2.
      { introv q; destruct ni2; rw lin_flat_map; eexists; dands; eauto. }

(* new stuff *)

      apply (blift_sub_diff (v :: maybe_new_var_b v b1
                               :: maybe_new_var_b v b2
                               :: all_vars_bterm b1
                               ++ all_vars_bterm b2)) in k; exrepnd.
      allrw disjoint_cons_r; allrw disjoint_cons_l; allrw disjoint_app_r; allrw disjoint_app_l; repnd.

      assert (wf_term nt1) as wfnt1.
      { repndors; exrepnd.
        - allapply @approx_star_relates_only_wf; repnd; eauto 2 with slow.
        - allapply @approx_star_relates_only_wf; repnd.
          allapply @lsubst_nt_wf; eauto with slow. }

      assert (wf_term nt2) as wfnt2.
      { repndors; exrepnd.
        - allapply @approx_star_relates_only_wf; repnd; eauto 2 with slow.
        - allapply @approx_star_relates_only_wf; repnd.
          allapply @lsubst_nt_wf; eauto with slow. }

      pose proof (alpha_eq_subst_bterm_aux_pull_out_token b1 v a lv nt1) as exs1.
      repeat (autodimp exs1 hyp); exrepnd.
      subst nt1.
      rename u into nt1.

      pose proof (alpha_eq_subst_bterm_aux_pull_out_token b2 v a lv nt2) as exs2.
      repeat (autodimp exs2 hyp); exrepnd.
      subst nt2.
      rename u into nt2.

      assert (disjoint lv (bound_vars nt1)) as disjlvnt1.
      { introv i1 i2; apply k7 in i1; destruct i1.
        unfsubst.
        rw (bound_vars_lsubst_aux_nrut_sub nt1 [(v,mk_utoken a)] []); auto.
        apply nrut_sub_cons; eexists; dands; simpl; eauto with slow; tcsp. }

      assert (disjoint lv (bound_vars nt2)) as disjlvnt2.
      { introv i1 i2; apply k8 in i1; destruct i1.
        unfsubst.
        rw (bound_vars_lsubst_aux_nrut_sub nt2 [(v,mk_utoken a)] []); auto.
        apply nrut_sub_cons; eexists; dands; simpl; eauto with slow; tcsp. }

      unfold blift_sub.

      pose proof (alpha_eq_bterm_mk_fresh_bterm_berm b1 v a lv nt1) as e1.
      repeat (autodimp e1 hyp); eauto 3 with slow.

      pose proof (alpha_eq_bterm_mk_fresh_bterm_berm b2 v a lv nt2) as e2.
      repeat (autodimp e2 hyp); eauto 3 with slow.

      exists lv (mk_fresh v nt1) (mk_fresh v nt2); dands; auto.

      (* here comes trouble! *)

      repndors;[left|right].

      * repnd; dands; auto.
        apply (apso _ _ _ _ [bterm [v] nt2]); allsimpl; auto; fold_terms;
        [|apply approx_open_refl; allrw <- @nt_wf_eq;
          allapply @lsubst_nt_wf; apply nt_wf_fresh; auto].
        unfold lblift_sub; simpl; dands; auto; introv q; destruct n0; cpx.
        unfold selectbt; simpl.
        unfold blift_sub.

        exists [v] nt1 nt2; dands; auto.
        right.
        exists [(v,mk_utoken a)]; simpl; dands; auto.
        apply nrut_sub_cons; simpl; eexists; dands; eauto with slow; tcsp.
        rw in_app_iff; sp.

      * exrepnd.

        pose proof (exists_nrut_sub
                      (dom_sub sub)
                      (a :: get_utokens (subst nt1 v (mk_utoken a))
                         ++ get_utokens (subst nt2 v (mk_utoken a))))
          as ens; exrepnd.

        pose proof (approx_star_change_nrut_sub
                      lib
                      (subst nt1 v (mk_utoken a))
                      (subst nt2 v (mk_utoken a))
                      sub
                      (get_utokens (subst nt1 v (mk_utoken a)) ++ get_utokens (subst nt2 v (mk_utoken a)))
                      sub0
                      (a :: get_utokens (subst nt1 v (mk_utoken a)) ++ get_utokens (subst nt2 v (mk_utoken a))))
          as aps; repeat (autodimp aps hyp); eauto 3 with slow.

        exists sub0; dands; auto; simpl; allrw app_nil_r;
        try (complete (subst; auto));
        [|eapply nrut_sub_subset;[|exact ens1]; apply subset_cons1;
          apply subset_app_lr; introv z;
          apply get_utokens_subst; boolvar; simpl;
          repeat (rw app_nil_r); repeat (rw in_app_iff); complete sp].
        repeat (rw @cl_lsubst_lsubst_aux; eauto 2 with slow); simpl; fold_terms.
        apply (apso _ _ _ _ [bterm [v] (lsubst_aux nt2 (sub_filter sub0 [v]))]); allsimpl; auto; fold_terms;
        [|apply approx_open_refl; allrw <- @nt_wf_eq;
          allapply @lsubst_nt_wf; apply nt_wf_fresh; auto;
          apply implies_wf_lsubst_aux; eauto 3 with slow];[].
        unfold lblift_sub; simpl; dands; auto; introv q; destruct n0; cpx.
        unfold selectbt; simpl.
        unfold blift_sub.

        allunfold @subst.
        rw (cl_lsubst_swap_sub_filter nt1) in aps; eauto 3 with slow.
        rw (cl_lsubst_swap_sub_filter nt2) in aps; eauto 3 with slow.
        allsimpl.

        assert (!LIn a (get_utokens_sub sub0)) as niasub.
        { intro z; unfold nrut_sub in ens1; repnd; allrw disjoint_cons_l; sp. }

        exists [v] (lsubst_aux nt1 (sub_filter sub0 [v])) (lsubst_aux nt2 (sub_filter sub0 [v])); dands; auto.
        right.
        exists [(v,mk_utoken a)]; simpl; dands; auto.
        { repeat (rw <- @cl_lsubst_lsubst_aux; eauto 3 with slow). }
        apply nrut_sub_cons; simpl; eexists; dands; eauto with slow; tcsp.
        rw in_app_iff; rw not_over_or; dands; intro z;
        apply get_utokens_lsubst_aux_subset in z; rw in_app_iff in z; repndors; tcsp;
        apply get_utokens_sub_filter_subset in z; tcsp.
Qed.

Lemma alpha_eq_lsubst_nrut_sub_implies {o} :
  forall (t1 t2 : @NTerm o) sub l,
    nrut_sub l sub
    -> subset (get_utokens t1) l
    -> subset (get_utokens t2) l
    -> alpha_eq (lsubst t1 sub) (lsubst t2 sub)
    -> alpha_eq t1 t2.
Proof.
  introv nrut ss1 ss2 aeq.

  pose proof (unfold_lsubst sub t1) as p; destruct p as [t1']; repnd.
  pose proof (unfold_lsubst sub t2) as q; destruct q as [t2']; repnd.
  rw p in aeq; rw p2 in aeq.

  pose proof (change_bvars_alpha_wspec (dom_sub sub) t1') as h; destruct h as [t1'']; repnd.
  pose proof (change_bvars_alpha_wspec (dom_sub sub) t2') as k; destruct k as [t2'']; repnd.
  dup p5 as a1.
  apply (computation2.lsubst_aux_alpha_congr_same_cl_sub _ _ sub) in a1; eauto 2 with slow.
  dup p7 as a2.
  apply (computation2.lsubst_aux_alpha_congr_same_cl_sub _ _ sub) in a2; eauto 2 with slow.

  assert (alpha_eq (lsubst_aux t1'' sub) (lsubst_aux t2'' sub)) as aeq2 by eauto 4 with slow.

  pose proof (alpha_eq_lsubst_aux_nrut_sub_implies t1'' t2'' sub l) as a.
  repeat (autodimp a hyp).
  - apply alphaeq_preserves_utokens in p5; rw <- p5.
    apply alphaeq_preserves_utokens in p0; rw <- p0; auto.
  - apply alphaeq_preserves_utokens in p7; rw <- p7.
    apply alphaeq_preserves_utokens in p3; rw <- p3; auto.
  - assert (alpha_eq t1 t1'') as aeq11 by eauto with slow.
    assert (alpha_eq t2 t2'') as aeq22 by eauto with slow.
    eauto with slow.
Qed.

Lemma reduces_in_atmost_k_steps_mk_fresh_id {o} :
  forall (lib : @library o) v k u,
    reduces_in_atmost_k_steps lib (mk_fresh v (vterm v)) u k
    -> u = mk_fresh v (vterm v).
Proof.
  induction k; introv r.
  - allrw @reduces_in_atmost_k_steps_0; auto.
  - allrw @reduces_in_atmost_k_steps_S; exrepnd.
    csunf r1; allsimpl; boolvar; ginv.
    apply IHk in r0; auto.
Qed.

Lemma reduces_in_atmost_k_steps_mk_fresh_id2 {o} :
  forall (lib : @library o) v k,
    reduces_in_atmost_k_steps lib (mk_fresh v (vterm v)) (mk_fresh v (vterm v)) k.
Proof.
  induction k; introv.
  - allrw @reduces_in_atmost_k_steps_0; auto.
  - allrw @reduces_in_atmost_k_steps_S; exrepnd.
    exists (@mk_fresh o v (vterm v)); dands; auto.
    csunf; simpl; boolvar; auto.
Qed.

Lemma isprog_vars_implies_nt_wf {o} :
  forall (t : @NTerm o) l, isprog_vars l t -> nt_wf t.
Proof.
  introv isp.
  rw @isprog_vars_eq in isp; sp.
Qed.
Hint Resolve isprog_vars_implies_nt_wf : slow.


(** Anything can be summarised as being basically two options.
  Furthermore, the second option is usually very wrong. **)
Axiom there_is_a_choice : forall T, exists a b, forall t : T, t = a \/ t = b.

Inductive undisciplined := Good | Bad | Ugly.

Lemma undisciplined_has_more_choice : forall a b : undisciplined,
  exists c, c <> a /\ c <> b.
Proof.
  destruct a, b;
    try solve [ exists Good; split; discriminate
              | exists Bad; split; discriminate
              | exists Ugly; split; discriminate ].
Qed.

Corollary nothing_matters : False.
  set (H := there_is_a_choice undisciplined). destruct H as (a&b&I).
  set (H := undisciplined_has_more_choice a b). destruct H as (c&D1&D2).
  destruct (I c); auto.
Qed.

(** Not only there are only two options, you can actually choose them.
  Again, the second one is usually very bad.
  The good news is that disjunction is commutative: if you need to change
  side in the middle, you can actually claim that it was the first one
  that was bad, not the second one. **)
Theorem straw_man : forall T (a b t : T), t = a \/ t = b.
Proof.
  exfalso. apply nothing_matters.
Qed.