[elephant-cvs] CVS elephant/src/elephant

[ieslick]

Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv19354

Added Files:
	query-example.lisp query.lisp 
Log Message:
Quick hack for object filtering queries; example of first pass at constraint syntax


--- /project/elephant/cvsroot/elephant/src/elephant/query-example.lisp	2007/03/01 02:45:45	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/query-example.lisp	2007/03/01 02:45:45	1.1

(in-package :elephant)

;; TEST DATA

(defparameter *constraint-spec*
  '(:BDB "/Users/eslick/Work/db/constraint/"))

(defun print-name (inst)
  (format t "Name: ~A~%" (slot-value inst 'name)))

(defpclass person ()
  ((name :initarg :name :index t)
   (salary :initarg :salary :index t)
   (department :initarg :dept)))

(defpclass department ()
  ((name :initarg :name)
   (manager :initarg :manager)))

(defparameter *names* 
    '("Jacob"
      "Emily"
"Michael"
"Emma"
"Joshua"
"Madison"
"Matthew"
"Abigail"
"Ethan"
"Olivia"
"Andrew"
"Isabella"
"Daniel"
"Hannah"
"Anthony"
"Samantha"
"Christopher"
"Ava"
"Joseph"
"Ashley"
))

(defun test-dataset ()
  (let* ((greg (make-instance 'person :name "Greg" :salary 100000))
	 (sally (make-instance 'person :name "Sally" :salary 110000))
	 (mkt (make-instance 'department :name "Marketing" :manager greg))
	 (engr (make-instance 'department :name "Engineering" :manager sally)))
    (setf (slot-value greg 'department) mkt)
    (setf (slot-value sally 'department) engr)
    (with-transaction ()
      (loop for i from 0 upto 500 do
	   (make-instance 'person 
			  :name (format nil "~A~A" (utils:random-element *names*) i)
			  :salary (floor (+ (* (random 1000) 150) 30000))
			  :department (if (= 1 (random 2)) mkt engr))))))

(defun print-person (person &optional (stream t))
  (format stream "name: ~A salary: ~A dept: ~A~%" 
	  (slot-value person 'name) (slot-value person 'salary) 
	  (slot-value (slot-value person 'department) 'name)))

(defun example-query1 ()
  "Performs a query against a single class.  Trivial string & integer matchingA"
  (map-class-query #'print-person
		   '((person name = "Greg")
		     (person salary >= 100000))))

(defun example-query2 (low-salary high-salary)
  "Parameterized query"
  (map-class-query #'print-person
		   `((person salary >= ,low-salary)
		     (person salary <= ,high-salary))))

		   
--- /project/elephant/cvsroot/elephant/src/elephant/query.lisp	2007/03/01 02:45:45	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/query.lisp	2007/03/01 02:45:45	1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; query.lisp -- Implement syntax for the elephant query engine
;;; 
;;; Copyright (c) 2007 by  Ian S. Eslick
;;; <ieslick at common-lisp.net>
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Limited General Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;

(in-package :elephant)

(defparameter *string-relation-functions*
  `((< . ,#'string<)
    (< . ,#'string<=)
    (> . ,#'string>)
    (> . ,#'string>=)
    (= . ,#'equal)
    (!= . ,(lambda (x y) (not (equal x y))))))

(defparameter *number-relation-functions*
  `((< . ,#'<)
    (> . ,#'>)
    (= . ,#'=)
    (!= . ,#'(lambda (x y) (not (= x y))))))

(defun relation-string-function (rel)
  (cdr (assoc rel *string-relation-functions*)))

(defun relation-number-function (rel)
  (cdr (assoc rel *number-relation-functions*)))

(defun test-relation (rel ival tvals)
  (assert (or (and (numberp ival) (numberp (first tvals)))
	      (and (stringp ival) (stringp (first tvals)))))
  (typecase ival
    (string (funcall (relation-string-function rel) ival (first tvals)))
    (number (funcall (relation-number-function rel) ival (first tvals)))))
      
(defun get-query-instances (constraints)
  (let ((list nil))
    (flet ((collect (inst)
	     (push inst list)))
      (declare (dynamic-extent collect))
      (map-class-query #'collect constraints))))

(defun map-class-query (fn constraints)
  "Map instances using the query constaints to filter objects, exploiting
   slot indices (for last query) and stack allocated test closures"
  (assert (not (null constraints)))
  (destructuring-bind (class slot relation &rest values) (first constraints)
    (flet ((filter-by-relation (inst)
	     (when (test-relation relation (slot-value inst slot) values)
	       (funcall fn inst))))
      (declare (dynamic-extent filter-by-relation))
      (if (null (cdr constraints))
	  (if (find-inverted-index class slot)
	      (if (= (length values) 1)
		  (progn
		    (map-class-index fn class slot (first values) (first values))
		    (map-class-index fn class slot (first values) (second values))))
	      (map-class #'filter-by-relation class))
	  (map-class-query #'filter-by-relation (cdr constraints))))))
       
;;
;; Conjunctions of indices
;;

;;(defun map-classes (fn classes)
;;  (map-index-list fn (mapcar #'find-class-index classes)))

;;(defun map-index-list (fn indices)
;;  (dolist (index indices)
;;    (map-index fn index)))