include "turing/while_machine.ma".
include "turing/if_machine.ma".
+include "turing/universal/alphabet.ma".
+include "turing/universal/tests.ma".
(* ADVANCE TO MARK (right)
definition atm_states ≝ initN 3.
+definition atm0 : atm_states ≝ mk_Sig ?? 0 (leb_true_to_le 1 3 (refl …)).
+definition atm1 : atm_states ≝ mk_Sig ?? 1 (leb_true_to_le 2 3 (refl …)).
+definition atm2 : atm_states ≝ mk_Sig ?? 2 (leb_true_to_le 3 3 (refl …)).
+
definition atmr_step ≝
λalpha:FinSet.λtest:alpha→bool.
mk_TM alpha atm_states
(λp.let 〈q,a〉 ≝ p in
match a with
- [ None ⇒ 〈1, None ?〉
+ [ None ⇒ 〈atm1, None ?〉
| Some a' ⇒
match test a' with
- [ true ⇒ 〈1,None ?〉
- | false ⇒ 〈2,Some ? 〈a',R〉〉 ]])
- O (λx.notb (x == 0)).
+ [ true ⇒ 〈atm1,None ?〉
+ | false ⇒ 〈atm2,Some ? 〈a',R〉〉 ]])
+ atm0 (λx.notb (x == atm0)).
definition Ratmr_step_true ≝
λalpha,test,t1,t2.
lemma atmr_q0_q1 :
∀alpha,test,ls,a0,rs. test a0 = true →
step alpha (atmr_step alpha test)
- (mk_config ?? 0 (midtape … ls a0 rs)) =
- mk_config alpha (states ? (atmr_step alpha test)) 1
+ (mk_config ?? atm0 (midtape … ls a0 rs)) =
+ mk_config alpha (states ? (atmr_step alpha test)) atm1
(midtape … ls a0 rs).
-#alpha #test #ls #a0 #ts #Htest normalize >Htest %
+#alpha #test #ls #a0 #ts #Htest whd in ⊢ (??%?);
+whd in match (trans … 〈?,?〉); >Htest %
qed.
lemma atmr_q0_q2 :
∀alpha,test,ls,a0,rs. test a0 = false →
step alpha (atmr_step alpha test)
- (mk_config ?? 0 (midtape … ls a0 rs)) =
- mk_config alpha (states ? (atmr_step alpha test)) 2
+ (mk_config ?? atm0 (midtape … ls a0 rs)) =
+ mk_config alpha (states ? (atmr_step alpha test)) atm2
(mk_tape … (a0::ls) (option_hd ? rs) (tail ? rs)).
-#alpha #test #ls #a0 #ts #Htest normalize >Htest cases ts //
+#alpha #test #ls #a0 #ts #Htest whd in ⊢ (??%?);
+whd in match (trans … 〈?,?〉); >Htest cases ts //
qed.
lemma sem_atmr_step :
∀alpha,test.
accRealize alpha (atmr_step alpha test)
- 2 (Ratmr_step_true alpha test) (Ratmr_step_false alpha test).
+ atm2 (Ratmr_step_true alpha test) (Ratmr_step_false alpha test).
#alpha #test *
[ @(ex_intro ?? 2)
- @(ex_intro ?? (mk_config ?? 1 (niltape ?))) %
- [ % // #Hfalse destruct | #_ % // % % ]
-| #a #al @(ex_intro ?? 2) @(ex_intro ?? (mk_config ?? 1 (leftof ? a al)))
- % [ % // #Hfalse destruct | #_ % // % % ]
-| #a #al @(ex_intro ?? 2) @(ex_intro ?? (mk_config ?? 1 (rightof ? a al)))
- % [ % // #Hfalse destruct | #_ % // % % ]
+ @(ex_intro ?? (mk_config ?? atm1 (niltape ?))) %
+ [ % // whd in ⊢ ((??%%)→?); #Hfalse destruct | #_ % // % % ]
+| #a #al @(ex_intro ?? 2) @(ex_intro ?? (mk_config ?? atm1 (leftof ? a al)))
+ % [ % // whd in ⊢ ((??%%)→?); #Hfalse destruct | #_ % // % % ]
+| #a #al @(ex_intro ?? 2) @(ex_intro ?? (mk_config ?? atm1 (rightof ? a al)))
+ % [ % // whd in ⊢ ((??%%)→?); #Hfalse destruct | #_ % // % % ]
| #ls #c #rs @(ex_intro ?? 2)
cases (true_or_false (test c)) #Htest
- [ @(ex_intro ?? (mk_config ?? 1 ?))
+ [ @(ex_intro ?? (mk_config ?? atm1 ?))
[| %
[ %
[ whd in ⊢ (??%?); >atmr_q0_q1 //
- | #Hfalse destruct ]
+ | whd in ⊢ ((??%%)→?); #Hfalse destruct ]
| #_ % // %2 @(ex_intro ?? c) % // ]
]
- | @(ex_intro ?? (mk_config ?? 2 (mk_tape ? (c::ls) (option_hd ? rs) (tail ? rs))))
+ | @(ex_intro ?? (mk_config ?? atm2 (mk_tape ? (c::ls) (option_hd ? rs) (tail ? rs))))
%
[ %
[ whd in ⊢ (??%?); >atmr_q0_q2 //
t2 = midtape ? (reverse ? rs1@c::ls) b rs2))).
definition adv_to_mark_r ≝
- λalpha,test.whileTM alpha (atmr_step alpha test) 2.
+ λalpha,test.whileTM alpha (atmr_step alpha test) atm2.
lemma wsem_adv_to_mark_r :
∀alpha,test.
definition mark_states ≝ initN 2.
+definition ms0 : mark_states ≝ mk_Sig ?? 0 (leb_true_to_le 1 2 (refl …)).
+definition ms1 : mark_states ≝ mk_Sig ?? 1 (leb_true_to_le 2 2 (refl …)).
+
definition mark ≝
λalpha:FinSet.mk_TM (FinProd … alpha FinBool) mark_states
(λp.let 〈q,a〉 ≝ p in
match a with
- [ None ⇒ 〈1,None ?〉
- | Some a' ⇒ match q with
- [ O ⇒ let 〈a'',b〉 ≝ a' in 〈1,Some ? 〈〈a'',true〉,N〉〉
- | S q ⇒ 〈1,None ?〉 ] ])
- O (λq.q == 1).
+ [ None ⇒ 〈ms1,None ?〉
+ | Some a' ⇒ match (pi1 … q) with
+ [ O ⇒ let 〈a'',b〉 ≝ a' in 〈ms1,Some ? 〈〈a'',true〉,N〉〉
+ | S q ⇒ 〈ms1,None ?〉 ] ])
+ ms0 (λq.q == ms1).
definition R_mark ≝ λalpha,t1,t2.
∀ls,c,b,rs.
*)
definition move_states ≝ initN 2.
+definition move0 : move_states ≝ mk_Sig ?? 0 (leb_true_to_le 1 2 (refl …)).
+definition move1 : move_states ≝ mk_Sig ?? 1 (leb_true_to_le 2 2 (refl …)).
definition move_r ≝
λalpha:FinSet.mk_TM alpha move_states
(λp.let 〈q,a〉 ≝ p in
match a with
- [ None ⇒ 〈1,None ?〉
- | Some a' ⇒ match q with
- [ O ⇒ 〈1,Some ? 〈a',R〉〉
- | S q ⇒ 〈1,None ?〉 ] ])
- O (λq.q == 1).
+ [ None ⇒ 〈move1,None ?〉
+ | Some a' ⇒ match (pi1 … q) with
+ [ O ⇒ 〈move1,Some ? 〈a',R〉〉
+ | S q ⇒ 〈move1,None ?〉 ] ])
+ move0 (λq.q == move1).
definition R_move_r ≝ λalpha,t1,t2.
∀ls,c,rs.
λalpha:FinSet.mk_TM alpha move_states
(λp.let 〈q,a〉 ≝ p in
match a with
- [ None ⇒ 〈1,None ?〉
- | Some a' ⇒ match q with
- [ O ⇒ 〈1,Some ? 〈a',L〉〉
- | S q ⇒ 〈1,None ?〉 ] ])
- O (λq.q == 1).
+ [ None ⇒ 〈move1,None ?〉
+ | Some a' ⇒ match pi1 … q with
+ [ O ⇒ 〈move1,Some ? 〈a',L〉〉
+ | S q ⇒ 〈move1,None ?〉 ] ])
+ move0 (λq.q == move1).
definition R_move_l ≝ λalpha,t1,t2.
∀ls,c,rs.
definition mrm_states ≝ initN 3.
+definition mrm0 : mrm_states ≝ mk_Sig ?? 0 (leb_true_to_le 1 3 (refl …)).
+definition mrm1 : mrm_states ≝ mk_Sig ?? 1 (leb_true_to_le 2 3 (refl …)).
+definition mrm2 : mrm_states ≝ mk_Sig ?? 2 (leb_true_to_le 3 3 (refl …)).
+
definition move_right_and_mark ≝
λalpha:FinSet.mk_TM (FinProd … alpha FinBool) mrm_states
(λp.let 〈q,a〉 ≝ p in
match a with
- [ None ⇒ 〈2,None ?〉
- | Some a' ⇒ match q with
- [ O ⇒ 〈1,Some ? 〈a',R〉〉
+ [ None ⇒ 〈mrm2,None ?〉
+ | Some a' ⇒ match pi1 … q with
+ [ O ⇒ 〈mrm1,Some ? 〈a',R〉〉
| S q ⇒ match q with
[ O ⇒ let 〈a'',b〉 ≝ a' in
- 〈2,Some ? 〈〈a'',true〉,N〉〉
- | S _ ⇒ 〈2,None ?〉 ] ] ])
- O (λq.q == 2).
+ 〈mrm2,Some ? 〈〈a'',true〉,N〉〉
+ | S _ ⇒ 〈mrm2,None ?〉 ] ] ])
+ mrm0 (λq.q == mrm2).
definition R_move_right_and_mark ≝ λalpha,t1,t2.
∀ls,c,d,b,rs.
definition clear_mark_states ≝ initN 3.
+definition clear0 : clear_mark_states ≝ mk_Sig ?? 0 (leb_true_to_le 1 3 (refl …)).
+definition clear1 : clear_mark_states ≝ mk_Sig ?? 1 (leb_true_to_le 2 3 (refl …)).
+definition claer2 : clear_mark_states ≝ mk_Sig ?? 2 (leb_true_to_le 3 3 (refl …)).
+
definition clear_mark ≝
λalpha:FinSet.mk_TM (FinProd … alpha FinBool) clear_mark_states
(λp.let 〈q,a〉 ≝ p in
match a with
- [ None ⇒ 〈1,None ?〉
- | Some a' ⇒ match q with
- [ O ⇒ let 〈a'',b〉 ≝ a' in 〈1,Some ? 〈〈a'',false〉,N〉〉
- | S q ⇒ 〈1,None ?〉 ] ])
- O (λq.q == 1).
+ [ None ⇒ 〈clear1,None ?〉
+ | Some a' ⇒ match pi1 … q with
+ [ O ⇒ let 〈a'',b〉 ≝ a' in 〈clear1,Some ? 〈〈a'',false〉,N〉〉
+ | S q ⇒ 〈clear1,None ?〉 ] ])
+ clear0 (λq.q == clear1).
definition R_clear_mark ≝ λalpha,t1,t2.
∀ls,c,b,rs.
| >reverse_append #Htc @Htc ]
]
qed.
-
-inductive unialpha : Type[0] ≝
-| bit : bool → unialpha
-| comma : unialpha
-| bar : unialpha
-| grid : unialpha.
-
-definition unialpha_eq ≝
- λa1,a2.match a1 with
- [ bit x ⇒ match a2 with [ bit y ⇒ ¬ xorb x y | _ ⇒ false ]
- | comma ⇒ match a2 with [ comma ⇒ true | _ ⇒ false ]
- | bar ⇒ match a2 with [ bar ⇒ true | _ ⇒ false ]
- | grid ⇒ match a2 with [ grid ⇒ true | _ ⇒ false ] ].
-
-definition DeqUnialpha ≝ mk_DeqSet unialpha unialpha_eq ?.
-* [ #x * [ #y cases x cases y normalize % // #Hfalse destruct
- | *: normalize % #Hfalse destruct ]
- |*: * [1,5,9,13: #y ] normalize % #H1 destruct % ]
-qed.
-
-definition FSUnialpha ≝
- mk_FinSet DeqUnialpha [bit true;bit false;comma;bar;grid] ?.
-@daemon
-qed.
(*
MATCH AND ADVANCE(f)
^
*)
-include "turing/universal/tests.ma".
-
-(* NO OPERATION
-
- t1 = t2
- *)
-
-definition nop_states ≝ initN 1.
-
-definition nop ≝
- λalpha:FinSet.mk_TM alpha nop_states
- (λp.let 〈q,a〉 ≝ p in 〈q,None ?〉)
- O (λ_.true).
-
-definition R_nop ≝ λalpha.λt1,t2:tape alpha.t2 = t1.
-
-lemma sem_nop :
- ∀alpha.Realize alpha (nop alpha) (R_nop alpha).
-#alpha #intape @(ex_intro ?? 1) @ex_intro [| % normalize % ]
-qed.
-
definition match_and_adv ≝
λalpha,f.ifTM ? (test_char ? f)
- (adv_both_marks alpha) (nop ?) tc_true.
+ (adv_both_marks alpha) (clear_mark ?) tc_true.
definition R_match_and_adv ≝
λalpha,f,t1,t2.
t1 = midtape (FinProd … alpha FinBool)
(l1@〈a,false〉::〈x,true〉::l0) 〈x0,true〉 (〈a0,false〉::l2) →
(f 〈x0,true〉 = true ∧ t2 = midtape ? (〈x,false〉::l0) 〈a,true〉 (reverse ? l1@〈x0,false〉::〈a0,true〉::l2))
- ∨ (f 〈x0,true〉 = false ∧ t2 = t1).
+ ∨ (f 〈x0,true〉 = false ∧
+ t2 = midtape ? (l1@〈a,false〉::〈x,true〉::l0) 〈x0,false〉 (〈a0,false〉::l2)).
lemma sem_match_and_adv :
∀alpha,f.Realize ? (match_and_adv alpha f) (R_match_and_adv alpha f).
#alpha #f #intape
-cases (sem_if ? (test_char ? f) … tc_true (sem_test_char ? f) (sem_adv_both_marks alpha) (sem_nop ?) intape)
+cases (sem_if ? (test_char ? f) … tc_true (sem_test_char ? f) (sem_adv_both_marks alpha) (sem_clear_mark ?) intape)
#k * #outc * #Hloop #Hif @(ex_intro ?? k) @(ex_intro ?? outc)
% [ @Hloop ] -Hloop
cases Hif
| * #ta * whd in ⊢ (%→%→?); #Hta #Houtc
#l0 #x #a #l1 #x0 #a0 #l2 #Hl1 #Hintape
>Hintape in Hta; #Hta cases (Hta … (refl ??)) -Hta #Hf #Hta %2 %
- [ @Hf | >Houtc @Hta ]
+ [ @Hf | >(Houtc … Hta) % ]
]
qed.
definition R_comp_step_subcase ≝
λalpha,c,RelseM,t1,t2.
- ∀l0,x,a,l1,x0,a0,l2. (∀c.memb ? c l1 = true → is_marked ? c = false) →
- t1 = midtape (FinProd … alpha FinBool)
- l0 〈x,true〉 (〈a,false〉::l1@〈x0,true〉::〈a0,false〉::l2) →
- (〈x,true〉 = c ∧ x = x0 ∧
- t2 = midtape ? (〈x,false〉::l0) 〈a,true〉 (l1@〈x0,false〉::〈a0,true〉::l2))
- ∨ (〈x,true〉 = c ∧ x ≠ x0 ∧
- t2 = midtape (FinProd … alpha FinBool)
- (reverse ? l1@〈a,false〉::〈x,true〉::l0) 〈x0,true〉 (〈a0,false〉::l2))
- ∨ (〈x,true〉 ≠ c ∧ RelseM t1 t2).
+ ∀l0,x,rs.t1 = midtape (FinProd … alpha FinBool) l0 〈x,true〉 rs →
+ (〈x,true〉 = c ∧
+ ∀a,l1,x0,a0,l2. (∀c.memb ? c l1 = true → is_marked ? c = false) →
+ rs = 〈a,false〉::l1@〈x0,true〉::〈a0,false〉::l2 →
+ ((x = x0 ∧
+ t2 = midtape ? (〈x,false〉::l0) 〈a,true〉 (l1@〈x0,false〉::〈a0,true〉::l2)) ∨
+ (x ≠ x0 ∧
+ t2 = midtape (FinProd … alpha FinBool)
+ (reverse ? l1@〈a,false〉::〈x,true〉::l0) 〈x0,false〉 (〈a0,false〉::l2)))) ∨
+ (〈x,true〉 ≠ c ∧ RelseM t1 t2).
lemma sem_comp_step_subcase :
∀alpha,c,elseM,RelseM.
% [ @Hloop ] -Hloop cases HR -HR
[ * #ta * whd in ⊢ (%→?); #Hta * #tb * whd in ⊢ (%→?); #Htb
* #tc * whd in ⊢ (%→?); #Htc whd in ⊢ (%→?); #Houtc
- #l0 #x #a #l1 #x0 #a0 #l2 #Hl1 #Hintape %
- >Hintape in Hta; #Hta cases (Hta ? (refl ??)) -Hta
- #Hx #Hta lapply (Htb … Hta) -Htb #Htb
- cases (Htc … Htb) [ * #Hfalse normalize in Hfalse; destruct (Hfalse) ]
- -Htc * #_ #Htc lapply (Htc l1 〈x0,true〉 (〈a0,false〉::l2) (refl ??) (refl ??) Hl1)
- -Htc #Htc cases (Houtc ???????? Htc) -Houtc
- [ * #Hx0 #Houtc % %
- [ % [ @(\P Hx) | <(\P Hx0) in Hx; #Hx lapply (\P Hx) #Hx' destruct (Hx') % ]
- | >Houtc >reverse_reverse % ]
- | * #Hx0 #Houtc %2 %
- [ % [ @(\P Hx) | <(\P Hx) in Hx0; #Hx0 lapply (\Pf Hx0) @not_to_not #Hx' >Hx' %]
- | >Houtc @Htc ]
- | (* members of lists are invariant under reverse *) @daemon ]
-| * #ta * whd in ⊢ (%→?); #Hta #Houtc
- #l0 #x #a #l1 #x0 #a0 #l2 #Hl1 #Hintape %2
- >Hintape in Hta; #Hta cases (Hta ? (refl ??)) -Hta #Hx #Hta %
- [ @(\Pf Hx)
- | <Hta @Houtc ]
+ #l0 #x #rs #Hintape cases (true_or_false (〈x,true〉==c)) #Hc
+ [ % % [ @(\P Hc) ]
+ #a #l1 #x0 #a0 #l2 #Hl1 #Hrs >Hrs in Hintape; #Hintape
+ >Hintape in Hta; #Hta cases (Hta ? (refl ??)) -Hta
+ #Hx #Hta lapply (Htb … Hta) -Htb #Htb
+ cases (Htc … Htb) [ * #Hfalse normalize in Hfalse; destruct (Hfalse) ]
+ -Htc * #_ #Htc lapply (Htc l1 〈x0,true〉 (〈a0,false〉::l2) (refl ??) (refl ??) Hl1)
+ -Htc #Htc cases (Houtc ???????? Htc) -Houtc
+ [ * #Hx0 #Houtc %
+ % [ <(\P Hx0) in Hx; #Hx lapply (\P Hx) #Hx' destruct (Hx') %
+ | >Houtc >reverse_reverse % ]
+ | * #Hx0 #Houtc %2
+ % [ <(\P Hx) in Hx0; #Hx0 lapply (\Pf Hx0) @not_to_not #Hx' >Hx' %
+ | >Houtc % ]
+ | (* members of lists are invariant under reverse *) @daemon ]
+ | %2 % [ @(\Pf Hc) ]
+ >Hintape in Hta; #Hta cases (Hta ? (refl ??)) -Hta #Hx #Hta
+ >Hx in Hc;#Hc destruct (Hc) ]
+| * #ta * whd in ⊢ (%→?); #Hta #Helse #ls #c0 #rs #Hintape %2
+ >Hintape in Hta; #Hta cases (Hta ? (refl ??)) -Hta #Hc #Hta %
+ [ @(\Pf Hc) | <Hta @Helse ]
]
qed.
+(*
+- se marcato, itero
+- se non è marcato
+ + se è un bit, ho fallito il confronto della tupla corrente
+ + se è un separatore, la tupla fa match
-(*
- MARK NEXT TUPLE machine
- (partially axiomatized)
+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.
+
+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.
- marks the first character after the first bar (rightwards)
- *)
+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; #Hleft cases (Hleft ? (refl ??)) -Hleft
+ cases c in Hintape; #c' #b #Hintape 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; #Hleft
+ cases (Hleft ? (refl ??)) -Hleft
+ #Hc #Hta % // >Hright //
+]
+qed.
-axiom myalpha : FinSet.
-axiom is_bar : FinProd … myalpha FinBool → bool.
-axiom is_grid : FinProd … myalpha FinBool → bool.
-definition bar_or_grid ≝ λc.is_bar c ∨ is_grid c.
-axiom bar : FinProd … myalpha FinBool.
-axiom grid : FinProd … myalpha FinBool.
+definition compare ≝
+ whileTM ? comp_step (inr … (inl … (inr … start_nop))).
-definition mark_next_tuple ≝
- seq ? (adv_to_mark_r ? bar_or_grid)
- (ifTM ? (test_char ? is_bar)
- (move_r_and_mark ?) (nop ?) 1).
+(*
+definition R_compare :=
+ λt1,t2.
+ (t
+
+ ∀ls,c,b,rs.t1 = midtape ? ls 〈c,b〉 rs →
+ (b = true → rs = ....) →
+ (b = false ∧ ....) ∨
+ (b = true ∧
+
+ rs = cs@l1@〈c0,true〉::cs0@l2
+ (
+
+
+ ls 〈c,b〉 cs l1 〈c0,b0〉 cs0 l2
+
+
+ACCETTAZIONE:
+ ls (hd (Ls@〈grid,false〉))* (tail (Ls@〈grid,false〉)) l1 (hd (Ls@〈comma,false〉))* (tail (Ls@〈comma,false〉)) l2
+ ^^^^^^^^^^^^^^^^^^^^^^^
+
+ ls Ls 〈grid,false〉 l1 Ls 〈comma,true〉 l2
+ ^^^^^^^^^^^^
-definition R_mark_next_tuple ≝
+RIFIUTO: c ≠ d
+
+ ls (hd (Ls@〈c,false〉))* (tail (Ls@〈c,false〉)) l1 (hd (Ls@〈d,false〉))* (tail (Ls@〈d,false〉)) l2
+ ^^^^^^^^^^^^^^^^^^^^^^^
+
+
+ ls Ls 〈c,true〉 l1 Ls 〈d,false〉 l2
+ ^^^^^^^^
+
+ ).
+
+ |bs| = |b0s| →
+ (∃la,d.〈b,true〉::bs = la@[〈grid,d〉] ∧ ∀x.memb ? x la → is_bit (\fst x) = true) →
+ (∃lb,d0.〈b0,true〉::b0s = lb@[〈comma,d0〉] ∧ ∀x.memb ? x lb → is_bit (\fst x) = true) →
+ t1 = midtape ? l0 〈b,true〉 (bs@l1@〈b0,true〉::b0s@l2 →
+
+ mk_tape left (option current) right
+
+ (b = grid ∧ b0 = comma ∧ bs = [] ∧ b0s = [] ∧
+ t2 = midtape ? l0 〈grid,false〉 (l1@〈comma,true〉::l2)) ∨
+ (b = bit x ∧ b = c ∧ bs = b0s
+ *)
+definition R_compare :=
λt1,t2.
- ∀ls,c,rs1,rs2.
- (* c non può essere un separatore ... speriamo *)
- t1 = midtape ? ls c (rs1@grid::rs2) →
- memb ? grid rs1 = false → bar_or_grid c = false →
- (∃rs3,rs4,d,b.rs1 = rs3 @ bar :: rs4 ∧
- memb ? bar rs3 = false ∧
- Some ? 〈d,b〉 = option_hd ? (rs4@grid::rs2) ∧
- t2 = midtape ? (bar::reverse ? rs3@c::ls) 〈d,true〉 (tail ? (rs4@grid::rs2)))
- ∨
- (memb ? bar rs1 = false ∧
- t2 = midtape ? (reverse ? rs1@c::ls) grid rs2).
-
-axiom tech_split :
- ∀A:DeqSet.∀f,l.
- (∀x.memb A x l = true → f x = false) ∨
- (∃l1,c,l2.f c = true ∧ l = l1@c::l2 ∧ ∀x.memb ? x l1 = true → f c = false).
-(*#A #f #l elim l
-[ % #x normalize #Hfalse *)
-
-theorem sem_mark_next_tuple :
- Realize ? mark_next_tuple R_mark_next_tuple.
-#intape
-lapply (sem_seq ? (adv_to_mark_r ? bar_or_grid)
- (ifTM ? (test_char ? is_bar) (mark ?) (nop ?) 1) ????)
-[@sem_if //
-| //
-|||#Hif cases (Hif intape) -Hif
- #j * #outc * #Hloop * #ta * #Hleft #Hright
- @(ex_intro ?? j) @ex_intro [|% [@Hloop] ]
- -Hloop
- #ls #c #rs1 #rs2 #Hrs #Hrs1 #Hc
- cases (Hleft … Hrs)
- [ * #Hfalse >Hfalse in Hc; #Htf destruct (Htf)
- | * #_ #Hta cases (tech_split ? is_bar rs1)
- [ #H1 lapply (Hta rs1 grid rs2 (refl ??) ? ?)
- [ (* Hrs1, H1 *) @daemon
- | (* bar_or_grid grid = true *) @daemon
- | -Hta #Hta cases Hright
- [ * #tb * whd in ⊢ (%→?); #Hcurrent
- @False_ind cases(Hcurrent grid ?)
- [ #Hfalse (* grid is not a bar *) @daemon
- | >Hta % ]
- | * #tb * whd in ⊢ (%→?); #Hcurrent
- cases (Hcurrent grid ?)
- [ #_ #Htb whd in ⊢ (%→?); #Houtc
- %2 %
- [ (* H1 *) @daemon
- | >Houtc >Htb >Hta % ]
- | >Hta % ]
+ ∀ls,c,rs.t1 = midtape (FinProd … FSUnialpha FinBool) ls c rs →
+ (∀c'.bit_or_null c' = false → c = 〈c',true〉 → t2 = midtape ? ls 〈c',false〉 rs) ∧
+ (∀c'. c = 〈c',false〉 → t2 = t1) ∧
+ ∀b,b0,bs,b0s,l1,l2.
+ |bs| = |b0s| →
+ (∀c.memb (FinProd … FSUnialpha FinBool) c bs = true → bit_or_null (\fst c) = true) →
+ (∀c.memb (FinProd … FSUnialpha FinBool) c b0s = true → bit_or_null (\fst c) = true) →
+ (∀c.memb ? c bs = true → is_marked ? c = false) →
+ (∀c.memb ? c b0s = true → is_marked ? c = false) →
+ (∀c.memb ? c l1 = true → is_marked ? c = false) →
+ c = 〈b,true〉 → bit_or_null b = true →
+ rs = bs@〈grid,false〉::l1@〈b0,true〉::b0s@〈comma,false〉::l2 →
+ (〈b,true〉::bs = 〈b0,true〉::b0s ∧
+ t2 = midtape ? (reverse ? bs@〈b,false〉::ls)
+ 〈grid,false〉 (l1@〈b0,false〉::b0s@〈comma,true〉::l2)) ∨
+ (∃la,c',d',lb,lc.c' ≠ d' ∧
+ 〈b,false〉::bs = la@〈c',false〉::lb ∧
+ 〈b0,false〉::b0s = la@〈d',false〉::lc ∧
+ t2 = midtape (FinProd … FSUnialpha FinBool) (reverse ? la@
+ reverse ? l1@
+ 〈grid,false〉::
+ reverse ? lb@
+ 〈c',true〉::
+ reverse ? la@ls)
+ 〈d',false〉 (lc@〈comma,false〉::l2)).
+
+lemma list_ind2 :
+ ∀T1,T2:Type[0].∀l1:list T1.∀l2:list T2.∀P:list T1 → list T2 → Prop.
+ length ? l1 = length ? l2 →
+ (P [] []) →
+ (∀tl1,tl2,hd1,hd2. P tl1 tl2 → P (hd1::tl1) (hd2::tl2)) →
+ P l1 l2.
+#T1 #T2 #l1 #l2 #P #Hl #Pnil #Pcons
+generalize in match Hl; generalize in match l2;
+elim l1
+[#l2 cases l2 // normalize #t2 #tl2 #H destruct
+|#t1 #tl1 #IH #l2 cases l2
+ [normalize #H destruct
+ |#t2 #tl2 #H @Pcons @IH normalize in H; destruct // ]
+]
+qed.
+
+lemma list_cases_2 :
+ ∀T1,T2:Type[0].∀l1:list T1.∀l2:list T2.∀P:Prop.
+ length ? l1 = length ? l2 →
+ (l1 = [] → l2 = [] → P) →
+ (∀hd1,hd2,tl1,tl2.l1 = hd1::tl1 → l2 = hd2::tl2 → P) → P.
+#T1 #T2 #l1 #l2 #P #Hl @(list_ind2 … Hl)
+[ #Pnil #Pcons @Pnil //
+| #tl1 #tl2 #hd1 #hd2 #IH1 #IH2 #Hp @Hp // ]
+qed.
+
+lemma wsem_compare : WRealize ? compare R_compare.
+#t #i #outc #Hloop
+lapply (sem_while ?????? sem_comp_step t i outc Hloop) [%]
+-Hloop * #t1 * #Hstar @(star_ind_l ??????? Hstar)
+[ #tapea whd in ⊢ (%→?); #Rfalse #ls #c #rs #Htapea %
+ [ %
+ [ #c' #Hc' #Hc lapply (Rfalse … Htapea) -Rfalse * >Hc
+ whd in ⊢ (??%?→?); #Hfalse destruct (Hfalse)
+ | #c' #Hc lapply (Rfalse … Htapea) -Rfalse * #_
+ #Htrue @Htrue ]
+ | #b #b0 #bs #b0s #l1 #l2 #Hlen #Hbs1 #Hb0s1 #Hbs2 #Hb0s2 #Hl1 #Hc
+ cases (Rfalse … Htapea) -Rfalse >Hc whd in ⊢ (??%?→?);#Hfalse destruct (Hfalse)
+ ]
+| #tapea #tapeb #tapec #Hleft #Hright #IH #Htapec lapply (IH Htapec) -Htapec -IH #IH
+ whd in Hleft; #ls #c #rs #Htapea cases (Hleft … Htapea) -Hleft
+ #c' * #Hc >Hc cases (true_or_false (bit_or_null c')) #Hc'
+ [2: *
+ [ * >Hc' #H @False_ind destruct (H)
+ | * #_ #Htapeb cases (IH … Htapeb) * #_ #H #_ %
+ [%
+ [#c1 #Hc1 #Heqc destruct (Heqc) <Htapeb @(H c1) %
+ |#c1 #Hfalse destruct (Hfalse)
+ ]
+ |#b #b0 #bs #b0s #l1 #l2 #_ #_ #_ #_ #_ #_
+ #Heq destruct (Heq) >Hc' #Hfalse @False_ind destruct (Hfalse)
+ ]
+ ]
+ |#Hleft %
+ [ %
+ [ #c'' #Hc'' #Heq destruct (Heq) >Hc'' in Hc'; #H destruct (H)
+ | #c0 #Hfalse destruct (Hfalse)
+ ]
+ |#b #b0 #bs #b0s #l1 #l2 #Hlen #Hbs1 #Hb0s1 #Hbs2 #Hb0s2 #Hl1
+ #Heq destruct (Heq) #_ #Hrs cases Hleft -Hleft
+ [2: * >Hc' #Hfalse @False_ind destruct ] * #_
+ @(list_cases_2 … Hlen)
+ [ #Hbs #Hb0s generalize in match Hrs; >Hbs in ⊢ (%→?); >Hb0s in ⊢ (%→?);
+ -Hrs #Hrs normalize in Hrs; #Hleft cases (Hleft ????? Hrs ?) -Hleft
+ [ * #Heqb #Htapeb cases (IH … Htapeb) -IH * #IH #_ #_
+ % %
+ [ >Heqb >Hbs >Hb0s %
+ | >Hbs >Hb0s @IH %
+ ]
+ |* #Hneqb #Htapeb %2
+ @(ex_intro … [ ]) @(ex_intro … b)
+ @(ex_intro … b0) @(ex_intro … [ ])
+ @(ex_intro … [ ]) %
+ [ % [ % [@sym_not_eq //| >Hbs %] | >Hb0s %]
+ | cases (IH … Htapeb) -IH * #_ #IH #_ >(IH ? (refl ??))
+ @Htapeb
+ ]
+ | @Hl1 ]
+ | * #b' #bitb' * #b0' #bitb0' #bs' #b0s' #Hbs #Hb0s
+ generalize in match Hrs; >Hbs in ⊢ (%→?); >Hb0s in ⊢ (%→?);
+ cut (bit_or_null b' = true ∧ bit_or_null b0' = true ∧
+ bitb' = false ∧ bitb0' = false)
+ [ % [ % [ % [ >Hbs in Hbs1; #Hbs1 @(Hbs1 〈b',bitb'〉) @memb_hd
+ | >Hb0s in Hb0s1; #Hb0s1 @(Hb0s1 〈b0',bitb0'〉) @memb_hd ]
+ | >Hbs in Hbs2; #Hbs2 @(Hbs2 〈b',bitb'〉) @memb_hd ]
+ | >Hb0s in Hb0s2; #Hb0s2 @(Hb0s2 〈b0',bitb0'〉) @memb_hd ]
+ | * * * #Ha #Hb #Hc #Hd >Hc >Hd
+ #Hrs #Hleft
+ cases (Hleft b' (bs'@〈grid,false〉::l1) b0 b0'
+ (b0s'@〈comma,false〉::l2) ??) -Hleft
+ [ 3: >Hrs normalize @eq_f >associative_append %
+ | * #Hb0 #Htapeb cases (IH …Htapeb) -IH * #_ #_ #IH
+ cases (IH b' b0' bs' b0s' (l1@[〈b0,false〉]) l2 ??????? Ha ?) -IH
+ [ * #Heq #Houtc % %
+ [ >Hb0 @eq_f >Hbs in Heq; >Hb0s in ⊢ (%→?); #Heq
+ destruct (Heq) >Hb0s >Hc >Hd %
+ | >Houtc >Hbs >Hb0s >Hc >Hd >reverse_cons >associative_append
+ >associative_append %
+ ]
+ | * #la * #c' * #d' * #lb * #lc * * * #H1 #H2 #H3 #H4 %2
+ @(ex_intro … (〈b,false〉::la)) @(ex_intro … c') @(ex_intro … d')
+ @(ex_intro … lb) @(ex_intro … lc)
+ % [ % [ % // >Hbs >Hc >H2 % | >Hb0s >Hd >H3 >Hb0 % ]
+ | >H4 >Hbs >Hb0s >Hc >Hd >Hb0 >reverse_append
+ >reverse_cons >reverse_cons
+ >associative_append >associative_append
+ >associative_append >associative_append %
+ ]
+ | generalize in match Hlen; >Hbs >Hb0s
+ normalize #Hlen destruct (Hlen) @e0
+ | #c0 #Hc0 @Hbs1 >Hbs @memb_cons //
+ | #c0 #Hc0 @Hb0s1 >Hb0s @memb_cons //
+ | #c0 #Hc0 @Hbs2 >Hbs @memb_cons //
+ | #c0 #Hc0 @Hb0s2 >Hb0s @memb_cons //
+ | #c0 #Hc0 cases (memb_append … Hc0)
+ [ @Hl1 | #Hc0' >(memb_single … Hc0') % ]
+ | %
+ | >associative_append >associative_append % ]
+ | * #Hneq #Htapeb %2
+ @(ex_intro … []) @(ex_intro … b) @(ex_intro … b0)
+ @(ex_intro … bs) @(ex_intro … b0s) %
+ [ % // % // @sym_not_eq //
+ | >Hbs >Hb0s >Hc >Hd >reverse_cons >associative_append
+ >reverse_append in Htapeb; >reverse_cons
+ >associative_append >associative_append
+ #Htapeb <Htapeb
+ cases (IH … Htapeb) -Htapeb -IH * #_ #IH #_ @(IH ? (refl ??))
+ ]
+ | #c1 #Hc1 cases (memb_append … Hc1) #Hyp
+ [ @Hbs2 >Hbs @memb_cons @Hyp
+ | cases (orb_true_l … Hyp)
+ [ #Hyp2 >(\P Hyp2) %
+ | @Hl1
+ ]
+ ]
]
- ]
- | * #rs3 * #c0 * #rs4 * * #Hc0 #Hsplit #Hrs3
- % @(ex_intro ?? rs3) @(ex_intro ?? rs4)
- lapply (Hta rs3 c0 (rs4@grid::rs2) ???)
- [ #x #Hrs3' (* Hrs1, Hrs3, Hsplit *) @daemon
- | (* bar → bar_or_grid *) @daemon
- | >Hsplit >associative_append % ] -Hta #Hta
- cases Hright
- [ * #tb * whd in ⊢ (%→?); #Hta'
- whd in ⊢ (%→?); #Htb
- cases (Hta' c0 ?)
- [ #_ #Htb' >Htb' in Htb; #Htb
- generalize in match Hsplit; -Hsplit
- cases rs4 in Hta;
- [ >(eq_pair_fst_snd … grid)
- #Hta #Hsplit >(Htb … Hta)
- >(?:c0 = bar)
- [ @(ex_intro ?? (\fst grid)) @(ex_intro ?? (\snd grid))
- % [ % [ % [ (* Hsplit *) @daemon |(*Hrs3*) @daemon ] | % ] | % ]
- | (* Hc0 *) @daemon ]
- | #r5 #rs5 >(eq_pair_fst_snd … r5)
- #Hta #Hsplit >(Htb … Hta)
- >(?:c0 = bar)
- [ @(ex_intro ?? (\fst r5)) @(ex_intro ?? (\snd r5))
- % [ % [ % [ (* Hc0, Hsplit *) @daemon | (*Hrs3*) @daemon ] | % ]
- | % ] | (* Hc0 *) @daemon ] ] | >Hta % ]
- | * #tb * whd in ⊢ (%→?); #Hta'
- whd in ⊢ (%→?); #Htb
- cases (Hta' c0 ?)
- [ #Hfalse @False_ind >Hfalse in Hc0;
- #Hc0 destruct (Hc0)
- | >Hta % ]
-]]]]
-qed.
\ No newline at end of file
+]]]]]
+qed.
+
+axiom sem_compare : Realize ? compare R_compare.
\ No newline at end of file
projects / helm.git / blobdiff