[isidorus-cvs] r707 - in trunk: playground src/rest_interface
lgiessmann at common-lisp.net
lgiessmann at common-lisp.net
Thu Aug 4 13:35:50 UTC 2011
Author: lgiessmann
Date: Thu Aug 4 06:35:48 2011
New Revision: 707
Log:
trunk: rest-interface: added the caching of topics and their psis => can be used for /json/psis
Added:
trunk/playground/binary-tree.lisp
Modified:
trunk/src/rest_interface/rest-interface.lisp
trunk/src/rest_interface/set-up-json-interface.lisp
Added: trunk/playground/binary-tree.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/playground/binary-tree.lisp Thu Aug 4 06:35:48 2011 (r707)
@@ -0,0 +1,359 @@
+;;; File: binary-tree.lisp -*- Mode: Lisp; Syntax: Common-Lisp -*-
+
+;; source: http://aima.cs.berkeley.edu/lisp/utilities/binary-tree.lisp
+
+
+;;;; The following definitions implement binary search trees.
+
+;;; They are not balanced as yet. Currently, they all order their
+;;; elements by #'<, and test for identity of elements by #'eq.
+
+
+(defstruct search-tree-node
+ "node for binary search tree"
+ value ;; list of objects with equal key
+ num-elements ;; size of the value set
+ key ;; f-cost of the a-star-nodes
+ parent ;; parent of search-tree-node
+ leftson ;; direction of search-tree-nodes with lesser f-cost
+ rightson ;; direction of search-tree-nodes with greater f-cost
+ )
+
+
+
+(defun make-search-tree (root-elem root-key &aux root)
+ "return dummy header for binary search tree, with initial
+ element root-elem whose key is root-key."
+ (setq root
+ (make-search-tree-node
+ :value nil
+ :parent nil
+ :rightson nil
+ :leftson (make-search-tree-node
+ :value (list root-elem)
+ :num-elements 1
+ :key root-key
+ :leftson nil :rightson nil)))
+ (setf (search-tree-node-parent
+ (search-tree-node-leftson root)) root)
+ root)
+
+
+
+(defun create-sorted-tree (list-of-elems key-fun &aux root-elem root)
+ "return binary search tree containing list-of-elems ordered according
+ tp key-fun"
+ (if (null list-of-elems)
+ nil
+ (progn
+ (setq root-elem (nth (random (length list-of-elems)) list-of-elems))
+ (setq list-of-elems (remove root-elem list-of-elems :test #'eq))
+ (setq root (make-search-tree root-elem
+ (funcall key-fun root-elem)))
+ (dolist (elem list-of-elems)
+ (insert-element elem root (funcall key-fun elem)))
+ root)))
+
+
+
+(defun empty-tree (root)
+ "Predicate of search trees; return t iff empty."
+ (null (search-tree-node-leftson root)))
+
+
+
+(defun leftmost (tree-node &aux next)
+ "return leftmost descendant of tree-node"
+ ;; used by pop-least-element and inorder-successor
+ (loop (if (null (setq next (search-tree-node-leftson tree-node)))
+ (return tree-node)
+ (setq tree-node next))))
+
+
+
+(defun rightmost (header &aux next tree-node)
+ "return rightmost descendant of header"
+ ;; used by pop-largest-element
+ ;; recall that root of tree is leftson of header, which is a dummy
+ (setq tree-node (search-tree-node-leftson header))
+ (loop (if (null (setq next (search-tree-node-rightson tree-node)))
+ (return tree-node)
+ (setq tree-node next))))
+
+
+
+(defun pop-least-element (header)
+ "return least element of binary search tree; delete from tree as side-effect"
+ ;; Note value slots of search-tree-nodes are lists of a-star-nodes, all of
+ ;; which have same f-cost = key slot of search-tree-node. This function
+ ;; arbitrarily returns first element of list with smallest f-cost,
+ ;; then deletes it from the list. If it was the last element of the list
+ ;; for the node with smallest key, that node is deleted from the search
+ ;; tree. (That's why we have a pointer to the node's parent).
+ ;; Node with smallest f-cost is leftmost descendant of header.
+ (let* ( (place (leftmost header))
+ (result (pop (search-tree-node-value place))) )
+ (decf (search-tree-node-num-elements place))
+ (when (null (search-tree-node-value place))
+ (when (search-tree-node-rightson place)
+ (setf (search-tree-node-parent
+ (search-tree-node-rightson place))
+ (search-tree-node-parent place)))
+ (setf (search-tree-node-leftson
+ (search-tree-node-parent place))
+ (search-tree-node-rightson place)))
+ result))
+
+
+
+
+(defun pop-largest-element (header)
+ "return largest element of binary search tree; delete from tree as side-effect"
+ ;; Note value slots of search-tree-nodes are lists of a-star-nodes, all of
+ ;; which have same key slot of search-tree-node. This function
+ ;; arbitrarily returns first element of list with largest key
+ ;; then deletes it from the list. If it was the last element of the list
+ ;; for the node with largest key, that node is deleted from the search
+ ;; tree. We need to take special account of the case when the largest element
+ ;; is the last element in the root node of the search-tree. In this case, it
+ ;; will be in the leftson of the dummy header. In all other cases,
+ ;; it will be in the rightson of its parent.
+ (let* ( (place (rightmost header))
+ (result (pop (search-tree-node-value place))) )
+ (decf (search-tree-node-num-elements place))
+ (when (null (search-tree-node-value place))
+ (cond ( (eq place (search-tree-node-leftson header))
+ (setf (search-tree-node-leftson header)
+ (search-tree-node-leftson place)) )
+ (t (when (search-tree-node-leftson place)
+ (setf (search-tree-node-parent
+ (search-tree-node-leftson place))
+ (search-tree-node-parent place)))
+ (setf (search-tree-node-rightson
+ (search-tree-node-parent place))
+ (search-tree-node-leftson place)))))
+ result))
+
+
+
+
+(defun least-key (header)
+ "return least key of binary search tree; no side effects"
+ (search-tree-node-key (leftmost header)))
+
+
+(defun largest-key (header)
+ "return least key of binary search tree; no side effects"
+ (search-tree-node-key (rightmost header)))
+
+
+
+(defun insert-element (element parent key
+ &optional (direction #'search-tree-node-leftson)
+ &aux place)
+ "insert new element at proper place in binary search tree"
+ ;; See Reingold and Hansen, Data Structures, sect. 7.2.
+ ;; When called initially, parent will be the header, hence go left.
+ ;; Element is an a-star-node. If tree node with key = f-cost of
+ ;; element already exists, just push element onto list in that
+ ;; node's value slot. Else have to make new tree node.
+ (loop (cond ( (null (setq place (funcall direction parent)))
+ (let ( (new-node (make-search-tree-node
+ :value (list element) :num-elements 1
+ :parent parent :key key
+ :leftson nil :rightson nil)) )
+ (if (eq direction #'search-tree-node-leftson)
+ (setf (search-tree-node-leftson parent) new-node)
+ (setf (search-tree-node-rightson parent) new-node)))
+ (return t))
+ ( (= key (search-tree-node-key place))
+ (push element (search-tree-node-value place))
+ (incf (search-tree-node-num-elements place))
+ (return t))
+ ( (< key (search-tree-node-key place))
+ (setq parent place)
+ (setq direction #'search-tree-node-leftson) )
+ (t (setq parent place)
+ (setq direction #'search-tree-node-rightson)))))
+
+
+
+
+(defun randomized-insert-element (element parent key
+ &optional (direction #'search-tree-node-leftson)
+ &aux place)
+ "insert new element at proper place in binary search tree -- break
+ ties randomly"
+ ;; This is just like the above, except that elements with equal keys
+ ;; are shuffled randomly. Not a "perfect shuffle", but the point is
+ ;; just to randomize whenever an arbitrary choice is to be made.
+
+ (loop (cond ( (null (setq place (funcall direction parent)))
+ (let ( (new-node (make-search-tree-node
+ :value (list element) :num-elements 1
+ :parent parent :key key
+ :leftson nil :rightson nil)) )
+ (if (eq direction #'search-tree-node-leftson)
+ (setf (search-tree-node-leftson parent) new-node)
+ (setf (search-tree-node-rightson parent) new-node)))
+ (return t))
+ ( (= key (search-tree-node-key place))
+ (setf (search-tree-node-value place)
+ (randomized-push element (search-tree-node-value place)))
+ (incf (search-tree-node-num-elements place))
+ (return t))
+ ( (< key (search-tree-node-key place))
+ (setq parent place)
+ (setq direction #'search-tree-node-leftson) )
+ (t (setq parent place)
+ (setq direction #'search-tree-node-rightson)))))
+
+
+
+
+(defun randomized-push (element list)
+ "return list with element destructively inserted at random into list"
+ (let ((n (random (+ 1 (length list)))) )
+ (cond ((= 0 n)
+ (cons element list))
+ (t (push element (cdr (nthcdr (- n 1) list)))
+ list))))
+
+
+
+
+(defun find-element (element parent key
+ &optional (direction #'search-tree-node-leftson)
+ &aux place)
+ "return t if element is int tree"
+ (loop (cond ( (null (setq place (funcall direction parent)))
+ (return nil) )
+ ( (= key (search-tree-node-key place))
+ (return (find element (search-tree-node-value place)
+ :test #'eq)) )
+ ( (< key (search-tree-node-key place))
+ (setq parent place)
+ (setq direction #'search-tree-node-leftson) )
+ (t (setq parent place)
+ (setq direction #'search-tree-node-rightson)))))
+
+
+
+
+
+(defun delete-element (element parent key &optional (error-p t)
+ &aux (direction #'search-tree-node-leftson)
+ place)
+ "delete element from binary search tree"
+ ;; When called initially, parent will be the header.
+ ;; Have to search for node containing element, using key, also
+ ;; keep track of parent of node. Delete element from list for
+ ;; node; if it's the last element on that list, delete node from
+ ;; binary tree. See Reingold and Hansen, Data Structures, pp. 301, 309.
+ ;; if error-p is t, signals error if element not found; else just
+ ;; returns t if element found, nil otherwise.
+ (loop (setq place (funcall direction parent))
+ (cond ( (null place) (if error-p
+ (error "delete-element: element not found")
+ (return nil)) )
+ ( (= key (search-tree-node-key place))
+ (cond ( (find element (search-tree-node-value place) :test #'eq)
+ ;; In this case we've found the right binary
+ ;; search-tree node, so we should delete the
+ ;; element from the list of nodes
+ (setf (search-tree-node-value place)
+ (remove element (search-tree-node-value place)
+ :test #'eq))
+ (decf (search-tree-node-num-elements place))
+ (when (null (search-tree-node-value place))
+ ;; If we've deleted the last element, we
+ ;; should delete the node from the binary search tree.
+ (cond ( (null (search-tree-node-leftson place))
+ ;; If place has no leftson sub-tree, replace it
+ ;; by its right sub-tree.
+ (when (search-tree-node-rightson place)
+ (setf (search-tree-node-parent
+ (search-tree-node-rightson place))
+ parent))
+ (if (eq direction #'search-tree-node-leftson)
+ (setf (search-tree-node-leftson parent)
+ (search-tree-node-rightson place))
+ (setf (search-tree-node-rightson parent)
+ (search-tree-node-rightson place))) )
+ ( (null (search-tree-node-rightson place) )
+ ;; Else if place has no right sub-tree,
+ ;; replace it by its left sub-tree.
+ (when (search-tree-node-leftson place)
+ (setf (search-tree-node-parent
+ (search-tree-node-leftson place))
+ parent))
+ (if (eq direction #'search-tree-node-leftson)
+ (setf (search-tree-node-leftson parent)
+ (search-tree-node-leftson place))
+ (setf (search-tree-node-rightson parent)
+ (search-tree-node-leftson place))) )
+ (t ;; Else find the "inorder-successor" of
+ ;; place, which must have nil leftson.
+ ;; Let it replace place, making its left
+ ;; sub-tree be place's current left
+ ;; sub-tree, and replace it by its own
+ ;; right sub-tree. (For details, see
+ ;; Reingold & Hansen, Data Structures, p. 301.)
+ (let ( (next (inorder-successor place)) )
+ (setf (search-tree-node-leftson next)
+ (search-tree-node-leftson place))
+ (setf (search-tree-node-parent
+ (search-tree-node-leftson next))
+ next)
+ (if (eq direction #'search-tree-node-leftson)
+ (setf (search-tree-node-leftson
+ parent) next)
+ (setf (search-tree-node-rightson parent)
+ next))
+ (unless (eq next (search-tree-node-rightson
+ place))
+ (setf (search-tree-node-leftson
+ (search-tree-node-parent next))
+ (search-tree-node-rightson next))
+ (when (search-tree-node-rightson next)
+ (setf (search-tree-node-parent
+ (search-tree-node-rightson next))
+ (search-tree-node-parent next)))
+ (setf (search-tree-node-rightson next)
+ (search-tree-node-rightson
+ place))
+ (setf (search-tree-node-parent
+ (search-tree-node-rightson next))
+ next))
+ (setf (search-tree-node-parent next)
+ (search-tree-node-parent place))))))
+ (return t))
+ (t (if error-p
+ (error "delete-element: element not found")
+ (return nil)))) )
+ ( (< key (search-tree-node-key place))
+ (setq parent place)
+ (setq direction #'search-tree-node-leftson))
+ (t (setq parent place)
+ (setq direction #'search-tree-node-rightson)))))
+
+
+
+
+
+(defun inorder-successor (tree-node)
+ "return inorder-successor of tree-node assuming it has a right son"
+ ;; this is used by function delete-element when deleting a node from
+ ;; the binary search tree. See Reingold and Hansen, pp. 301, 309.
+ ;; The inorder-successor is the leftmost descendant of the rightson.
+ (leftmost (search-tree-node-rightson tree-node)))
+
+
+
+(defun list-elements (parent &aux child)
+ "return list of elements in tree"
+ (append (when (setq child (search-tree-node-leftson parent))
+ (list-elements child))
+ (search-tree-node-value parent)
+ (when (setq child (search-tree-node-rightson parent))
+ (list-elements child))))
Modified: trunk/src/rest_interface/rest-interface.lisp
==============================================================================
--- trunk/src/rest_interface/rest-interface.lisp Wed Aug 3 12:22:06 2011 (r706)
+++ trunk/src/rest_interface/rest-interface.lisp Thu Aug 4 06:35:48 2011 (r707)
@@ -23,8 +23,9 @@
:json-importer
:base-tools
:isidorus-threading)
- (:export :import-fragments-feed
- :import-snapshots-feed
+ (:export :*use-overview-cache*
+ :import-fragments-feed
+ :import-snapshots-feed
:import-tm-feed
:read-url
:read-fragment-feed
Modified: trunk/src/rest_interface/set-up-json-interface.lisp
==============================================================================
--- trunk/src/rest_interface/set-up-json-interface.lisp Wed Aug 3 12:22:06 2011 (r706)
+++ trunk/src/rest_interface/set-up-json-interface.lisp Thu Aug 4 06:35:48 2011 (r707)
@@ -19,6 +19,11 @@
that represents a list of topics and their
valid psi object id's")
+
+(defparameter *use-overview-cache* t "if this boolean vaue is set to t, the rest
+ interface uses the *verview-table*-list to
+ cache topics and their psis.")
+
;the prefix to get a fragment by the psi -> localhost:8000/json/get/<fragment-psi>
(defparameter *json-get-prefix* "/json/get/(.+)$")
;the prefix to get a fragment by the psi -> localhost:8000/json/rdf/get/<fragment-psi>
@@ -125,7 +130,9 @@
;; === rest interface ========================================================
(push
- (create-regex-dispatcher json-get-all-psis #'return-all-topic-psis)
+ (if *use-overview-cache*
+ (create-regex-dispatcher json-get-all-psis #'cached-return-all-topic-psis)
+ (create-regex-dispatcher json-get-all-psis #'return-all-topic-psis))
hunchentoot:*dispatch-table*)
(push
(create-regex-dispatcher json-get-prefix #'return-json-fragment)
@@ -293,6 +300,33 @@
(setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+))))
+(defun cached-return-all-topic-psis (&optional param)
+ "return all psis currently existing in isidorus as a list of list. every topic is a list
+ of psis and the entire list contains a list of topics"
+ (declare (ignorable param))
+ (let ((http-method (hunchentoot:request-method*)))
+ (if (eq http-method :GET)
+ (progn
+ (setf (hunchentoot:content-type*) "application/json") ;RFC 4627
+ (handler-case
+ (with-reader-lock
+ (json:encode-json-to-string
+ (map 'list
+ (lambda(item)
+ (map 'list
+ (lambda(psi-oid)
+ (d:uri (elephant::controller-recreate-instance
+ elephant:*store-controller* psi-oid)))
+ (getf item :psis)))
+ *overview-table*)))
+ (condition (err) (progn
+ (setf (hunchentoot:return-code*)
+ hunchentoot:+http-internal-server-error+)
+ (setf (hunchentoot:content-type*) "text")
+ (format nil "Condition: \"~a\"" err)))))
+ (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+))))
+
+
(defun return-json-fragment(&optional psi)
"returns the json-fragmen belonging to the psi passed by the parameter psi.
If the topic is marked as deleted the corresponding fragment is treated
@@ -362,7 +396,9 @@
(handler-case
(let ((frag (json-importer:import-from-isidorus-json json-data)))
(when frag
- (push-to-cache (d:topic frag))))
+ (push-to-cache (d:topic frag))
+ (update-list (d:topic frag)
+ (d:psis (d:topic frag) :revision 0))))
(condition (err)
(progn
(setf (hunchentoot:return-code*)
@@ -458,8 +494,11 @@
(when (typep result 'd:TopicC)
(append ;;the append function is used only for suppress
;;style warnings of unused delete return values
- (delete (elephant::oid result) *type-table*)
- (delete (elephant::oid result) *instance-table*)))
+ (setf *type-table*
+ (delete (elephant::oid result) *type-table*))
+ (setf *instance-table*
+ (delete (elephant::oid result) *instance-table*))
+ (remove-topic-from-list result)))
(format nil "")) ;operation succeeded
(progn
(setf (hunchentoot:return-code*) hunchentoot:+http-not-found+)
@@ -506,6 +545,9 @@
(cxml:parse xml-data (cxml-dom:make-dom-builder)))))
(xtm-importer:importer xml-dom :tm-id tm-id
:xtm-id (xtm-importer::get-uuid))
+ (with-writer-lock
+ (init-cache)
+ (init-fragments))
(format nil ""))))
(setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+))
(condition (err)
@@ -569,6 +611,7 @@
(with-writer-lock
(setf *type-table* nil)
(setf *instance-table* nil)
+ (setf *overview-table* nil)
(let ((topictype (get-item-by-psi json-tmcl-constants::*topictype-psi*
:revision 0))
(topictype-constraint (json-tmcl::is-type-constrained :revision 0)))
@@ -576,7 +619,16 @@
(map 'list #'(lambda(top)
(format t ".")
(push-to-cache top topictype topictype-constraint))
- (elephant:get-instances-by-class 'TopicC)))))
+ (elephant:get-instances-by-class 'TopicC)))
+ (when *use-overview-cache*
+ (setf *overview-table*
+ (remove-null
+ (map 'list (lambda(top)
+ (when (find-item-by-revision top 0)
+ (list :topic (elephant::oid top)
+ :psis (map 'list #'elephant::oid
+ (psis top :revision 0)))))
+ (elephant:get-instances-by-class 'TopicC)))))))
(defun push-to-cache (topic-instance &optional
@@ -614,15 +666,16 @@
psi list."
(declare (TopicC top)
(List psis))
- (let ((node
- (find-if (lambda(item)
- (= (getf item :topic) (elephant::oid top)))
- *overview-table*))
- (psi-oids (map 'list #'elephant::oid psis)))
- (if node
- (setf (getf node :psis) psi-oids)
- (push (list :topic (elephant::oid top) :psis psi-oids)
- *overview-table*))))
+ (let ((top-oid (elephant::oid top)))
+ (let ((node
+ (find-if (lambda(item)
+ (= (getf item :topic) top-oid))
+ *overview-table*))
+ (psi-oids (map 'list #'elephant::oid psis)))
+ (if node
+ (setf (getf node :psis) psi-oids)
+ (push (list :topic top-oid :psis psi-oids)
+ *overview-table*)))))
(defun remove-psis-from-list (top psis)
@@ -630,14 +683,24 @@
to the passed topic."
(declare (TopicC top)
(List psis))
- (let ((node
- (find-if (lambda(item)
- (= (getf item :topic) (elephant::oid top)))
- *overview-table*))
- (psi-oids (map 'list #'elephant::oid psis)))
- (when node
- (dolist (psi psi-oids)
- (setf (getf node :psis) (delete psi (getf node :psis) :test #'=))))))
+ (let ((top-oid (elephant::oid top)))
+ (let ((node
+ (find-if (lambda(item)
+ (= (getf item :topic) top-oid))
+ *overview-table*))
+ (psi-oids (map 'list #'elephant::oid psis)))
+ (when node
+ (dolist (psi psi-oids)
+ (setf (getf node :psis) (delete psi (getf node :psis) :test #'=)))))))
+
+
+(defun remove-topic-from-list (top)
+ "Removes the node that represents the passed topic item."
+ (declare (TopicC top))
+ (let ((top-oid (elephant::oid top)))
+ (setf *overview-table*
+ (delete-if (lambda(item) (= (getf item :topic) top-oid))
+ *overview-table*))))
(defun add-to-list (top psis)
@@ -645,11 +708,12 @@
bound to the psi list of the topic top."
(declare (TopicC top)
(List psis))
- (let ((node
- (find-if (lambda(item) (= (getf item :topic) (elephant::oid top)))
- *overview-table*))
+ (let ((top-oid (elephant::oid top)))
+ (let ((node
+ (find-if (lambda(item) (= (getf item :topic) top-oid))
+ *overview-table*))
(psi-oids (map 'list #'elephant::oid psis)))
- (if node
- (dolist (psi psi-oids)
- (pushnew psi (getf node :psis) :test #'=))
- (push (list :topic top :psis psi-oids) *overview-table*))))
\ No newline at end of file
+ (if node
+ (dolist (psi psi-oids)
+ (pushnew psi (getf node :psis) :test #'=))
+ (push (list :topic top-oid :psis psi-oids) *overview-table*)))))
\ No newline at end of file
More information about the Isidorus-cvs
mailing list