+ [* #ta * whd in ⊢ (%→?); * * #cin * #Hcin #Hcintrue #Hta * #tb * whd in ⊢ (%→?); #Htb
+ * #tc * whd in ⊢ (%→?); #Htc * whd in ⊢ (%→%→?); #Houtc #Houtc1
+ #ls #x #rs #Hintape >Hintape in Hcin; whd in ⊢ ((??%?)→?); #H destruct (H) %
+ [#_ cases (dec_marked ? rs) #Hdec
+ [%
+ [#_ #a #l1
+ >Hintape in Hta; #Hta
+ lapply (proj2 ?? Htb … Hta) -Htb -Hta cases rs in Hdec;
+ (* by cases on rs *)
+ [#_ whd in ⊢ ((???%)→?); #Htb >Htb in Htc; #Htc
+ lapply (proj1 ?? Htc (refl …)) -Htc #Htc <Htc in Houtc1; #Houtc1
+ normalize in ⊢ (???%→?); #Hl1 destruct(Hl1) @(Houtc1 (refl …))
+ |#r0 #rs0 #Hdec whd in ⊢ ((???%)→?); #Htb >Htb in Htc; #Htc
+ >reverse_cons >reverse_cons #Hl1
+ cases (proj2 ?? Htc … (refl …))
+ [* >(Hdec …) [ #Hfalse destruct(Hfalse) ] @memb_hd
+ |* #_ -Htc #Htc cut (∃l2.l1 = l2@[〈x,true〉])
+ [generalize in match Hl1; -Hl1 <(reverse_reverse … l1)
+ cases (reverse ? l1)
+ [#Hl1 cut ([a]=〈x,true〉::r0::rs0)
+ [ <(reverse_reverse … (〈x,true〉::r0::rs0))
+ >reverse_cons >reverse_cons <Hl1 %
+ | #Hfalse destruct(Hfalse)]
+ |#a0 #l10 >reverse_cons #Heq
+ lapply (append_l2_injective_r ? (a::reverse ? l10) ???? Heq) //
+ #Ha0 destruct(Ha0) /2/ ]
+ |* #l2 #Hl2 >Hl2 in Hl1; #Hl1
+ lapply (append_l1_injective_r ? (a::l2) … Hl1) // -Hl1 #Hl1
+ >reverse_cons in Htc; #Htc lapply (Htc … (sym_eq … Hl1))
+ [ #x0 #Hmemb @Hdec @memb_cons @Hmemb ]
+ -Htc #Htc >Htc in Houtc1; #Houtc1 >associative_append @Houtc1 %
+ ]
+ ]
+ ]
+ |#l1 #x0 #l2 #_ #Hrs @False_ind
+ @(absurd ?? not_eq_true_false)
+ change with (is_marked ? 〈x0,true〉) in match true;
+ @Hdec >Hrs @memb_append_l2 @memb_hd
+ ]
+ |% [#H @False_ind @(absurd …H Hdec)]
+ (* by cases on l1 *) *
+ [#x0 #l2 #Hdec normalize in ⊢ (%→?); #Hrs >Hrs in Hintape; #Hintape
+ >Hintape in Hta; (* * * #x1 * whd in ⊢ ((??%?)→?); #H destruct (H) #Hx *)
+ #Hta lapply (proj2 … Htb … Hta) -Htb -Hta
+ whd in match (mk_tape ????); whd in match (tail ??); #Htb cases Htc -Htc
+ #_ #Htc cases (Htc … Htb) -Htc
+ [2: * * #Hfalse normalize in Hfalse; destruct (Hfalse) ]
+ * * #Htc >Htb in Htc; -Htb #Htc cases (Houtc … Htc) -Houtc *
+ #H1 #H2 #H3 cases (true_or_false (x==x0)) #eqxx0
+ [>(\P eqxx0) % [2: #H @False_ind /2/] %
+ [#_ #Hl2 >(H2 … Hl2) <(\P eqxx0) [% | @Hcintrue]
+ |#_ #a #a0 #b #l1' #l2' normalize in ⊢ (%→?); #Hdes destruct (Hdes)
+ #Hl2 @(H3 … Hdec … Hl2) <(\P eqxx0) [@Hcintrue | % | @reverse_single]
+ ]
+ |% [% #eqx @False_ind lapply (\Pf eqxx0) #Habs @(absurd … eqx Habs)]
+ #_ @H1 @(\bf ?) @(not_to_not ??? (\Pf eqxx0)) <(\P Hcintrue)
+ #Hdes destruct (Hdes) %
+ ]
+ |#l1hd #l1tl #x0 #l2 #Hdec normalize in ⊢ (%→?); #Hrs >Hrs in Hintape; #Hintape
+ >Hintape in Hta; (* * * #x1 * whd in ⊢ ((??%?)→?); #H destruct (H) #Hx *)
+ #Hta lapply (proj2 … Htb … Hta) -Htb -Hta
+ whd in match (mk_tape ????); whd in match (tail ??); #Htb cases Htc -Htc
+ #_ #Htc cases (Htc … Htb) -Htc
+ [* #Hfalse @False_ind >(Hdec … (memb_hd …)) in Hfalse; #H destruct]
+ * * #_ #Htc lapply (Htc … (refl …) (refl …) ?) -Htc
+ [#x1 #membx1 @Hdec @memb_cons @membx1] #Htc
+ cases (Houtc … Htc) -Houtc *
+ #H1 #H2 #H3 #_ cases (true_or_false (x==x0)) #eqxx0
+ [>(\P eqxx0) % [2: #H @False_ind /2/] %
+ [#_ #Hl2 >(H2 … Hl2) <(\P eqxx0)
+ [>reverse_cons >associative_append % | @Hcintrue]
+ |#_ #a #a0 #b #l1' #l2' normalize in ⊢ (%→?); #Hdes (* destruct (Hdes) *)
+ #Hl2 @(H3 ?????? (reverse … (l1hd::l1tl)) … Hl2) <(\P eqxx0)
+ [@Hcintrue
+ |>reverse_cons >associative_append %
+ |#c0 #memc @Hdec <(reverse_reverse ? (l1hd::l1tl)) @memb_reverse @memc
+ |>Hdes >reverse_cons >reverse_reverse >(\P eqxx0) %
+ ]
+ ]
+ |% [% #eqx @False_ind lapply (\Pf eqxx0) #Habs @(absurd … eqx Habs)]
+ #_ >reverse_cons >associative_append @H1 @(\bf ?)
+ @(not_to_not ??? (\Pf eqxx0)) <(\P Hcintrue) #Hdes
+ destruct (Hdes) %
+ ]
+ ]
+ ]
+ |>(\P Hcintrue) * #Hfalse @False_ind @Hfalse %
+ ]
+ | * #ta * * #Hcur #Hta #Houtc
+ #l0 #x #rs #Hintape >Hintape in Hcur; #Hcur lapply (Hcur ? (refl …)) -Hcur #Hc %
+ [ #Hfalse >Hfalse in Hc; #Hc cases (\Pf Hc) #Hc @False_ind @Hc %
+ | -Hc #Hc <Hintape <Hta @Houtc ] ]
+qed.
+
+(*
+- se marcato, itero
+- se non è marcato
+ + se è un bit, ho fallito il confronto della tupla corrente
+ + se è un separatore, la tupla fa match
+
+
+ifTM ? (test_char ? is_marked)
+ (single_finalTM … (comp_step_subcase unialpha 〈bit false,true〉
+ (comp_step_subcase unialpha 〈bit true,true〉
+ (clear_mark …))))
+ (nop ?)
+*)
+
+definition comp_step ≝
+ ifTM ? (test_char ? (is_marked ?))
+ (single_finalTM … (comp_step_subcase FSUnialpha 〈bit false,true〉
+ (comp_step_subcase FSUnialpha 〈bit true,true〉
+ (comp_step_subcase FSUnialpha 〈null,true〉
+ (clear_mark …)))))
+ (nop ?)
+ tc_true.
+
+(* da spostare *)
+
+lemma mem_append : ∀A,x,l1,l2. mem A x (l1@l2) →
+ mem A x l1 ∨ mem A x l2.
+#A #x #l1 elim l1 normalize [/2/]
+#a #tl #Hind #l2 * [#eqxa %1 /2/ |#memx cases (Hind … memx) /3/]
+qed.
+
+let rec split_on A (l:list A) f acc on l ≝
+ match l with
+ [ nil ⇒ 〈acc,nil ?〉
+ | cons a tl ⇒
+ if f a then 〈acc,a::tl〉 else split_on A tl f (a::acc)
+ ].
+
+lemma split_on_spec: ∀A:DeqSet.∀l,f,acc,res1,res2.
+ split_on A l f acc = 〈res1,res2〉 →
+ (∃l1. res1 = l1@acc ∧
+ reverse ? l1@res2 = l ∧
+ ∀x. memb ? x l1 =true → f x = false) ∧
+ ∀a,tl. res2 = a::tl → f a = true.
+#A #l #f elim l
+ [#acc #res1 #res2 normalize in ⊢ (%→?); #H destruct %
+ [@(ex_intro … []) % normalize [% % | #x #H destruct]
+ |#a #tl #H destruct
+ ]
+ |#a #tl #Hind #acc #res1 #res2 normalize in ⊢ (%→?);
+ cases (true_or_false (f a)) #Hfa >Hfa normalize in ⊢ (%→?);
+ #H destruct
+ [% [@(ex_intro … []) % normalize [% % | #x #H destruct]
+ |#a1 #tl1 #H destruct (H) //]
+ |cases (Hind (a::acc) res1 res2 H) * #l1 * *
+ #Hres1 #Htl #Hfalse #Htrue % [2:@Htrue] @(ex_intro … (l1@[a])) %
+ [% [>associative_append @Hres1 | >reverse_append <Htl % ]
+ |#x #Hmemx cases (memb_append ???? Hmemx)
+ [@Hfalse | #H >(memb_single … H) //]
+ ]
+ ]
+ ]
+qed.
+
+axiom mem_reverse: ∀A,l,x. mem A x (reverse ? l) → mem A x l.
+
+lemma split_on_spec_ex: ∀A:DeqSet.∀l,f.∃l1,l2.
+ l1@l2 = l ∧ (∀x:A. memb ? x l1 = true → f x = false) ∧
+ ∀a,tl. l2 = a::tl → f a = true.
+#A #l #f @(ex_intro … (reverse … (\fst (split_on A l f []))))
+@(ex_intro … (\snd (split_on A l f [])))
+cases (split_on_spec A l f [ ] ?? (eq_pair_fst_snd …)) * #l1 * *
+>append_nil #Hl1 >Hl1 #Hl #Hfalse #Htrue %
+ [% [@Hl|#x #memx @Hfalse <(reverse_reverse … l1) @memb_reverse //] | @Htrue]
+qed.
+
+(* versione esistenziale *)
+
+definition R_comp_step_true ≝ λt1,t2.
+ ∃ls,c,rs.t1 = midtape (FinProd … FSUnialpha FinBool) ls 〈c,true〉 rs ∧
+ ((* bit_or_null c = false *)
+ (bit_or_null c = false → t2 = midtape ? ls 〈c,false〉 rs) ∧
+ (* no marks in rs *)
+ (bit_or_null c = true →
+ (∀c.memb ? c rs = true → is_marked ? c = false) →
+ ∀a,l. (a::l) = reverse ? (〈c,true〉::rs) →
+ t2 = rightof (FinProd FSUnialpha FinBool) a (l@ls)) ∧
+ (∀l1,c0,l2.
+ bit_or_null c = true →
+ (∀c.memb ? c l1 = true → is_marked ? c = false) →
+ rs = l1@〈c0,true〉::l2 →
+ (c = c0 →
+ l2 = [ ] → (* test true but l2 is empty *)
+ t2 = rightof ? 〈c0,false〉 ((reverse ? l1)@〈c,true〉::ls)) ∧
+ (c = c0 →
+ ∀a,a0,b,l1',l2'. (* test true and l2 is not empty *)
+ 〈a,false〉::l1' = l1@[〈c0,false〉] →
+ l2 = 〈a0,b〉::l2' →
+ t2 = midtape ? (〈c,false〉::ls) 〈a,true〉 (l1'@〈a0,true〉::l2')) ∧
+ (c ≠ c0 →(* test false *)
+ t2 = midtape (FinProd … FSUnialpha FinBool)
+ ((reverse ? l1)@〈c,true〉::ls) 〈c0,false〉 l2))).
+
+definition R_comp_step_false ≝
+ λt1,t2.
+ ∀ls,c,rs.t1 = midtape (FinProd … FSUnialpha FinBool) ls c rs →
+ is_marked ? c = false ∧ t2 = t1.
+
+lemma is_marked_to_exists: ∀alpha,c. is_marked alpha c = true →
+ ∃c'. c = 〈c',true〉.
+#alpha * #c * [#_ @(ex_intro … c) //| normalize #H destruct]
+qed.
+
+lemma exists_current: ∀alpha,c,t.
+ current alpha t = Some alpha c → ∃ls,rs. t= midtape ? ls c rs.
+#alpha #c *
+ [whd in ⊢ (??%?→?); #H destruct
+ |#a #l whd in ⊢ (??%?→?); #H destruct
+ |#a #l whd in ⊢ (??%?→?); #H destruct
+ |#ls #c1 #rs whd in ⊢ (??%?→?); #H destruct
+ @(ex_intro … ls) @(ex_intro … rs) //
+ ]
+qed.
+
+lemma sem_comp_step :
+ accRealize ? comp_step (inr … (inl … (inr … start_nop)))
+ R_comp_step_true R_comp_step_false.
+@(acc_sem_if_app … (sem_test_char ? (is_marked ?))
+ (sem_comp_step_subcase FSUnialpha 〈bit false,true〉 ??
+ (sem_comp_step_subcase FSUnialpha 〈bit true,true〉 ??
+ (sem_comp_step_subcase FSUnialpha 〈null,true〉 ??
+ (sem_clear_mark …))))
+ (sem_nop …) …)
+[#intape #outape #ta #Hta #Htb cases Hta * #cm * #Hcur
+ cases (exists_current … Hcur) #ls * #rs #Hintape #cmark
+ cases (is_marked_to_exists … cmark) #c #Hcm
+ >Hintape >Hcm -Hintape -Hcm #Hta
+ @(ex_intro … ls) @(ex_intro … c) @(ex_intro …rs) % [//] lapply Hta -Hta
+ (* #ls #c #rs #Hintape whd in Hta;
+ >Hintape in Hta; * #_ -Hintape forse non serve *)
+ cases (true_or_false (c==bit false)) #Hc
+ [>(\P Hc) #Hta %
+ [%[whd in ⊢ ((??%?)→?); #Hdes destruct
+ |#Hc @(proj1 ?? (proj1 ?? (Htb … Hta) (refl …)))
+ ]
+ |#l1 #c0 #l2 #Hc @(proj2 ?? (proj1 ?? (Htb … Hta) (refl …)))
+ ]
+ |cases (true_or_false (c==bit true)) #Hc1
+ [>(\P Hc1) #Hta
+ cut (〈bit true, true〉 ≠ 〈bit false, true〉) [% #Hdes destruct] #Hneq %
+ [%[whd in ⊢ ((??%?)→?); #Hdes destruct
+ |#Hc @(proj1 … (proj1 ?? (proj2 ?? (Htb … Hta) Hneq … Hta) (refl …)))
+ ]
+ |#l1 #c0 #l2 #Hc @(proj2 ?? (proj1 ?? (proj2 ?? (Htb … Hta) Hneq … Hta)(refl …)))
+ ]
+ |cases (true_or_false (c==null)) #Hc2
+ [>(\P Hc2) #Hta
+ cut (〈null, true〉 ≠ 〈bit false, true〉) [% #Hdes destruct] #Hneq
+ cut (〈null, true〉 ≠ 〈bit true, true〉) [% #Hdes destruct] #Hneq1 %
+ [%[whd in ⊢ ((??%?)→?); #Hdes destruct
+ |#Hc @(proj1 … (proj1 ?? (proj2 ?? (proj2 ?? (Htb … Hta) Hneq … Hta) Hneq1 … Hta) (refl …)))
+ ]
+ |#l1 #c0 #l2 #Hc @(proj2 ?? (proj1 ?? (proj2 ?? (proj2 ?? (Htb … Hta) Hneq … Hta) Hneq1 … Hta) (refl …)))
+ ]
+ |#Hta cut (bit_or_null c = false)
+ [lapply Hc; lapply Hc1; lapply Hc2 -Hc -Hc1 -Hc2
+ cases c normalize [* normalize /2/] /2/] #Hcut %
+ [%[cases (Htb … Hta) #_ -Htb #Htb
+ cases (Htb … Hta) [2: % #H destruct (H) normalize in Hc; destruct] #_ -Htb #Htb
+ cases (Htb … Hta) [2: % #H destruct (H) normalize in Hc1; destruct] #_ -Htb #Htb
+ lapply (Htb ?) [% #H destruct (H) normalize in Hc2; destruct]
+ * #_ #Houttape #_ @(Houttape … Hta)
+ |>Hcut #H destruct
+ ]
+ |#l1 #c0 #l2 >Hcut #H destruct
+ ]
+ ]
+ ]
+ ]
+|#intape #outape #ta #Hta #Htb #ls #c #rs #Hintape
+ >Hintape in Hta; whd in ⊢ (%→?); * #Hmark #Hta % [@Hmark //]
+ whd in Htb; >Htb //