[elephant-cvs] CVS elephant/examples

Sun Feb 19 04:52:58 UTC 2006

Update of /project/elephant/cvsroot/elephant/examples
In directory common-lisp:/tmp/cvs-serv7130/examples

Added Files:
	index-tutorial.lisp sql-tutorial.lisp 
Log Message:
See elephant-devel mail for changes...and take a big, deep breath...


--- /project/elephant/cvsroot/elephant/examples/index-tutorial.lisp	2006/02/19 04:52:58	NONE
+++ /project/elephant/cvsroot/elephant/examples/index-tutorial.lisp	2006/02/19 04:52:58	1.1

(defpackage elephant-tutorial 
  (:use :cl :elephant))

(in-package :elephant-tutorial)

(defclass simple-plog ()
  ((timestamp :accessor plog-timestamp :initarg :timestamp :index t)
   (type :accessor plog-type :initarg :type :index t)
   (data :accessor plog-data :initarg :data)
   (user :accessor plog-user :initarg :user :index t))
  (:metaclass persistent-metaclass)
  (:documentation "Simple persistent log"))

(defclass url-record ()
  ((url :accessor url-record-url :initarg :url :initform "")
   (fetched :accessor url-record-fetched :initarg :fetched :initform nil)
   (analyzed :accessor url-record-analyzed :initarg :analyzed :initform nil))
  (:documentation "An application object, declared persistent but not indexed"))

(defmethod print-object ((obj url-record) stream)
  "Pretty print program objects so they're easy to inspect"
  (format stream "<url: ~A ~A ~A>" (url-record-url obj) (url-record-fetched obj) (url-record-analyzed obj)))

(defclass url-log (simple-plog) ()
  (:metaclass persistent-metaclass)
  (:documentation "This class tracks events that transform our program object state"))

(defmethod print-object ((obj url-log) stream)
  "Structured printing of log entries so they're easy to inspect at the repl"
  (format stream "#plog[~A :: ~A]" (plog-type obj) (plog-data obj)))

(defun log-event (user type data)
  "A helper function to generically log various events by user"
  (make-instance 'url-log
		 :timestamp (get-universal-time)
		 :type type
		 :data data
		 :user user))

(defun report-events-by-time (user start end)
  "A custom reporting function for our logs - pull out a time range.  A real
   implementation might do it by dates or by dates + times using one of the
   lisp time libraries"
  (let ((entries1 (get-instances-by-range 'url-log 'timestamp start end))
	(entries2 (get-instances-by-value 'url-log 'user user)))
    (format t "Event logs for ~A (~A range, ~A user):~%" user (length entries1) (length entries2))
    (format t "~{~A~%~}" (nreverse (intersection entries1 entries2)))))

;;
;; This code is the skeleton of a program
;;

(defvar *start-timestamp* nil)
(defvar *end-timestamp* nil)

(defun generate-events (user count &optional delay)
  (setf *start-timestamp* (get-universal-time))
  (loop for i from 1 upto count do
       (let ((url (get-a-url user i)))
	 (sleep delay)
	 (fetch-url url user)
	 (sleep delay)
	 (analyze-url url user)
	 (sleep delay)))
  (setf *end-timestamp* (get-universal-time)))

