HOL-OCL
/
su4sml
1
0
Fork 0
Code Issues Pull Requests Releases Activity
su4sml/su4sml/src/wfcpog/rep_holocl.sml

319 lines
13 KiB
Standard ML
Raw Blame History

(*****************************************************************************
* HOL-OCL --- an interactive theorem-prover for for UML/OCL
* http://www.brucker.ch/projects/hol-ocl/
*
* holocl_namespace.sml ---
* This file is part of HOL-OCL.
*
* Copyright (c) 2005-2007 ETH Zurich, Switzerland
* 2008-2009 Achim D. Brucker, Germany
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are
* met:
*
* * Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above
* copyright notice, this list of conditions and the following
* disclaimer in the documentation and/or other materials provided
* with the distribution.
*
* * Neither the name of the copyright holders nor the names of its
* contributors may be used to endorse or promote products derived
* from this software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
******************************************************************************)
(* $Id: holocl_namespace.sml 7513 2008-03-27 06:27:50Z brucker $ *)
signature REP_HOLOCL_NAMESPACE =
sig
datatype Level = univ (* universe toolbox *)
| operation
| holocl (* HOL-OCL toplevel *)
| l0 (* Level 0 *)
| l1 (* Level 1 *)
| l2 (* Level 2 *)
(* useful stuff; move to su4sml? *)
val rm_whitespace : string -> string
val listin : ''a -> ''a list -> bool
val ext_name_of : Rep_OclType.Path -> string list
val post_1_of : Rep_OclType.Path -> Rep_OclType.Path
val pre_1_of : Rep_OclType.Path -> Rep_OclType.Path
val local_name_of : Rep_OclType.Path -> string
val hc_path : Level -> Rep_OclType.Path -> Rep_OclType.Path
val get_class_of : Rep_OclType.Path -> Rep_OclType.Path
val mk_class_of : Rep_OclType.Path -> Rep_OclType.Path
val mk_def_of : Rep_OclType.Path -> Rep_OclType.Path
val is_hc_pathstr : Level-> string -> bool
val class2get_parent : Rep_OclType.Path -> string -> Rep_OclType.Path
val parent2class_of : Rep_OclType.Path -> string -> Rep_OclType.Path
val is_univ_class_of : Rep_OclType.Path -> Rep_OclType.Path
val is_class_of : Rep_OclType.Path -> Rep_OclType.Path
val key_name_of : Rep_OclType.Path -> string list
val base_type_name_of : Rep_OclType.Path -> Rep_OclType.Path
val type_name_of : Rep_OclType.Path -> Rep_OclType.Path
val attr_of : Rep_OclType.Path -> string -> Rep_OclType.Path
val is_classType_of : Rep_OclType.Path -> Rep_OclType.Path
val attr_pre_of : Rep_OclType.Path -> string -> Rep_OclType.Path
val type_charset_name_of : Rep_OclType.Path -> Rep_OclType.Path
val invariant_1_of : Rep_OclType.Path -> Rep_OclType.Path
val invariant_2_of : Rep_OclType.Path -> Rep_OclType.Path
val strong_sve_2_of :Rep_OclType.Path -> Rep_OclType.Path
val strict_sve_2_of :Rep_OclType.Path -> Rep_OclType.Path
val name_of_inv : Rep_Core.Classifier -> Rep_OclType.Path
val name_of_pre : Rep_Core.Classifier -> Rep_Core.operation -> Rep_OclType.Path
val name_of_post : Rep_Core.Classifier -> Rep_Core.operation -> Rep_OclType.Path
end
structure Rep_HolOcl_Namespace:REP_HOLOCL_NAMESPACE =
struct
datatype Level = univ (* universe toolbox *)
| operation
| holocl (* HOL-OCL toplevel *)
| l0 (* Level 0 *)
| l1 (* Level 1 *)
| l2 (* Level 2 *)
fun listin _ [] = false
| listin e (x::xs) = if e=x then true else listin e xs
(*separate s [x1, x2, ..., xn] ===> [x1, s, x2, s, ..., s, xn]*)
fun separate s (x :: (xs as _ :: _)) = x :: s :: separate s xs
| separate _ xs = xs;
fun space_implode a bs = SML90.implode (separate a bs);
fun rm_whitespace s = space_implode "_" (String.tokens (fn c => c = (#" ")
orelse c = (#":")) s)
fun local_name_of path = case path of
[] => ""
| p => (hd o rev) p
fun hc_path level p = if ((String.isSubstring "OclAny" (local_name_of p))
andalso not (String.isSubstring "_2_OclAny" (local_name_of p))
andalso not (String.isSubstring "OclAny_2" (local_name_of p)))
(* hack *)
then
case level of
univ => p
| operation => p
| holocl => p
| l0 => ("UML_OCL"::["level0"])@p
| l1 => ("UML_OCL"::["level1"])@p
| l2 => p
else
case level of
univ => ("UML_OCL"::["univ"])@p (* universe toolbox *)
| operation => ("UML_OCL"::["ops"])@p
| holocl => "UML_OCL"::p (* HOL-OCL toplevel *)
| l0 => ("UML_OCL"::["level0"])@p
| l1 => ("UML_OCL"::["level1"])@p
| l2 => p
fun class2get_parent path superclass = rev (((hd (rev path))^"_2_"^superclass)::(tl (rev path)))
fun parent2class_of path superclass = rev ((superclass^"_2_"^(hd (rev path)))::(tl (rev path)))
fun mk_def_of path = rev (((hd (rev path))^"_def")::(tl (rev path)))
fun type_charset_name_of path = rev (((hd (rev path))^"_type")::(tl (rev path)))
fun attr_of path attr= path @[attr]
fun attr_pre_of path attr = path@[attr^"_pre"]
fun invariant_1_of path = path@["invariant1"]
fun invariant_2_of path = path@["inv"]
fun strong_sve_2_of path = path@["strong_sve"]
fun strict_sve_2_of path = path@["strict_sve"]
fun rm_whitespace s = space_implode "_" (String.tokens (fn c => c = (#" ")
orelse c = (#":")) s)
fun op_tab_of path = path@["op_tab"]
fun pre_1_of path = path@["pre1"]
fun post_1_of path = path@["post1"]
fun get_class_of path = rev (("get_"^(hd (rev path)))::(tl (rev path))) (* mkC *)
fun mk_class_of path = rev (("mk_"^(hd (rev path)))::(tl (rev path))) (* mkC *)
fun key_name_of path = if (path = (Rep_Core.name_of Rep_Core.OclAnyC)) (* hack *)
then ["OCL_OclAny_type","OclAny_key"]
else rev (((hd (rev path))^"_key")::(tl (rev path))) (* keyC *)
fun is_hc_pathstr level pstr = if ((String.isSubstring "OclAny" pstr)
andalso not (String.isSubstring "_2_OclAny" pstr)
andalso not (String.isSubstring "OclAny_2" pstr))
(* hack *)
then
case level of
univ => false
| operation => false
| holocl => false
| l0 => String.isSubstring "UML_OCL.level0." pstr
| l1 => String.isSubstring "UML_OCL.level1." pstr
| l2 => false
else
case level of
univ => String.isSubstring "UML_OCL.univ." pstr
| operation => String.isSubstring "UML_OCL.ops" pstr
| holocl => String.isSubstring "UML_OCL." pstr
| l0 => String.isSubstring "UML_OCL.level0." pstr
| l1 => String.isSubstring "UML_OCL.level1." pstr
| l2 => not (String.isSubstring "UML_OCL." pstr)
fun base_type_name_of path = if (path = (Rep_Core.name_of Rep_Core.OclAnyC)) (* hack *)
then ["OCL_OclAny_type","OclAny_key"] (* ??? *)
else rev (((hd (rev path))^"_base_type")::(tl (rev path)))
fun type_name_of path = if (path = (Rep_Core.name_of Rep_Core.OclAnyC)) (* hack *)
then ["OCL_OclAny_type","OclAny_key"]
else rev (((hd (rev path))^"_type")::(tl (rev path))) (* typeC *)
fun is_class_of path = rev (("is_"^(hd (rev path)))::(tl (rev path))) (* mkC *)
fun is_classType_of path = rev (("isType_"^(hd (rev path)))::(tl (rev path))) (* mkC *)
fun is_univ_class_of path = rev (("is_"^(hd (rev path))^"_univ")::(tl (rev path))) (* mkC *)
fun ext_name_of path = if (path = (Rep_Core.name_of Rep_Core.OclAnyC)) (* hack *)
then ["OCL_OclAny_type","OclAny_ext"]
else rev (((hd (rev path))^"_ext")::(tl (rev path))) (* extC *)
fun name_of_inv C = let
fun invariant_1_of path = path@["model","inv"]
in
hc_path l2 (invariant_1_of ((Rep_Core.name_of C)))
end
fun name_of_pre C Op = hc_path l2 (pre_1_of ((Rep_Core.name_of C)@[Rep_Core.mangled_name_of_op Op]))
fun name_of_post C Op = hc_path l2 (post_1_of ((Rep_Core.name_of C)@[Rep_Core.mangled_name_of_op Op]))
end
signature REP_HOLOCL_HELPER =
sig
val holocl_and : Rep_OclTerm.OclTerm -> Rep_OclTerm.OclTerm -> Rep_OclTerm.OclTerm
val holocl_and_all : Rep_OclTerm.OclTerm list -> Rep_OclTerm.OclTerm
val holocl_or : Rep_OclTerm.OclTerm -> Rep_OclTerm.OclTerm -> Rep_OclTerm.OclTerm
val holocl_or_all : Rep_OclTerm.OclTerm list -> Rep_OclTerm.OclTerm
val holocl_implies : Rep_OclTerm.OclTerm -> Rep_OclTerm.OclTerm -> Rep_OclTerm.OclTerm
val holocl_not : Rep_OclTerm.OclTerm -> Rep_OclTerm.OclTerm
val holocl_xor : Rep_OclTerm.OclTerm -> Rep_OclTerm.OclTerm -> Rep_OclTerm.OclTerm
val holocl_localValid_state : Rep_OclTerm.OclTerm -> string -> Rep_OclTerm.OclTerm
val holocl_localValid_transition : Rep_OclTerm.OclTerm -> string -> string -> Rep_OclTerm.OclTerm
val get_holocl_operation : string -> Rep_Core.operation -> Rep_Core.Classifier -> Rep_Core.transform_model -> Rep_OclTerm.OclTerm
val get_holocl_abstraction_relation: Rep_Core.Classifier -> Rep_Core.Classifier -> Rep_Core.transform_model -> Rep_OclTerm.OclTerm
end
structure Rep_HolOcl_Helper:REP_HOLOCL_HELPER =
struct
open Rep_Core
open Rep_OclType
open Rep_OclTerm
open WFCPOG_Library
exception HolOcl_Helper_InvalidArguments of string
fun type_of_t term = Rep_OclHelper.type_of term
fun ocl_opcall (source:OclTerm) f args t = OperationCall (source, type_of_t source, f,
map (fn x => (x,type_of_t x)) args,
t)
fun holocl_and a b = ocl_opcall a ["holOclLib","Boolean","and"] [b] Boolean
fun holocl_and_all [] = raise (HolOcl_Helper_InvalidArguments ("holocl.holocl_and_all: empty argument list"))
| holocl_and_all [a:OclTerm] = a
| holocl_and_all (h::t) = holocl_and h (holocl_and_all t)
fun holocl_or a b = ocl_opcall a ["holOclLib","Boolean","or"] [b] Boolean
fun holocl_or_all [] = raise (HolOcl_Helper_InvalidArguments ("holocl.holocl_or_all: empty argument list"))
| holocl_or_all [a:OclTerm] = a
| holocl_or_all (h::t) = holocl_or h (holocl_or_all t)
fun holocl_implies a b = ocl_opcall a ["holOclLib","Boolean","implies"] [b] Boolean
fun holocl_xor a b = ocl_opcall a ["holOclLib","Boolean","xor"] [b] Boolean
fun holocl_not a = ocl_opcall a ["holOclLib","Boolean","not"] [] Boolean
fun holocl_localValid_state term var_name =
OperationCall(term,Boolean,["holOclLib","Boolean","OclLocalValid"],[(Literal(var_name,OclState),DummyT)],Boolean)
fun holocl_localValid_transition term var_name1 var_name2 =
let
val sigma = Literal(var_name1,OclState)
val sigma_s = Literal(var_name2,OclState)
val tuple_term = Tuple [(var_name1,sigma,OclState),(var_name2,sigma_s,OclState)]
in
OperationCall(term,Boolean,["holOclLib","Boolean","OclLocalValid"],[(tuple_term,OclState)],Boolean)
end
fun get_holocl_operation abs_or_conc oper class model =
let
val _ = Logger.info ("WFCPOG_Refine_Constraint.get_holocl_operation\n")
val hol_name = string_of_path ((name_of class)@[name_of_op oper])
val styp = type_of class
val src = Variable((abs_or_conc^"_"^(name_of_op oper)),styp)
val predicate = Predicate(src,Boolean,[hol_name],args2varargs
(map (fn (n,t) => (abs_or_conc^"_"^n,t)) (arguments_of_op oper)))
val _ = Logger.info ("WFCPOG_Refine_Constraint.get_holocl_operation\n")
in
predicate
end
fun get_holocl_abstraction_relation abs_class conc_class model =
let
val _ = Logger.info ("WFCPOG_Refine_Constraint.get_holocl_abstraction_relation\n")
val predicate_name = "R_"^(string_of_path (package_of abs_class))^"_"^(string_of_path (package_of conc_class))^"_"^(List.last (name_of abs_class))
val abs_typ = type_of abs_class
val conc_typ = type_of conc_class
val abs_state = Variable("tau_concrete",OclState)
val conc_state = Variable("tau_abstract",OclState)
val abs_term = Variable(string_of_path (name_of abs_class),abs_typ)
val conc_term = Variable(string_of_path (name_of conc_class),conc_typ)
val predicate = Predicate(abs_state,OclState,[predicate_name],[(conc_state,OclState),(abs_term,abs_typ),(conc_term,conc_typ)])
val _ = Logger.info ("WFCPOG_Refine_Constraint.get_holocl_abstraction_relation\n")
in
predicate
end
end
Reference in New Issue View Git Blame Copy Permalink