Update of /project/cells/cvsroot/triple-cells In directory clnet:/tmp/cvs-serv11470
Added Files: core.lisp defpackage.lisp hello-world.lisp triple-cells.lpr Log Message:
--- /project/cells/cvsroot/triple-cells/core.lisp 2007/12/20 13:08:17 NONE +++ /project/cells/cvsroot/triple-cells/core.lisp 2007/12/20 13:08:17 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: triple-cells; -*- ;;; ;;; ;;; Copyright (c) 1995,2003 by Kenneth William Tilton. ;;; ;;; 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.
(in-package :3c)
;; --- ag utils -----------------------
(defun triple-value (tr) (upi->value (object tr)))
(defun get-sp (s p) #+allegrocl (get-triple :s s :p p) #-allegrocl (car (get-triples-list :s s :p p)))
(defun get-spo (s p o) #+allegrocl (get-triple :s s :p p :o o) #-allegrocl (car (get-triples-list :s s :p p :o o)))
(defun get-sp-value (s p) (triple-value (get-sp s p)))
;; --- triple-cells ---
(defvar *3c?*) (defvar *3c-pulse*)
(defun 3c-init () (setf *3c-pulse* 0) (setf *3c?* (make-hash-table :test 'equal)))
;;; --- 3cell predicates -------------------------------------------
(defun 3c-cell? (c) (when (upip c) (get-sp c !ccc:type)))
(defun 3c-pulse (c) (get-sp-value c !ccc:pulse))
(defun 3c-ephemeral? (c) (get-sp c !ccc:ephemeral))
(defun 3c-ruled? (c) (when (upip c) (bwhen (tr-type (get-sp c !ccc:type)) (part= (object tr-type) !ccc:ruled))))
;;; --- 3cell accessors -------------------------------------------
(defun 3c-class-of (s) (intern (up$ (get-sp-value s !ccc:instance-of))))
(defun 3c-predicate-of (p) (intern (up$ (part-value p))))
(defun 3c-pred-value (s p) (loop for tr in (get-triples-list :s s :p p) unless (3c-cell? (object tr)) return (triple-value tr)))
(defun 3c-cell-value (c) (when (3c-ruled? c) (3c-ensure-current c)) (object (car (get-triples-list :s c :p !ccc:value))))
;; --- 3cell construction -----------------------------------------
(defun 3cv (initial-value &key ephemeral &aux (c (new-blank-node))) (add-triple c !ccc:type !ccc:input) (add-triple c !ccc:value (mk-upi initial-value)) (when ephemeral (add-triple c !ccc:ephemeral !ccc:t)) c)
(defmacro 3c? (&body rule) `(call-3c? '(progn ,@rule)))
(defun 3c?-rule-store (c-node rule) (setf (gethash *3c?* c-node) rule))
(defun 3c?-rule (c-node) (gethash *3c?* c-node))
(defun call-3c? (rule) (let* ((c (new-blank-node)) (tr-c (add-triple c !ccc:type !ccc:ruled)) (tr-cv (add-triple c !ccc:rule (mk-upi (princ-to-string rule))))) (3c?-rule-store c (eval rule)) (trc "c? type tr" tr-c) (trc "c? value tr" tr-cv) c))
(defun 3c-ensure-current (c) (when (> *3c-pulse* (3c-pulse c))))
;;; --- 3cell observation --------------------------------------------------------
(defun 3c-echo-triple (s p new-value prior-value prior-value?) (3c-observe-predicate (3c-class-of s)(3c-predicate-of p) new-value (when prior-value (upi->value prior-value)) prior-value?))
(defmethod 3c-observe-predicate (s p new-value prior-value prior-value?) (trc "3c-observe undefined" s p new-value prior-value prior-value?))
;;; --- access ------------------------------------------
(defun 3c-add-triple (s p o &aux (tv o)) (when (3c-cell? o) (add-triple s p o) ;; associate cell with this s and p (incf *3c-pulse*) (add-triple o !ccc:pulse (mk-upi *3c-pulse*)) (setf tv (3c-cell-value o))) (add-triple s p (mk-upi tv)) (3c-echo-triple s p tv nil nil))
(defun (setf 3c) (new-value s p) (trc "SETF>" p new-value) (let (tr-cell tr-value) (loop for tr in (get-triples-list :s s :p p) if (3c-cell? (object tr)) do (setf tr-cell tr) else do (setf tr-value tr)) (assert tr-cell () "subject ~a pred ~a not mediated by input cell so cannot be changed from ~a to ~a" s p (object tr-value) new-value) ;(trc "tr-cell" (triple-id tr-cell)) ;(trc "tr-value" (triple-id tr-value)) (let ((prior-object (object tr-value))) (unless (equal new-value (upi->value prior-object)) (delete-triple (triple-id tr-value)) ;(trc "tr-value orig deleted") (let* ((new-value-upi (mk-upi new-value)) (tr-value-new (add-triple s p new-value-upi))) (let ((tr-cell-value (car (get-triples-list :s (object tr-cell) :p !ccc:value)))) (assert tr-cell-value) (delete-triple (triple-id tr-cell-value)) (let ((tr-cell-value-new (add-triple (object tr-cell) !ccc:value new-value-upi))) (3c-observe-predicate (3c-class-of s)(3c-predicate-of p) new-value (upi->value prior-object) t) (when (3c-ephemeral? (object tr-cell)) ; fix up cell... (delete-triple tr-cell-value-new) (add-triple (object tr-cell) !ccc:value !ccc:nil) ; reset value itself to nil (delete-triple tr-value-new) (add-triple s p !ccc:nil)))))))))
;;; --- utils ------------------------
(defun mk-upi (v) (typecase v (string (literal v)) (integer (value->upi v :short)) (otherwise v) ;; probably should not occur ))--- /project/cells/cvsroot/triple-cells/defpackage.lisp 2007/12/20 13:08:17 NONE +++ /project/cells/cvsroot/triple-cells/defpackage.lisp 2007/12/20 13:08:17 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-user; -*- ;;; ;;; Copyright (c) 1995,2003 by Kenneth William Tilton. ;;; ;;; 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.
(in-package :common-lisp-user)
;;; Porting to Redland left as an exercise: http://librdf.org/
(eval-when (:compile-toplevel :load-toplevel :execute) (require :agraph))
(defpackage :triple-cells (:nicknames :3c) (:use #:common-lisp #:utils-kt #:db.agraph #:cells)) ;; cells just fro TRC (so far)
--- /project/cells/cvsroot/triple-cells/hello-world.lisp 2007/12/20 13:08:17 NONE +++ /project/cells/cvsroot/triple-cells/hello-world.lisp 2007/12/20 13:08:17 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: triple-cells; -*- ;;; ;;; ;;; Copyright (c) 1995,2003 by Kenneth William Tilton. ;;; ;;; 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.
(in-package :3c)
#+wait (def-3c-observer happen () (when new-value (format t "~&happen: ~a" new-value)))
(defmethod 3c-observe-predicate (s (p (eql 'happen)) new-value prior-value prior-value?) (trc "OBS> happen" s new-value prior-value prior-value?))
(defmethod 3c-observe-predicate (s (p (eql 'location)) new-value prior-value prior-value?) (trc "OBS> location" s new-value prior-value prior-value?))
(defun 3c-test () (let ((*synchronize-automatically* t)) (enable-print-decoded t) (make-tutorial-store) (register-namespace "hw" "helloworld#" :errorp nil) (register-namespace "ccc" "triplecells#" :errorp nil)
(let ((dell (new-blank-node)) (happen !"happen") (location !"location"))
(add-triple dell !ccc:instance-of !<computer>)
(3c-add-triple dell happen #+const "test" (3cv "test" :ephemeral t)) (trc "start happen is" (3c-pred-value dell happen))
(3c-add-triple dell location (3c? (if (string-equal (3c-pred-value dell happen) "arrive") "home" "away"))) (trc "start location is" (3c-pred-value dell location))
(loop repeat 2 do (setf (3c dell happen) "knock-knock")) (setf (3c dell happen) "arrive") (setf (3c dell happen) "knock-knock") (setf (3c dell happen) "leave"))))
#|
(defmd computer () (happen (c-in nil) :cell :ephemeral) (location (c? (case (^happen) (:leave :away) (:arrive :at-home) (t .cache)))) ;; ie, unchanged (response nil :cell :ephemeral))
(defobserver response(self new-response old-response) (when new-response (format t "~&computer: ~a" new-response)))
(defobserver happen() (when new-value (format t "~&happen: ~a" new-value)))
(def-cell-test hello-world () (let ((dell (make-instance 'computer :response (c? (bwhen (h (happen self)) (if (eql (^location) :at-home) (case h (:knock-knock "who's there?") (:world "hello, world.")) "<silence>")))))) (dotimes (n 2) (setf (happen dell) :knock-knock))
(setf (happen dell) :arrive) (setf (happen dell) :knock-knock) (setf (happen dell) :leave) (values)))
|#
#+(or) (hello-world)
#| output
happen: KNOCK-KNOCK computer: <silence> happen: KNOCK-KNOCK computer: <silence> happen: ARRIVE happen: KNOCK-KNOCK computer: who's there? happen: LEAVE computer: <silence>
|#
--- /project/cells/cvsroot/triple-cells/triple-cells.lpr 2007/12/20 13:08:17 NONE +++ /project/cells/cvsroot/triple-cells/triple-cells.lpr 2007/12/20 13:08:17 1.1 ;; -*- lisp-version: "8.1 [Windows] (Dec 2, 2007 6:32)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
(defpackage :TRIPLE-CELLS)
(define-project :name :triple-cells :modules (list (make-instance 'module :name "defpackage.lisp") (make-instance 'module :name "ag-utils.lisp") (make-instance 'module :name "core.lisp") (make-instance 'module :name "agraph-tutorial") (make-instance 'module :name "hello-world.lisp")) :projects (list (make-instance 'project-module :name "..\Cells\cells")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :triple-cells :main-form nil :compilation-unit t :verbose nil :runtime-modules (list :cg-dde-utils :cg.acache :cg.base :cg.bitmap-pane :cg.bitmap-pane.clipboard :cg.bitmap-stream :cg.button :cg.caret :cg.chart-or-plot :cg.chart-widget :cg.check-box :cg.choice-list :cg.choose-printer :cg.class-grid :cg.class-slot-grid :cg.class-support :cg.clipboard :cg.clipboard-stack :cg.clipboard.pixmap :cg.color-dialog :cg.combo-box :cg.common-control :cg.comtab :cg.cursor-pixmap :cg.curve :cg.dialog-item :cg.directory-dialog :cg.directory-dialog-os :cg.drag-and-drop :cg.drag-and-drop-image :cg.drawable :cg.drawable.clipboard :cg.dropping-outline :cg.edit-in-place :cg.editable-text :cg.file-dialog :cg.fill-texture :cg.find-string-dialog :cg.font-dialog :cg.gesture-emulation :cg.get-pixmap :cg.get-position :cg.graphics-context :cg.grid-widget :cg.grid-widget.drag-and-drop :cg.group-box :cg.header-control :cg.hotspot :cg.html-dialog :cg.html-widget :cg.icon :cg.icon-pixmap :cg.ie :cg.item-list :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip :cg.message-dialog :cg.multi-line-editable-text :cg.multi-line-lisp-text :cg.multi-picture-button :cg.multi-picture-button.drag-and-drop :cg.multi-picture-button.tooltip :cg.object-editor :cg.object-editor.layout :cg.ocx :cg.os-widget :cg.os-window :cg.outline :cg.outline.drag-and-drop :cg.outline.edit-in-place :cg.palette :cg.paren-matching :cg.picture-widget :cg.picture-widget.palette :cg.pixmap :cg.pixmap-widget :cg.pixmap.file-io :cg.pixmap.printing :cg.pixmap.rotate
[36 lines skipped]