(defun get-a-url (user seq)
  (let ((url (make-instance 'url-record :url (format nil "http://www.common-lisp.net/~A/" seq))))
    (log-event user :received-url url)
    url))

(defun fetch-url (url user)
  (setf (url-record-fetched url) t)
  (log-event user :fetched-url url))

(defun analyze-url (url user)
  (setf (url-record-analyzed url) t)
  (log-event user :analyzed-url url))
       
;; Top Level Test Code

(defun test-generate-and-report (name store-spec)
  (open-store store-spec)
  (generate-events name 10 0.2)
  (report-events name)
  (close-store))
			 
(defun report-events (name)
  (let ((first-third-start *start-timestamp*)
	(first-third-end (+ *start-timestamp*
			   (/ (- *end-timestamp* *start-timestamp*) 3))))
    (report-events-by-time name first-third-start first-third-end)))

--- /project/elephant/cvsroot/elephant/examples/sql-tutorial.lisp	2006/02/19 04:52:58	NONE
+++ /project/elephant/cvsroot/elephant/examples/sql-tutorial.lisp	2006/02/19 04:52:58	1.1
;;; sql-tutorial.lisp
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.


(asdf:operate 'asdf:load-op :elephant)
(asdf:operate 'asdf:load-op :ele-bdb)
(asdf:operate 'asdf:load-op :elephant-tests)
(in-package "ELEPHANT-TESTS")
(open-store *testdb-path*)
(add-to-root "my key" "my value")
(get-from-root "my key")

(setq foo (cons nil nil))

(add-to-root "my key" foo)
(add-to-root "my other key" foo)
(eq (get-from-root "my key")
                (get-from-root "my other key"))

(setf (car foo) T)

(get-from-root "my key")

(defclass my-persistent-class ()
        ((slot1 :accessor slot1)
         (slot2 :accessor slot2))
        (:metaclass persistent-metaclass))


(setq foo (make-instance 'my-persistent-class))

(add-to-root "foo" foo)

(add-to-root "bar" foo)

(eq (get-from-root "foo")
           (get-from-root "bar"))

(get-from-root "foo")
(setf (slot1 foo) "one")

(setf (slot2 foo) "two")
(slot1 foo)
(slot2 foo)
(setf (slot1 foo) "three")

(slot1 (get-from-root "bar"))

(setq *auto-commit* nil)
(with-transaction ()
        (setf (slot1 foo) 123456789101112)
        (setf (slot2 foo) "onetwothree..."))

(defvar *friends-birthdays* (make-btree))

(add-to-root "friends-birthdays" *friends-birthdays*)

(setf (get-value "Andrew" *friends-birthdays*)
     	(encode-universal-time 0 0 0 22 12 1976))
(setf (get-value "Ben" *friends-birthdays*)
     	(encode-universal-time 0 0 0 14 4 1976))

(get-value "Andrew" *friends-birthdays*)
(decode-universal-time *)
(defvar curs (make-cursor *friends-birthdays*))
 (cursor-close curs)
(setq curs (make-cursor *friends-birthdays*))
(cursor-current curs)
(cursor-first curs)
(cursor-next curs)
(cursor-next curs)
(cursor-close curs)
(with-transaction ()
  (with-btree-cursor (curs *friends-birthdays*)
    (loop
     (multiple-value-bind (more k v) (cursor-next curs)
       (unless more (return nil))
       (format t "~A ~A~%"  k v)))))

(defclass appointment ()
         ((date :accessor ap-date :initarg :date :type integer)
          (type :accessor ap-type :initarg :type :type string))
         (:metaclass persistent-metaclass))

(defvar *appointments* (with-transaction () (make-indexed-btree *store-controller*)))

(defun add-appointment (date type)
         (with-transaction ()
           (setf (get-value date *appointments*)
                 (make-instance 'appointment :date date :type type))))

(add-appointment (encode-universal-time 0 0 0 22 12 2004) "Birthday")
(add-appointment (encode-universal-time 0 0 0 14 4 2005) "Birthday")
(add-appointment (encode-universal-time 0 0 0 1 1 2005) "Holiday")
(defun key-by-type (secondary-db primary value)
         (declare (ignore secondary-db primary))
         (let ((type (ap-type value)))
           (when type
             (values t type))))
(with-transaction ()
         (add-index *appointments* :index-name 'by-type
                                   :key-form 'key-by-type
                                   :populate t))
(defvar *by-type* (get-index *appointments* 'by-type))

(decode-universal-time (ap-date (get-value "Holiday" *by-type*)))


(with-btree-cursor (curs *by-type*)
         (loop for (more? k v) =
               (multiple-value-list (cursor-set curs "Birthday"))
     	  then (multiple-value-list (cursor-next-dup curs))
               do
     	  (unless more? (return t))
     	  (multiple-value-bind (s m h d mo y)
     	      (decode-universal-time (ap-date v))
     	    (declare (ignore s m h))
     	    (format t "~A/~A/~A~%" mo d y))))