Permalink
Browse files

first commit of exisitng repo

  • Loading branch information...
1 parent 8a77857 commit def33fb8f8c4f0ec0ae647b4449f4589c44ba8c1 @kraison committed Nov 8, 2010
Showing with 2,544 additions and 0 deletions.
  1. +125 −0 certainty-factors.lisp
  2. +8 −0 conditions.lisp
  3. +37 −0 constants.lisp
  4. +20 −0 data-types.lisp
  5. +2 −0 full-text-index.lisp
  6. +47 −0 functor.lisp
  7. +88 −0 gettimeofday.lisp
  8. +49 −0 globals.lisp
  9. +157 −0 index.lisp
  10. +55 −0 namespaces.lisp
  11. +337 −0 prolog-functors.lisp
  12. +603 −0 prologc.lisp
  13. +26 −0 rw.lisp
  14. +98 −0 store.lisp
  15. +61 −0 templates.lisp
  16. +49 −0 test.lisp
  17. +70 −0 transaction.lisp
  18. +243 −0 triples.lisp
  19. +222 −0 utilities.lisp
  20. +66 −0 uuid.lisp
  21. +133 −0 vivace-graph-v2-package.lisp
  22. +48 −0 vivace-graph-v2.asd
View
@@ -0,0 +1,125 @@
+;;; Copyright (C) 2000 David E. Young
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+
+;;; This library 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 Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public License
+;;; along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+;;; File: certainty-factors.lisp
+
+;;; Description: An implementation of Certainty Factors as found in Peter Norvig's PAIP.
+
+;;; Modified for VivaceGraph by Keivn Raison, 2010
+
+(in-package #:vivace-graph-v2)
+
+(defgeneric belief-factor (tuple))
+
+(defmethod belief-factor ((tuple list))
+ (fifth tuple))
+
+(defun certainty-factor-p (number)
+ (<= +cf-false+ number +cf-true+))
+
+(deftype certainty-factor ()
+ `(and (real)
+ (satisfies certainty-factor-p)))
+
+(defun true-p (cf)
+ (check-type cf certainty-factor)
+ (> cf +cf-unknown+))
+
+(defun false-p (cf)
+ (check-type cf certainty-factor)
+ (< cf +cf-unknown+))
+
+(defun unknown-p (cf)
+ (check-type cf certainty-factor)
+ (= cf +cf-unknown+))
+
+(defun cf-or (a b)
+ "Combine the certainty factors for the formula (A or B).
+ This is used when two rules support the same conclusion."
+ (check-type a certainty-factor)
+ (check-type b certainty-factor)
+ (cond ((and (> a 0) (> b 0))
+ (+ a b (* -1 a b)))
+ ((and (< a 0) (< b 0))
+ (+ a b (* a b)))
+ (t (/ (+ a b)
+ (- 1 (min (abs a) (abs b)))))))
+
+(defun cf-and (a b)
+ "Combine the certainty factors for the formula (A and B)."
+ (check-type a certainty-factor)
+ (check-type b certainty-factor)
+ (min a b))
+
+(defun cf-combine (a b)
+ (check-type a certainty-factor)
+ (check-type b certainty-factor)
+ (cond ((and (plusp a)
+ (plusp b))
+ (+ a b (* -1 a b)))
+ ((and (minusp a)
+ (minusp b))
+ (+ a b (* a b)))
+ (t (/ (+ a b)
+ (- 1 (min (abs a) (abs b)))))))
+
+(defun conjunct-cf (objects)
+ "Combines the certainty factors of objects matched within a single rule."
+ (let ((conjuncts
+ (loop for obj in objects
+ for cf = (belief-factor obj)
+ if cf collect cf)))
+ (if conjuncts
+ (apply #'min conjuncts)
+ nil)))
+
+(defgeneric recalculate-cf (objects rule-cf old-cf)
+ (:method (objects (rule-cf number) (old-cf number))
+ (let* ((combined-cf (conjunct-cf objects))
+ (new-cf (if combined-cf (* rule-cf combined-cf) rule-cf)))
+ (cf-combine old-cf new-cf)))
+ (:method (objects (rule-cf number) (old-cf t))
+ (let* ((combined-cf (conjunct-cf objects))
+ (new-cf (if combined-cf combined-cf rule-cf))
+ (factor (if combined-cf rule-cf +cf-true+)))
+ (* new-cf factor)))
+ (:method (objects (rule-cf t) (old-cf t))
+ (let* ((combined-cf (conjunct-cf objects)))
+ (if combined-cf
+ (* combined-cf 1.0)
+ nil))))
+
+(defun cf->english (cf)
+ (cond ((= cf 1.0) "certain evidence")
+ ((> cf 0.8) "strongly suggestive evidence")
+ ((> cf 0.5) "suggestive evidence")
+ ((> cf 0.0) "weakly suggestive evidence")
+ ((= cf 0.0) "no evidence either way")
+ ((< cf 0.0) (concatenate 'string (cf->english (- cf))
+ " against the conclusion"))))
+
+;;; interface into the generic belief system.
+
+(defmethod adjust-belief (objects (rule-belief number) &optional (old-belief nil))
+ (recalculate-cf objects rule-belief old-belief))
+
+(defmethod adjust-belief (objects (rule-belief t) &optional old-belief)
+ (declare (ignore objects old-belief))
+ nil)
+
+(defmethod belief->english ((cf number))
+ (cf->english cf))
+
View
@@ -0,0 +1,8 @@
+(in-package #:vivace-graph-v2)
+
+(define-condition prolog-error (error)
+ ((reason :initarg :reason))
+ (:report (lambda (error stream)
+ (with-slots (reason) error
+ (format stream "Prolog error: ~A." reason)))))
+
View
@@ -0,0 +1,37 @@
+(in-package #:vivace-graph-v2)
+
+(cffi:defctype size :unsigned-int)
+
+;; Prolog constants and specials
+(defconstant +unbound+ :unbound)
+(ignore-errors (defconstant +no-bindings+ '((t . t))))
+(defconstant +fail+ nil)
+
+;; Certainty factors
+(defconstant +cf-true+ 1.0)
+(defconstant +cf-false+ -1.0)
+(defconstant +cf-unknown+ 0.0)
+
+(defconstant +needs-lookup+ :needs-lookup)
+
+;; User-defined type identifiers for serializing. Start at 100
+(defconstant +triple+ 101)
+;;(defconstant +node+ 102)
+(defparameter +psymbol+ 102)
+(defconstant +predicate+ 103)
+(defconstant +rule+ 105)
+
+;; Tags for sorting entry types in tokyo cabinet
+(defconstant +triple-key+ 201)
+;;(defconstant +node-key+ 202)
+(defconstant +predicate-key+ 209)
+(defconstant +triple-subject+ 203)
+(defconstant +triple-predicate+ 204)
+(defconstant +triple-object+ 205)
+(defconstant +triple-subject-predicate+ 206)
+(defconstant +triple-subject-object+ 207)
+(defconstant +triple-predicate-object+ 208)
+;;(defconstant +node-ref-count+ 209)
+(defconstant +deleted-triple-key+ 210)
+(defconstant +text-index+ 211)
+(defconstant +rule-key+ 212)
View
@@ -0,0 +1,20 @@
+(in-package #:vivace-graph-v2)
+
+;;; UUIDs
+(defun make-uuid ()
+ "Create a new UUID."
+ (uuid:make-v1-uuid))
+
+(defun sxhash-uuid (uuid) (sxhash (uuid:print-bytes nil uuid)))
+
+(sb-ext:define-hash-table-test uuid:uuid-eql sxhash-uuid)
+
+(defun make-uuid-table (&key synchronized)
+ (make-hash-table :test 'uuid:uuid-eql :synchronized synchronized))
+
+
+;;; Dates
+;;; timestamps provided by local-time lib
+(defgeneric timestamp? (thing)
+ (:method ((thing timestamp)) t)
+ (:method (thing) nil))
@@ -0,0 +1,2 @@
+(in-package #:vivace-graph-v2)
+
View
@@ -0,0 +1,47 @@
+(in-package #:vivace-graph-v2)
+
+(defstruct (functor
+ (:constructor %make-functor)
+ (:predicate functor?))
+ name fn clauses (lock (make-recursive-lock)))
+
+(defun lookup-functor (name)
+ (gethash name *user-functors*))
+
+(defun make-functor (&key name clauses)
+ (or (lookup-functor name)
+ (let ((functor (%make-functor :name name
+ :clauses clauses)))
+ (prog1
+ (setf (gethash name *user-functors*) functor)
+ (prolog-compile functor)))))
+
+(defun add-functor-clause (functor clause)
+ (with-recursive-lock-held ((functor-lock functor))
+ (cas (cdr (last (functor-clauses functor)))
+ (cdr (last (functor-clauses functor)))
+ (list clause))
+ (prolog-compile functor))
+ (functor-clauses functor))
+
+(defun delete-functor (functor)
+ (remhash (functor-name functor) *user-functors*))
+
+(defun reset-functor (functor)
+ (with-recursive-lock-held ((functor-lock functor))
+ (cas (functor-clauses functor) (functor-clauses functor) nil)
+ (prolog-compile functor))
+ nil)
+
+(defun get-functor-fn (functor-symbol)
+ (let ((f (lookup-functor functor-symbol)))
+ (when (functor? f)
+ (functor-fn f))))
+
+(defun set-functor-fn (functor-symbol fn)
+ (let ((f (lookup-functor functor-symbol)))
+ ;;(when *prolog-trace* (format t "set-functor-fn for ~A got ~A~%" functor-symbol f))
+ (if (functor? f)
+ (setf (functor-fn f) fn)
+ (error 'prolog-error
+ :reason (format nil "unknown functor ~A" functor-symbol)))))
View
@@ -0,0 +1,88 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; gettimeofday.lisp --- Example CFFI binding to gettimeofday(2)
+;;;
+;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# CFFI Example: gettimeofday binding
+;;;
+;;; This example illustrates the use of foreign structures, typedefs,
+;;; and using type translators to do checking of input and output
+;;; arguments to a foreign function.
+
+;;; Define the TIMEVAL structure used by 'gettimeofday'. This assumes
+;;; that 'time_t' is a 'long' --- it would be nice if CFFI could
+;;; provide a proper :TIME-T type to help make this portable.
+(in-package #:vivace-graph-v2)
+
+(defcstruct timeval
+ (tv-sec :long)
+ (tv-usec :long))
+
+;;; A NULL-POINTER is a foreign :POINTER that must always be NULL.
+;;; Both a NULL pointer and NIL are legal values---any others will
+;;; result in a runtime error.
+(define-foreign-type null-pointer-type ()
+ ()
+ (:actual-type :pointer)
+ (:simple-parser null-pointer))
+
+;;; This type translator is used to ensure that a NULL-POINTER has a
+;;; null value. It also converts NIL to a null pointer.
+(defmethod translate-to-foreign (value (type null-pointer-type))
+ (cond
+ ((null value) (null-pointer))
+ ((null-pointer-p value) value)
+ (t (error "~A is not a null pointer." value))))
+
+;;; The SYSCALL-RESULT type is an integer type used for the return
+;;; value of C functions that return -1 and set errno on errors.
+;;; Someday when CFFI has a portable interface for dealing with
+;;; 'errno', this error reporting can be more useful.
+(define-foreign-type syscall-result-type ()
+ ()
+ (:actual-type :int)
+ (:simple-parser syscall-result))
+
+;;; Type translator to check a SYSCALL-RESULT and signal a Lisp error
+;;; if the value is negative.
+(defmethod translate-from-foreign (value (type syscall-result-type))
+ (if (minusp value)
+ (error "System call failed with return value ~D." value)
+ value))
+
+;;; Define the Lisp function %GETTIMEOFDAY to call the C function
+;;; 'gettimeofday', passing a pointer to the TIMEVAL structure to fill
+;;; in. The TZP parameter is deprecated and should be NULL --- we can
+;;; enforce this by using our NULL-POINTER type defined above.
+(defcfun ("gettimeofday" %gettimeofday) syscall-result
+ (tp :pointer)
+ (tzp null-pointer))
+
+(defun gettimeofday ()
+ (with-foreign-object (tv 'timeval)
+ (%gettimeofday tv nil)
+ (with-foreign-slots ((tv-sec tv-usec) tv timeval)
+ (+ tv-sec (/ tv-usec 1000000)))))
+
View
@@ -0,0 +1,49 @@
+(in-package #:vivace-graph-v2)
+
+(defparameter *store* nil)
+(defparameter *store-table* (make-hash-table :synchronized t :test 'eql))
+(defparameter *namespaces* (make-hash-table :synchronized t :test 'equalp))
+
+;; Graphs
+(defvar *graph* nil)
+(defvar *graph-table* nil)
+
+;; Logging
+(defvar *syslog-program* "vivace-graph-v2")
+(defvar *syslog-facility* sb-posix:log-local7)
+(progn
+ (defparameter *syslog-priorities* (make-hash-table))
+ (setf (gethash :emerg *syslog-priorities*) sb-posix:log-emerg)
+ (setf (gethash :alert *syslog-priorities*) sb-posix:log-alert)
+ (setf (gethash :crit *syslog-priorities*) sb-posix:log-crit)
+ (setf (gethash :err *syslog-priorities*) sb-posix:log-err)
+ (setf (gethash :warning *syslog-priorities*) sb-posix:log-warning)
+ (setf (gethash :warn *syslog-priorities*) sb-posix:log-warning)
+ (setf (gethash :notice *syslog-priorities*) sb-posix:log-notice)
+ (setf (gethash :info *syslog-priorities*) sb-posix:log-info)
+ (setf (gethash :debug *syslog-priorities*) sb-posix:log-debug))
+
+;; Prolog specials
+(defparameter *occurs-check* t)
+(defvar *trail* (make-array 200 :fill-pointer 0 :adjustable t))
+(defvar *var-counter* 0 "Counter for generating variable names.")
+(defvar *functor* nil "The Prolog functor currently being compiled.")
+(defvar *select-list* nil "Accumulator for prolog selects.")
+(defvar *cont* nil "Continuation container for step-wise queries.")
+(defvar *prolog-global-functors* (make-hash-table :synchronized t))
+(defvar *user-functors* (make-hash-table :synchronized t :test 'eql))
+
+;; Shortened slot identifiers for slot keys
+(defparameter +predicate-slot+ #x00)
+(defparameter +subject-slot+ #x01)
+(defparameter +object-slot+ #x02)
+(defparameter +timestamp-slot+ #x03)
+(defparameter +belief-factor-slot+ #x04)
+(defparameter +deleted?-slot+ #x04)
+(defparameter +derived?-slot+ #x05)
+(defparameter +uuid-slot+ #x06)
+(defparameter +name-slot+ #x07)
+(defparameter +clauses-slot+ #x08)
+(defparameter +premises-slot+ #x09)
+(defparameter +conclusions-slot+ #x10)
+(defparameter +cf-slot+ #x11)
Oops, something went wrong.

0 comments on commit def33fb

Please sign in to comment.