cases (halt sig M acc) %
qed.
+lemma halt_while_not_acc :
+ ∀sig,M,acc,s.s == acc = false → halt sig (whileTM sig M acc) s = halt sig M s.
+#sig #M #acc #s #neqs normalize >neqs
+cases (halt sig M s) %
+qed.
+
lemma step_while_acc :
∀sig,M,acc,c.cstate ?? c = acc →
step sig (whileTM sig M acc) c = initc … (ctape ?? c).
]
qed.
-(* inductive move_states : Type[0] ≝
-| start : move_states
-| q1 : move_states
-| q2 : move_states
-| q3 : move_states
-| qacc : move_states
-| qfail : move_states.
-
-definition
-*)
-
-definition mystates : FinSet → FinSet ≝ λalpha:FinSet.FinProd (initN 5) alpha.
-
-definition move_char ≝
- λalpha:FinSet.λsep:alpha.
- mk_TM alpha (mystates alpha)
- (λp.let 〈q,a〉 ≝ p in
- let 〈q',b〉 ≝ q in
- match a with
- [ None ⇒ 〈〈4,sep〉,None ?〉
- | Some a' ⇒
- match q' with
- [ O ⇒ (* qinit *)
- match a' == sep with
- [ true ⇒ 〈〈4,sep〉,None ?〉
- | false ⇒ 〈〈1,a'〉,Some ? 〈a',L〉〉 ]
- | S q' ⇒ match q' with
- [ O ⇒ (* q1 *)
- 〈〈2,a'〉,Some ? 〈b,R〉〉
- | S q' ⇒ match q' with
- [ O ⇒ (* q2 *)
- 〈〈3,sep〉,Some ? 〈b,R〉〉
- | S q' ⇒ match q' with
- [ O ⇒ (* qacc *)
- 〈〈3,sep〉,None ?〉
- | S q' ⇒ (* qfail *)
- 〈〈4,sep〉,None ?〉 ] ] ] ] ])
- 〈0,sep〉
- (λq.let 〈q',a〉 ≝ q in q' == 3 ∨ q' == 4).
-
-definition mk_tape :
- ∀sig:FinSet.list sig → option sig → list sig → tape sig ≝
- λsig,lt,c,rt.match c with
- [ Some c' ⇒ midtape sig lt c' rt
- | None ⇒ match lt with
- [ nil ⇒ match rt with
- [ nil ⇒ niltape ?
- | cons r0 rs0 ⇒ leftof ? r0 rs0 ]
- | cons l0 ls0 ⇒ rightof ? l0 ls0 ] ].
-
-lemma cmove_q0_q1 :
- ∀alpha:FinSet.∀sep,a,ls,a0,rs.
- a0 == sep = false →
- step alpha (move_char alpha sep)
- (mk_config ?? 〈0,a〉 (mk_tape … ls (Some ? a0) rs)) =
- mk_config alpha (states ? (move_char alpha sep)) 〈1,a0〉
- (tape_move_left alpha ls a0 rs).
-#alpha #sep #a *
-[ #a0 #rs #Ha0 whd in ⊢ (??%?);
- normalize in match (trans ???); >Ha0 %
-| #a1 #ls #a0 #rs #Ha0 whd in ⊢ (??%?);
- normalize in match (trans ???); >Ha0 %
-]
-qed.
-
-lemma cmove_q1_q2 :
- ∀alpha:FinSet.∀sep,a,ls,a0,rs.
- step alpha (move_char alpha sep)
- (mk_config ?? 〈1,a〉 (mk_tape … ls (Some ? a0) rs)) =
- mk_config alpha (states ? (move_char alpha sep)) 〈2,a0〉
- (tape_move_right alpha ls a rs).
-#alpha #sep #a #ls #a0 * //
-qed.
-
-lemma cmove_q2_q3 :
- ∀alpha:FinSet.∀sep,a,ls,a0,rs.
- step alpha (move_char alpha sep)
- (mk_config ?? 〈2,a〉 (mk_tape … ls (Some ? a0) rs)) =
- mk_config alpha (states ? (move_char alpha sep)) 〈3,sep〉
- (tape_move_right alpha ls a rs).
-#alpha #sep #a #ls #a0 * //
-qed.
-
-definition option_hd ≝
- λA.λl:list A. match l with
- [ nil ⇒ None ?
- | cons a _ ⇒ Some ? a ].
-
-definition Rmove_char_true ≝
- λalpha,sep,t1,t2.
- ∀a,b,ls,rs. b ≠ sep →
- t1 = midtape alpha (a::ls) b rs →
- t2 = mk_tape alpha (a::b::ls) (option_hd ? rs) (tail ? rs).
-
-definition Rmove_char_false ≝
- λalpha,sep,t1,t2.
- (current alpha t1 = None alpha → t2 = t1) ∧
- (current alpha t1 = Some alpha sep → t2 = t1).
-
-lemma loop_S_true :
- ∀A,n,f,p,a. p a = true →
- loop A (S n) f p a = Some ? a. /2/
-qed.
-
-lemma loop_S_false :
- ∀A,n,f,p,a. p a = false →
- loop A (S n) f p a = loop A n f p (f a).
-normalize #A #n #f #p #a #Hpa >Hpa %
-qed.
-
-notation < "𝐅" non associative with precedence 90
- for @{'bigF}.
-notation < "𝐃" non associative with precedence 90
- for @{'bigD}.
-
-interpretation "FinSet" 'bigF = (mk_FinSet ???).
-interpretation "DeqSet" 'bigD = (mk_DeqSet ???).
-
-lemma trans_init_sep:
- ∀alpha,sep,x.
- trans ? (move_char alpha sep) 〈〈0,x〉,Some ? sep〉 = 〈〈4,sep〉,None ?〉.
-#alpha #sep #x normalize >(\b ?) //
-qed.
-
-lemma trans_init_not_sep:
- ∀alpha,sep,x,y.y == sep = false →
- trans ? (move_char alpha sep) 〈〈0,x〉,Some ? y〉 = 〈〈1,y〉,Some ? 〈y,L〉〉.
-#alpha #sep #x #y #H1 normalize >H1 //
-qed.
-
-lemma sem_move_char :
- ∀alpha,sep.
- accRealize alpha (move_char alpha sep)
- 〈3,sep〉 (Rmove_char_true alpha sep) (Rmove_char_false alpha sep).
-#alpha #sep *
-[@(ex_intro ?? 2)
- @(ex_intro … (mk_config ?? 〈4,sep〉 (niltape ?)))
- % [% [whd in ⊢ (??%?);% |#Hfalse destruct ] |#H1 whd % #_ % ]
-|#l0 #lt0 @(ex_intro ?? 2)
- @(ex_intro … (mk_config ?? 〈4,sep〉 (leftof ? l0 lt0)))
- % [% [whd in ⊢ (??%?);% |#Hfalse destruct ] |#H1 whd % #_ % ]
-|#r0 #rt0 @(ex_intro ?? 2)
- @(ex_intro … (mk_config ?? 〈4,sep〉 (rightof ? r0 rt0)))
- % [% [whd in ⊢ (??%?);% |#Hfalse destruct ] |#H1 whd % #_ % ]
-| #lt #c #rt cases (true_or_false (c == sep)) #Hc
- [ @(ex_intro ?? 2)
- @(ex_intro ?? (mk_config ?? 〈4,sep〉 (midtape ? lt c rt)))
- %
- [%
- [ >(\P Hc) >loop_S_false //
- >loop_S_true
- [ @eq_f whd in ⊢ (??%?); >trans_init_sep %
- |>(\P Hc) whd in ⊢(??(???(???%))?);
- >trans_init_sep % ]
- | #Hfalse destruct
+theorem terminate_while: ∀sig,M,acc,Rtrue,Rfalse,t.
+ halt sig M acc = true →
+ accRealize sig M acc Rtrue Rfalse →
+ WF ? (inv … Rtrue) t → Terminate sig (whileTM sig M acc) t.
+#sig #M #acc #Rtrue #Rfalse #t #Hacctrue #HM #HWF elim HWF
+#t1 #H #Hind cases (HM … t1) #i * #outc * * #Hloop
+#Htrue #Hfalse cases (true_or_false (cstate … outc == acc)) #Hcase
+ [cases (Hind ? (Htrue … (\P Hcase))) #iwhile * #outcfinal
+ #Hloopwhile @(ex_intro … (i+iwhile))
+ @(ex_intro … outcfinal) @(loop_merge … outc … Hloopwhile)
+ [@(λc.halt sig M (cstate … c))
+ |* #s0 #t0 normalize cases (s0 == acc) normalize
+ [ cases (halt sig M s0) //
+ | cases (halt sig M s0) normalize //
]
- |#_ % #_ % ]
- | @(ex_intro ?? 4)
- cases lt
- [ @ex_intro
- [|%
- [ %
- [ >loop_S_false //
- >cmove_q0_q1 //
- | normalize in ⊢ (%→?); #Hfalse destruct (Hfalse)
- ]
- | normalize in ⊢ (%→?); #_ %
- [ normalize in ⊢ (%→?); #Hfalse destruct (Hfalse)
- | normalize in ⊢ (%→?); #Hfalse destruct (Hfalse)
- @False_ind @(absurd ?? (\Pf Hc)) %
- ]
- ]
- ]
- | #l0 #lt @ex_intro
- [| %
- [ %
- [ >loop_S_false //
- >cmove_q0_q1 //
- | #_ #a #b #ls #rs #Hb #Htape
- destruct (Htape)
- >cmove_q1_q2
- >cmove_q2_q3
- cases rs normalize //
- ]
- | normalize in ⊢ (% → ?); * #Hfalse
- @False_ind /2/
- ]
+ |@(loop_lift ?? i (λc.c) ?
+ (step ? (whileTM ? M acc)) ?
+ (λc.halt sig M (cstate ?? c)) ??
+ ?? Hloop)
+ [ #x %
+ | * #s #t #Hx whd in ⊢ (??%%); >while_trans_false
+ [%
+ |% #Hfalse <Hfalse in Hacctrue; >Hx #H0 destruct ]
]
+ |@step_while_acc @(\P Hcase)
+ |>(\P Hcase) @halt_while_acc
+ ]
+ |@(ex_intro … i) @(ex_intro … outc)
+ @(loop_lift_acc ?? i (λc.c) ?????? (λc.cstate ?? c == acc) ???? Hloop)
+ [#x #Hx >(\P Hx) //
+ |#x @halt_while_not_acc
+ |#x #H whd in ⊢ (??%%); >while_trans_false [%]
+ % #eqx >eqx in H; >Hacctrue #H destruct
+ |@Hcase
]
]
-]
qed.
-definition R_while_cmove :
- λalpha,sep,t1,t2.
- ∀a,b,ls,rs. b ≠ sep → memb ? sep rs = false →
- t1 = midtape alpha (a::ls) b (rs@sep::rs') →
- t2 = midtape alpha (a::rev ? rs@b::ls) sep rs'.
+(*
+axiom terminate_while: ∀sig,M,acc,Rtrue,Rfalse,t.
+ halt sig M acc = true →
+ accRealize sig M acc Rtrue Rfalse →
+ ∃t1. Rfalse t t1 → Terminate sig (whileTM sig M acc) t.
+*)
(* (*
projects / helm.git / blobdiff