-(* old universal version
-
-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 *)
-
-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 #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 //
-]
-qed. *)
-
-(*
-definition R_comp_step_true ≝
- λt1,t2.
- ∀l0,c,rs.t1 = midtape (FinProd … FSUnialpha FinBool) l0 c rs →
- ∃c'. c = 〈c',true〉 ∧
- ((bit_or_null c' = true ∧
- ∀a,l1,c0,a0,l2.
- rs = 〈a,false〉::l1@〈c0,true〉::〈a0,false〉::l2 →
- (∀c.memb ? c l1 = true → is_marked ? c = false) →
- (c0 = c' ∧
- t2 = midtape ? (〈c',false〉::l0) 〈a,true〉 (l1@〈c0,false〉::〈a0,true〉::l2)) ∨
- (c0 ≠ c' ∧
- t2 = midtape (FinProd … FSUnialpha FinBool)
- (reverse ? l1@〈a,false〉::〈c',true〉::l0) 〈c0,false〉 (〈a0,false〉::l2))) ∨
- (bit_or_null c' = false ∧ t2 = midtape ? l0 〈c',false〉 rs)).
-
-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 sem_comp_step :
- accRealize ? comp_step (inr … (inl … (inr … start_nop)))
- R_comp_step_true R_comp_step_false.
-#intape
-cases (acc_sem_if … (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)
-#k * #outc * * #Hloop #H1 #H2
-@(ex_intro ?? k) @(ex_intro ?? outc) %
-[ % [@Hloop ] ] -Hloop
-[ #Hstate lapply (H1 Hstate) -H1 -Hstate -H2 *
- #ta * whd in ⊢ (%→?); #Hleft #Hright #ls #c #rs #Hintape
- >Hintape in Hleft; * *
- cases c in Hintape; #c' #b #Hintape #x * whd in ⊢ (??%?→?); #H destruct (H)
- whd in ⊢ (??%?→?); #Hb >Hb #Hta @(ex_intro ?? c') % //
- cases (Hright … Hta)
- [ * #Hc' #H1 % % [destruct (Hc') % ]
- #a #l1 #c0 #a0 #l2 #Hrs >Hrs in Hintape; #Hintape #Hl1
- cases (H1 … Hl1 Hrs)
- [ * #Htmp >Htmp -Htmp #Houtc % % // @Houtc
- | * #Hneq #Houtc %2 %
- [ @sym_not_eq //
- | @Houtc ]
- ]
- | * #Hc #Helse1 cases (Helse1 … Hta)
- [ * #Hc' #H1 % % [destruct (Hc') % ]
- #a #l1 #c0 #a0 #l2 #Hrs >Hrs in Hintape; #Hintape #Hl1
- cases (H1 … Hl1 Hrs)
- [ * #Htmp >Htmp -Htmp #Houtc % % // @Houtc
- | * #Hneq #Houtc %2 %
- [ @sym_not_eq //
- | @Houtc ]
- ]
- | * #Hc' #Helse2 cases (Helse2 … Hta)
- [ * #Hc'' #H1 % % [destruct (Hc'') % ]
- #a #l1 #c0 #a0 #l2 #Hrs >Hrs in Hintape; #Hintape #Hl1
- cases (H1 … Hl1 Hrs)
- [ * #Htmp >Htmp -Htmp #Houtc % % // @Houtc
- | * #Hneq #Houtc %2 %
- [ @sym_not_eq //
- | @Houtc ]
- ]
- | * #Hc'' whd in ⊢ (%→?); #Helse3 %2 %
- [ generalize in match Hc''; generalize in match Hc'; generalize in match Hc;
- cases c'
- [ * [ #_ #Hfalse @False_ind @(absurd ?? Hfalse) %
- | #Hfalse @False_ind @(absurd ?? Hfalse) % ]
- | #_ #_ #Hfalse @False_ind @(absurd ?? Hfalse) %
- |*: #_ #_ #_ % ]
- | @(Helse3 … Hta)
- ]
- ]
- ]
- ]
-| #Hstate lapply (H2 Hstate) -H1 -Hstate -H2 *
- #ta * whd in ⊢ (%→%→?); #Hleft #Hright #ls #c #rs #Hintape
- >Hintape in Hleft; * #Hc #Hta % [@Hc % | >Hright //]
-]
-qed.*)