;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; This file is part of "NOVA": NOVA = search + COCOMO tools ; Copyright, 2008, Tim Menzies tim@menzies.us ; ; NOVA is free software: you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation, either version 3 of the License, or ; (at your option) any later version. ; ; NOVA is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; a long with NOVA. If not, see . ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :nova-web.xml) (defun nova-xml-interface (input-stream output-stream) (nova-output-to-xml (nova-interface (nova-input-from-xml input-stream)) output-stream) (values)) (defun nova-xml-standard-io-interface () (nova-xml-interface *standard-input* *standard-output*)) ;;;; ;;;; XML -> NOVA-INPUT ;;;; (defun nova-input-from-xml (stream) (declare (stream stream)) (cxml:parse-stream stream (make-nova-builder))) (defclass nova-builder (sax:content-handler) ((document :initform nil :accessor nb-document) (element-stack :initform '() :accessor nb-element-stack) (text-buffer :initform nil :accessor nb-text-buffer))) (defun make-nova-builder () (make-instance 'nova-builder)) (defclass document () ((type :initform nil :accessor d-type) (lists-buffer :initform '() :accessor d-lists-buffer) (search-engine-id :initform nil :accessor d-search-engine-id) (evaluation-method-id :initform nil :accessor d-evaluation-method-id) (scoring-method-ids :initform nil :accessor d-scoring-method-ids) (constraints :initform nil :accessor d-constraints) (parameters :initform nil :accessor d-parameters) (parameter :initform nil :accessor d-parameter) (models :initform nil :accessor d-models) (model :initform nil :accessor d-model) (modifiable-attributes :initform nil :accessor d-modifiable-attributes) (attributes :initform nil :accessor d-attributes) (attribute :initform nil :accessor d-attribute) (value :initform nil :accessor d-value))) (defstruct attribute name range value) (defstruct value value) (defstruct range minimum maximum interval) (defstruct model name tuning-parameters) (defmethod sax:start-document ((handler nova-builder)) (setf (nb-document handler) (make-instance 'document))) (defun retrieve-attribute (attributes name &optional (default nil defaultp)) (let ((attribute (sax:find-attribute name attributes))) (cond (attribute (sax:attribute-value attribute)) (defaultp default) (t (error "required attribute not found: ~a" name))))) (defun 2sym (str) ;;FIXME needa better parse symbol (add regex) (read-from-string str)) (defun parse-float (str) ;;FIXME need a better parse float method (add regex) (when str (read-from-string str))) (defmethod sax:start-element ((handler nova-builder) namespace-uri local-name qname attributes) (let ((document (nb-document handler))) (macrolet ((q= (name) `(equal ,name qname))) (cond ((q= "nova-input") nil) ((q= "learning-input") (setf (d-type document) 'learning-input)) ((q= "search-engine") (setf (d-search-engine-id document) (2sym (retrieve-attribute attributes "name")))) ((q= "evaluation-method") (setf (d-evaluation-method-id document) (2sym (retrieve-attribute attributes "name")))) ((q= "scoring-methods") (push nil (d-lists-buffer document))) ((q= "scoring-method") (push (2sym (retrieve-attribute attributes "name")) (d-scoring-method-ids document))) ((q= "parameters") (push nil (d-lists-buffer document))) ((q= "parameter") (setf (d-parameter document) (make-attribute :name (2sym (retrieve-attribute attributes "name"))))) ((q= "models") (push nil (d-lists-buffer document))) ((q= "model") (progn (setf (d-model document) (make-model :name (2sym (retrieve-attribute attributes "name")))) (push nil (d-lists-buffer document)))) ((q= "tuning-parameter") (setf (d-parameter document) (make-attribute :name (2sym (retrieve-attribute attributes "name"))))) ((q= "attributes") (push nil (d-lists-buffer document))) ((q= "attribute") (setf (d-attribute document) (make-attribute :name (2sym (retrieve-attribute attributes "name"))))) ((q= "range") (setf (d-value document) (make-range :minimum (parse-float (retrieve-attribute attributes "minimum" nil)) :maximum (parse-float (retrieve-attribute attributes "maximum" nil)) :interval (parse-float (retrieve-attribute attributes "interval" nil))))) ((q= "value") (setf (d-value document) (make-value))) ((q= "modifiable-attributes") (push nil (d-lists-buffer document))))))) (defun build-constraints (parameters models attributes) (let (constraints) (labels ((process-value (id value) (list id (value-value value))) (process-range (id range) (cond ((equal (range-minimum range) (range-maximum range)) (process-value id (range-minimum range))) ((null (range-interval range)) (list id (range-minimum range) (range-maximum range))) (t (cons id (expand-range (range-minimum range) (range-maximum range) (range-interval range) 5)))))) ;;parameters (dolist (p parameters) (push (if (attribute-value p) (process-value (attribute-name p) (attribute-value p)) (process-range (attribute-name p) (attribute-range p))) constraints)) ;;models (dolist (m models) (dolist (tp (model-tuning-parameters m)) (push (if (attribute-value tp) (process-value (attribute-name tp) (attribute-value tp)) (process-range (attribute-name tp) (attribute-range tp))) constraints))) ;;attributes (dolist (a attributes) (push (if (attribute-value a) (process-value (attribute-name a) (attribute-value a)) (process-range (attribute-name a) (attribute-range a))) constraints))) (nreverse constraints))) (defmethod sax:end-element ((handler nova-builder) namespace-uri local-name qname) (let ((document (nb-document handler))) (macrolet ((q= (name) `(equal ,name qname))) (cond ((q= "value") (setf (value-value (d-value document)) (parse-float (string-trim-whitespace (nb-text-buffer handler))))) ((q= "attribute") (progn (when (d-value document) (etypecase (d-value document) (value (setf (attribute-value (d-attribute document)) (d-value document))) (range (setf (attribute-range (d-attribute document)) (d-value document))))) (setf (d-value document) nil) (push (d-attribute document) (first (d-lists-buffer document))))) ((q= "attributes") (setf (d-attributes document) (nreverse (pop (d-lists-buffer document))))) ((q= "parameter") (progn (when (d-value document) (etypecase (d-value document) (value (setf (attribute-value (d-parameter document)) (d-value document))) (range (setf (attribute-range (d-parameter document)) (d-value document))))) (setf (d-value document) nil) (push (d-parameter document) (first (d-lists-buffer document))))) ((q= "parameters") (setf (d-parameters document) (nreverse (pop (d-lists-buffer document))))) ((q= "tuning-parameter") (progn (when (d-value document) (etypecase (d-value document) (value (setf (attribute-value (d-parameter document)) (d-value document))) (range (setf (attribute-range (d-parameter document)) (d-value document))))) (setf (d-value document) nil) (push (d-parameter document) (first (d-lists-buffer document))))) ((q= "model") (progn (setf (model-tuning-parameters (d-model document)) (nreverse (pop (d-lists-buffer document)))) (push (d-model document) (first (d-lists-buffer document))))) ((q= "models") (setf (d-models document) (nreverse (pop (d-lists-buffer document))))) ((q= "constraints") (setf (d-constraints document) (build-constraints (d-parameters document) (d-models document) (d-attributes document)))) ((q= "modifiable-attributes") (setf (d-modifiable-attributes document) (mapcar #'attribute-name (nreverse (pop (d-lists-buffer document)))))))))) (defmethod sax:end-document ((handler nova-builder)) (let ((document (nb-document handler))) (case (d-type document) (learning-input (make-nova-learning-input (d-search-engine-id document) (d-evaluation-method-id document) (d-scoring-method-ids document) (d-constraints document) (d-modifiable-attributes document))) (otherwise nil)))) (defmethod sax:characters ((handler nova-builder) data) (setf (nb-text-buffer handler) data)) ;;;; ;;;; NOVA-OUTPUT -> XML ;;;; (defgeneric nova-output-to-xml (nova-output stream) ) (defmethod cxml:unparse-attribute ((sym symbol)) (concatenate 'string (package-name (symbol-package sym)) ":" (symbol-name sym))) (defmethod cxml:unparse-attribute ((f float)) (format nil "~,6f" f)) (defmethod nova-output-to-xml ((nova-output nova-learning-output) (stream stream)) (let ((sink (if (eq (stream-element-type stream) 'character) ;;uncomment canocial and indention for better testing (cxml:make-character-stream-sink stream); :canonical nil :indentation 1) (cxml:make-octet-stream-sink stream ))) ;;TODO pull out scoring methods (scoring-methods (list 'xomo.model:effort 'xomo.model:months 'xomo.model:defects 'xomo.model:threat 'xomo.model:energy)) ;;TODO pull out stat-methods (stat-methods (list 'median 'spread))) (cxml:with-xml-output sink (cxml:with-element "nova-output" (cxml:with-element "learning-output" (cxml:with-element "result" (cxml:attribute "search-engine" (nova-learning-output-search-engine-id nova-output)) (let ((result (nova-learning-output-result nova-output))) (labels ((generate-scores (constraints) (let ((scores (wvu-lib.guess:with-new-db (apply-treatments (complete-treatments constraints)) (monte-carlo :score-fn #'(lambda () (mapcar #'(lambda (sm) (cons sm (funcall (symbol-function sm)))) scoring-methods)) :combine-fn #'(lambda (l) (mapcar #'(lambda (sm) (cons sm (mapcar #'(lambda (x) (geta sm x)) l))) scoring-methods)) :n 100)))) (mapcar #'(lambda (score) (cons (first score) (mapcar #'(lambda (stat-m) (cons stat-m (funcall (symbol-function stat-m) (rest score)))) stat-methods))) scores)))) ;; initial-scores (cxml:with-element "initial-scores" (dolist (sm-s (generate-scores (constraints? (result-init-state result)))) (cxml:with-element "scoring-method" (cxml:attribute "name" (first sm-s)) (cxml:with-element "statistics" (dolist (n-v (rest sm-s)) (cxml:with-element "statistic" (cxml:attribute "name" (car n-v)) (cxml:attribute "value"(cdr n-v)))))))) ;; decisions (cxml:with-element "decisions" (dolist (decision (path2decisions (result-path result))) (when (> (length (decision-added-constraints decision)) 1) (warn "multiple new decisions")) ;;FIXME need to check for multiple values (let* ((new-constraint (first (decision-added-constraints decision))) (attribute (first new-constraint)) (value (second new-constraint))) (cxml:with-element "decision" (cxml:attribute "attribute" attribute) (cxml:attribute "type" "rating") (cxml:with-element "value" (cxml:text (format nil "~a" value))) (dolist (sm-s (generate-scores (decision-constraints decision))) (cxml:with-element "scoring-method" (cxml:attribute "name" (first sm-s)) (cxml:with-element "statistics" (dolist (n-v (rest sm-s)) (cxml:with-element "statistic" (cxml:attribute "name" (car n-v)) (cxml:attribute "value"(cdr n-v))))))))))))))))))) (defmethod nova-output-to-xml ((nova-output nova-error-output) (stream stream)) (let ((sink (if (eq (stream-element-type stream) 'character) (cxml:make-character-stream-sink stream); :canonical nil :indentation 1) (cxml:make-octet-stream-sink stream )))) (cxml:with-xml-output sink (cxml:with-element "nova-error" (cxml:with-element "errors" (dolist (error (nova-error-output-errors nova-output)) (cxml:with-element "error" (cxml:attribute "code" (nova-error-code error)) (cxml:with-element "message" (cxml:cdata (nova-error-message error))))))))))