;-*- Mode: Common-lisp; Package: lexiparse; Readtable: ytools; -*- (in-package :lexiparse) (depends-on %owl-s-gram/ owl-s-syn) ;;; INTERNALIZATION A: Translation to RDF (def-grammar owl-s-as-rdf :parent owl-s :sym-case #+ansi-cl :up #-ansi-cl :preserve) (defun string->uri (s) (net.uri:intern-uri (net.uri:parse-uri s))) (defun is-uri (s) (net.uri:uri-p s)) (defvar owl-s-namespace* (make-XML-namespace :global true :governor (string->uri "http://www.daml.org/services/owl-s/1.1/Process.owl"))) (defvar rdf-namespace* (make-XML-namespace :global true :governor (string->uri "http://www.w3.org/1999/02/22-rdf-syntax-ns"))) (defvar xsd-namespace* (make-XML-namespace :global true :governor (string->uri "http://www.w3.org/2001/XMLSchema"))) (defvar comlog-namespace* (make-XML-namespace :global true :governor (string->uri "http://www.ihmc.us/users/phayes/SCLJune2004.html"))) (defvar shadow-rdf-namespace* (make-XML-namespace :global true :governor (string->uri "http://www.daml.org/services/owl-s/1.2/generic/ObjectList.owl"))) ;;; Third element in each tuple is the entity name, which is set by ;;; 'rdf-xml-out' -- (defvar example-ns-tab* (list (tuple 'owls owl-s-namespace* 'owls) (tuple 'rdf rdf-namespace* 'rdf) (tuple 'xsd xsd-namespace* 'xsd) (tuple 'clog comlog-namespace* 'clog) (tuple 'lisht shadow-rdf-namespace* 'lisht))) ;;;;(defun rdf-xml-out (rdf-xml-tree srm) ;;;; (xml-document-out rdf-xml-tree example-ns-tab* ;;;; (XML-namespace-governor owl-s-namespace*) ;;;; srm)) (defvar rdf-ID-name* (make-XML-name :string "ID" :namespace rdf-namespace*)) (defvar rdf-resource-name* (make-XML-name :string "resource" :namespace rdf-namespace*)) (defvar rdf-parseType-name* (make-XML-name :string "parseType" :namespace rdf-namespace*)) (defvar rdf-shadow-list-name* (make-XML-name :string "List" :namespace shadow-rdf-namespace*)) (defvar rdf-shadow-first-name* (make-XML-name :string "First" :namespace shadow-rdf-namespace*)) (defvar rdf-shadow-rest-name* (make-XML-name :string "Rest" :namespace shadow-rdf-namespace*)) (defvar rdf-shadow-empty-list-name* (make-XML-name :string "nil" :namespace shadow-rdf-namespace*)) (defun owl-s-name (str) (make-XML-name :string str :namespace owl-s-namespace*)) (with-grammar owl-s-as-rdf (def-internal with_namespaces (pt g ns-tab) (match-let ?(:^+ with_namespaces ?sub-pt ?@nsl) pt (let* ((namespace-pairs (nconc (<# (\\ (nsp) (match-let ?(:^+ namespace+name ?name (:^+ uri ?uri)) nsp (tuple name (make-XML-namespace :global true :governor (make-interned-uri uri))))) nsl) ns-tab)) (i (internalize sub-pt g namespace-pairs))) (cond ((is-XML-element i) (!= (XML-element-namespace-decls i) namespace-pairs) i) ((is-list-of i #'is-XML-element) (repeat :for ((xe :in i)) (!= (XML-element-namespace-decls xe) namespace-pairs)) i) (t (signal-problem with_namespaces "Somehow failed to internalize" :% 3 pt :% " to XML-element: " :% 3 i)))))) (def-internal name-wrt-space (pt _ ns-tab) (match-let ?(:^+ name-wrt-space ?spacename ?name) pt (let ((space (alref ns-tab spacename))) (cond (space (make-XML-name :string (Symbol-name name) :namespace space :prefix spacename)) (t (signal-problem name-wrt-space "Undeclared namespace " spacename)))))) (def-internal left-brace (pt g ns-tab) (<# (\\ (sub) (internalize sub g ns-tab)) (Parsetree-subtrees pt))) (defvar process-kind-owl-s-equivs* (list (tuple 'atomic (owl-s-name "AtomicProcess")) (tuple 'simple (owl-s-name "SimpleProcess")) (tuple 'composite (owl-s-name "CompositeProcess")))) (def-internal define (pt _ ns-tab) (match-cond pt (:? ?(:^+ define ?kind ?name (:^+ iopr ?@iopr-specs) ?body-exp) (multi-let (((bound-vars output-vars var-xmls) (iopr->xml iopr-specs))) (make-XML-element :type (alref process-kind-owl-s-equivs* kind) :attributes (list (tuple rdf-ID-name* name)) :contents (cond ((eq kind 'composite) (append var-xmls (list (composite-body->xml body-exp bound-vars output-vars ns-tab)))) (t var-xmls))))) (t (signal-problem define-internalizer "Unintelligible define-headed parsetree: " :% (:e (parsetree-show pt)))))) (defun composite-body->xml (body-exp bound-vars output-vars ns-tab) (make-XML-element :type (owl-s-name "composedOf") :contents (list (body->xml body-exp bound-vars output-vars (extract-step-tags body-exp) ns-tab)))) ) ;;; Each element of 'iopr-specs' is an 'inputs', 'outputs', etc. ;;; parsetree. ;;; For 'inputs', 'outputs", and 'locals', sus are parsetrees headed ;;; by , , or a variable. ;;; Returns < input-n-local-vars, output-vars, xml-elements > (defun iopr->xml (iopr-specs) (let-fun () (let ((inputs (find-subtree 'inputs iopr-specs)) (locals (find-subtree 'locals iopr-specs)) (outputs (find-subtree 'outputs iopr-specs)) (precond (find-subtree 'precondition iopr-specs)) (results (repeat :for ((iopr :in iopr-specs) r) :when (matchq ?(:^+ result ?r) iopr) :collect r))) (multi-let (((input-vars inputs-xmls) (cond (inputs (vardecls->xml inputs ':input '"hasInput")) (t (values !() !())))) ((local-vars locals-xmls) (cond (locals (vardecls->xml locals ':local '"hasLocal")) (t (values !() !())))) ((output-vars outputs-xmls) (cond (outputs (vardecls->xml outputs ':output '"hasOutput")) (t (values !() !()))))) (let ((precond-xmls (cond (precond (list (logical-expression-element "hasPrecondition" precond (append input-vars local-vars) !()))) (t !()))) (result-xmls (xml r (append input-vars local-vars) output-vars))) (list (make-XML-element :type (owl-s-name "hasResult") :contents (list (make-XML-element :type (owl-s-name "Result") :contents xml-res)))))) results))) (values (append input-vars local-vars) output-vars (nconc inputs-xmls locals-xmls outputs-xmls precond-xmls result-xmls))))) :where (:def find-subtree (sort subtrees) (repeat :for ((sub :in subtrees)) :result false :until (matchq ?(:^+ ?,sort ?@_) sub) :result sub)))) (defun vardecls->xml (labeled-decls role var-role) (let-fun () (match-let ?(:^+ ?_ ?@decls) labeled-decls (repeat :for ((decl :in decls) :collectors vars xmls) :result (values vars xmls) :within (multi-let (((vl xl) (match-cond decl (:? ?(:^+ hyphen ?@vl ?ty) (declarations vl ty)) (:? ?(:^+ comma ?@vl) (declarations vl false)) (t (declarations (list decl) false))))) (:continue :nconc (:into vars vl) :nconc (:into xmls xl))))) :where (:def declarations (vars type) (values (<# (\\ (v) (tuple v role)) vars) (repeat :for ((v :in vars)) :collect (make-XML-element :type (owl-s-name var-role) :attributes (list (tuple rdf-ID-name* (symbol-name v))) :contents (cond (type (list (make-XML-element :type (owl-s-name "parameterType") :attributes (list (tuple rdf-resource-name* (type-xml type)))))) (t !())))))))) ;;; 'ins' are variables bound as inputs and locals. ;;; 'outs' are variables bound as outputs. ;;; Both lists are alists with pairs (var [:input|:local|:outputs] ;;; The latter are the only variables that can appear to the left of ;;; '<='. Everywhere else a variable must be an element of 'ins' (or ;;; bound by a local quantifier). (defun res-tree->xml (res ins outs) (let-fun () (walk-through res false (append ins outs)) :where (:def walk-through (subres must-see-when bvars) (match-cond subres (:? ?(:^+ forall ?vars ?r) (multi-let (((vl resVars) (decls->resVars vars))) (append resVars (walk-through r true (append vl ins))))) (:? ?(:^+ when ?condition ?effect) (cons (logical-expression-element "inCondition" condition bvars !()) (effect-elements effect bvars))) (:? ?(:^+ ?(:|| and group) ?@elts) (xml "Result contains 'forall' without '|->' to make bindings work: " :% res)) (t (effect-elements subres bvars)))) (:def effect-elements (eff bvars) (match-cond eff (:? ?(:^+ and ?@conjuncts) (repeat :for ((c :in conjuncts)) :nconc (effect-elements c bvars))) (:? ?(:^+ output ?@bindings) (list (make-XML-element :type (owl-s-name "withOutput") :contents (repeat :for ((b :in bindings)) :collect (match-let ?(:^+ bind-param ?p ?e) b (output-element p e)))))) (t (list (logical-expression-element "hasEffect" eff bvars !()))))) (:def output-element (param exp) (cond ((assq param outs) (make-XML-element :type (owl-s-name "OutputBinding") :contents (list (make-XML-element :type (owl-s-name "toParam") :attributes (list (tuple rdf-resource-name* (sharpify-sym-name param)))) (match-cond exp (:? ?(:^+ dot ?step ?output) (dot-expression step output)) (t (logical-expression-element "valueFunction" exp ins !())))))) (t (signal-problem res-tree->xml "Undeclared output parameter " param)))) )) ;;; Returns < bvars, resVar-XML-list >. 'bvars' is alist of pairs (var :local). (defun decls->resVars (vars) (let-fun () (match-cond vars (:? ?(:^+ hyphen ?@vl ?type) (values (<# (\\ (v) (tuple v ':local)) vl) (<# (\\ (v) (var-decl-element v (list (make-XML-element :type (owl-s-name "parameterType") :attributes (list (tuple rdf-resource-name* (out-to-string type))))))) vl))) (:? ?(:^+ comma ?@vl) (values vl (<# (\\ (v) (var-decl-element v !())) vl))) (:? ?(:^+ group ?@vars) (repeat :for ((vd :in vars) :collectors vars decls) :within (multi-let (((vl dl) (decls->resVars vd))) (:continue :nconc (:into vars vl) :nconc (:into decls dl))) :result (values vars decls))) (t (let ((v (var-decl-element vars !()))) (values (list v) (list v))))) :where (:def var-decl-element (v cl) (make-XML-element :type (owl-s-name "resultVar") :attributes (list (tuple rdf-ID-name* (out-to-string v))) :contents cl)))) (defun extract-step-tags (body) (match-cond body (:? ?(:^+ ?op ?@subtrees) (case op ((semicolon anyord split split-join) (xml (body bvars output-vars step-tags ns-tab) (match-cond body (:? ?(:^+ ?op ?@subtrees) (case op (semicolon (collection-control-construct "Sequence" subtrees bvars output-vars step-tags ns-tab)) (anyord (collection-control-construct "Any-order" subtrees bvars output-vars step-tags ns-tab)) (split (collection-control-construct "Split" subtrees bvars output-vars step-tags ns-tab)) (split-join (collection-control-construct "Split-Join" subtrees bvars output-vars step-tags ns-tab)) (choice (collection-control-construct "Choice" subtrees bvars output-vars step-tags ns-tab)) (if (build-if subtrees bvars output-vars step-tags ns-tab)) (perform (let ((callee (first subtrees)) (args (rest subtrees))) (let ((proc-elt (make-XML-element :type (owl-s-name "process") :attributes (list (tuple rdf-resource-name* (name-internalize callee ns-tab)))))) (make-XML-element :type (owl-s-name "Perform") :contents (cond ((null args) (list proc-elt)) (t (list proc-elt (make-XML-element :type (owl-s-name "hasDataFrom") :contents (<# (\\ (tr) (binding-element tr bvars step-tags)) args))))))))) (tag (match-let (?name ?tree) subtrees (let ((elem (body->xml tree bvars output-vars step-tags ns-tab))) (cond ((is-XML-element elem) (!= (XML-element-attributes elem) (cons (tuple rdf-ID-name* (sharpify-sym-name name)) *-*)) elem) (t (signal-problem tag->xmlr "Tagged statement " name ":: " tree :% " internalizes to " elem)))))) (produce (make-XML-element :type (owl-s-name "Produce") :contents (repeat :for ((bp :in subtrees)) :collect (make-XML-element :type (owl-s-name "outputBinding") :contents (list (binding-element bp bvars step-tags)))))) (t (signal-problem body->xml "Impossible process body " body)))) (t (signal-problem body->xml "Body is not a parsetree: " body)))) (defvar allow-collection-parsetype* false) ;;; Builds a description RDF element for object of 'type' (defun collection-control-construct (type elements bvars output-vars step-tags ns-tab) (make-XML-element :type (owl-s-name type) :contents (list (property-with-list-value (owl-s-name "components") (<# (\\ (c) (cond ((is-XML-element c) c) (t (out (:to :string) c)))) (<# (\\ (e) (body->xml e bvars output-vars step-tags ns-tab)) elements)) allow-collection-parsetype*)))) (defun build-if (subtrees bvars output-vars step-tags ns-tab) (make-XML-element :type (owl-s-name "If-then-else") :attributes !() :contents (nconc (list (logical-expression-element "ifCondition" (first subtrees) bvars step-tags) (body->xml (second subtrees) bvars output-vars step-tags ns-tab)) (cond ((> (length subtrees) 2) (list (body->xml (third subtrees) bvars output-vars step-tags ns-tab))) (t !()))))) (defun binding-element (bdg bvars step-tags) (match-let ?(:^+ bind-param ?param ?val) bdg (make-XML-element :type (owl-s-name "Binding") :contents (list (make-XML-element :type (owl-s-name "theParam") :attributes (list (tuple rdf-resource-name* (symbol-name param)))) (match-cond val (:? ?(:^+ dot ?step ?output) (dot-expression step output)) (t (let ((s (alref bvars val))) (cond ((eq s ':input) (dot-expression 'TheParentPerform val)) (t (logical-expression-element "valueFunction" val bvars step-tags)))))))))) (defun dot-expression (step output) (make-XML-element :type (owl-s-name "valueOf") :contents (list (make-XML-element :type (owl-s-name "fromProcess") :attributes (list (tuple rdf-resource-name* (sharpify-sym-name step)))) (make-XML-element :type (owl-s-name "theParam") :attributes (list (tuple rdf-resource-name* (sharpify-sym-name output))))))) ;;; Builds a property RDF element for property 'type-string' -- (defun logical-expression-element (type-string exp bvars step-tags) (make-XML-element :type (owl-s-name type-string) :attributes (list (tuple (owl-s-name "expressionLanguage") (make-XML-name :string "CommonLogic" :namespace comlog-namespace*)) (tuple (make-XML-name :string "dataType" :namespace rdf-namespace*) (make-XML-name :string "string" :namespace xsd-namespace*))) :contents (list (out-to-string (parsetree->common-logic exp bvars step-tags))))) (defun property-with-list-value (prop-name elements allow-collection-parsetype) (cond (allow-collection-parsetype (make-XML-element :type prop-name :attributes (list (tuple (make-XML-name :string "parseType" :namespace rdf-namespace*) "Collection")) :contents elements)) (t ;;; Spell it out painfully with shadow list vocabulary (let-fun ((construct-list (l) (cond ((null l) ;; We can't spell out the XML until ;; we pop up a level -- false) (t (let ((a (first l)) (d (construct-list (rest l)))) (make-XML-element :type rdf-shadow-list-name* :contents (list (cond ((is-uri a) (prop-resource-XML-element rdf-shadow-first-name* a)) (t (prop-descrip-XML-element rdf-shadow-first-name* a))) (construct-rest d))))))) (construct-rest (l) (cond (l (prop-descrip-XML-element rdf-shadow-rest-name* l)) (t (prop-resource-XML-element rdf-shadow-rest-name* rdf-shadow-empty-list-name*)))) (construct-prop-list (prop-name d) (cond (d (prop-descrip-XML-element prop-name d)) (t (prop-resource-XML-element prop-name rdf-shadow-empty-list-name*))))) (construct-prop-list prop-name (construct-list elements)))))) (defun prop-descrip-XML-element (name descrip) (make-XML-element :type name :contents (list descrip))) (defun prop-resource-XML-element (name uri) (make-XML-element :type name :attributes (list (tuple rdf-resource-name* uri)))) ;;; This is for globally bound symbols, such as predicate names. (defvar global-symbols* '(TheClient null true false loves purple mauve)) (defun parsetree->common-logic (pt bvars step-tags) (match-cond pt (:? ?(:^+ ?(:|| forall exists :& ?quant) ?decls ?exp) (multi-let (((vars decls) (vardecls->common-logic decls))) `(,quant ,decls ,(parsetree->common-logic exp (append vars bvars) step-tags)))) (:? ?(:^+ dot ?step ?output) (cond ((not (memq step step-tags)) (signal-problem parsetree->common-logic "Undefined step " step (:proceed "I'll pretend it's defined")))) `(output-of ,step ,output)) (:? ?(:|| ?(:^+ fun-app ?op ?@args) ?(:^+ ?op ?@args)) `(,op ,@(<# (\\ (a) (parsetree->common-logic a bvars step-tags)) args))) ((is-Symbol pt) (let ((s (alref bvars pt))) (cond (s (cond ((eq s ':input) `(input-of TheParentPerform ,pt)) (t pt))) ((memq pt global-symbols*) pt) (t (signal-problem parsetree->common-logic "Unbound variable: " pt (:proceed "I'll pretend it's bound")) pt)))) (t pt))) ;;; Returns < vars, common-logic-decls > (defun vardecls->common-logic (decl-tree) (let-fun () (match-cond decl-tree (:? ?(:^+ hyphen ?vars ?type) (match-cond vars (:? ?(:^+ comma ?@vl) (values (vars-local vl) (<# (\\ (v) `(,v ,type)) vl))) (t (values (vars-local (list vars)) `((,vars ,type)))))) (:? ?(:^+ comma ?@vars) (values (vars-local vars) vars)) (:? ?(:^+ group ?@vars) (repeat :for ((vd :in vars) :collectors vars decls) :within (multi-let (((vl dl) (vardecls->common-logic vd))) (:continue :nconc (:into vars vl) :nconc (:into decls dl))) :result (values vars decls))) (t (values (vars-local (list decl-tree)) (list decl-tree)))) :where (:def vars-local (varlist) (<# (\\ (v) (tuple v ':local)) varlist)))) ;;; Stub for something more realistic (defun type-xml (ty) (make-XML-name :string ty :namespace xsd-namespace*)) (defun sharpify-sym-name (sym) (out-to-string "#" (:a (symbol-name sym)))) (defun name-internalize (name ns-tab) (let-fun () (match-cond name (:? ?(:^+ name-wrt-space ?spacename ?sym) (XML-ify sym spacename)) (t (XML-ify name false))) :where (:def XML-ify (sym spacename) (let ((space (alref ns-tab spacename))) (cond (space (make-XML-name :string (Symbol-name sym) :namespace space :prefix spacename)) (spacename (signal-problem name-internalize "Undeclared namespace " spacename)) (t (signal-problem name-internalize "No default namespace for " sym)))))))