[cells-cvs] CVS triple-cells
ktilton
ktilton at common-lisp.net
Thu Dec 20 13:08:17 UTC 2007
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 , at 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]
More information about the Cells-cvs
mailing list