623 by (cases P) simp |
623 by (cases P) simp |
624 |
624 |
625 inductive eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where "eq x x" |
625 inductive eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where "eq x x" |
626 |
626 |
627 lemma eq_is_eq: "eq x y \<equiv> (x = y)" |
627 lemma eq_is_eq: "eq x y \<equiv> (x = y)" |
628 by (rule eq_reflection) (auto intro: eq.intros elim: eq.cases) |
628 by (rule eq_reflection) (auto intro: eq.intros elim: eq.cases) |
|
629 |
|
630 ML {* |
|
631 signature PREDICATE = |
|
632 sig |
|
633 datatype 'a pred = Seq of (unit -> 'a seq) |
|
634 and 'a seq = Empty | Insert of 'a * 'a pred | Join of 'a pred * 'a seq |
|
635 val yield: 'a pred -> ('a * 'a pred) option |
|
636 val yieldn: int -> 'a pred -> 'a list * 'a pred |
|
637 end; |
|
638 |
|
639 structure Predicate : PREDICATE = |
|
640 struct |
|
641 |
|
642 @{code_datatype pred = Seq}; |
|
643 @{code_datatype seq = Empty | Insert | Join}; |
|
644 |
|
645 fun yield (Seq f) = next (f ()) |
|
646 and next @{code Empty} = NONE |
|
647 | next (@{code Insert} (x, P)) = SOME (x, P) |
|
648 | next (@{code Join} (P, xq)) = (case yield P |
|
649 of NONE => next xq |
|
650 | SOME (x, Q) => SOME (x, @{code Seq} (fn _ => @{code Join} (Q, xq)))) |
|
651 |
|
652 fun anamorph f k x = (if k = 0 then ([], x) |
|
653 else case f x |
|
654 of NONE => ([], x) |
|
655 | SOME (v, y) => let |
|
656 val (vs, z) = anamorph f (k - 1) y |
|
657 in (v :: vs, z) end) |
|
658 |
|
659 fun yieldn P = anamorph yield P; |
|
660 |
|
661 end; |
|
662 *} |
|
663 |
|
664 code_reserved Eval Predicate |
|
665 |
|
666 code_type pred and seq |
|
667 (Eval "_/ Predicate.pred" and "_/ Predicate.seq") |
|
668 |
|
669 code_const Seq and Empty and Insert and Join |
|
670 (Eval "Predicate.Seq" and "Predicate.Empty" and "Predicate.Insert/ (_,/ _)" and "Predicate.Join/ (_,/ _)") |
|
671 |
|
672 text {* dummy setup for code_pred keyword *} |
|
673 |
|
674 ML {* |
|
675 OuterSyntax.local_theory_to_proof "code_pred" "sets up goal for cases rule from given introduction rules and compiles predicate" |
|
676 OuterKeyword.thy_goal (OuterParse.term_group >> (K (Proof.theorem_i NONE (K I) [[]]))) |
|
677 *} |
629 |
678 |
630 no_notation |
679 no_notation |
631 inf (infixl "\<sqinter>" 70) and |
680 inf (infixl "\<sqinter>" 70) and |
632 sup (infixl "\<squnion>" 65) and |
681 sup (infixl "\<squnion>" 65) and |
633 Inf ("\<Sqinter>_" [900] 900) and |
682 Inf ("\<Sqinter>_" [900] 900) and |
638 |
687 |
639 hide (open) type pred seq |
688 hide (open) type pred seq |
640 hide (open) const Pred eval single bind if_pred not_pred |
689 hide (open) const Pred eval single bind if_pred not_pred |
641 Empty Insert Join Seq member pred_of_seq "apply" adjunct eq |
690 Empty Insert Join Seq member pred_of_seq "apply" adjunct eq |
642 |
691 |
643 text {* dummy setup for code_pred keyword *} |
|
644 |
|
645 ML {* |
|
646 OuterSyntax.local_theory_to_proof "code_pred" "sets up goal for cases rule from given introduction rules and compiles predicate" |
|
647 OuterKeyword.thy_goal (OuterParse.term_group >> (K (Proof.theorem_i NONE (K I) [[]]))) |
|
648 *} |
|
649 |
|
650 |
|
651 end |
692 end |