Commit 8120c87c authored by Dave Cooper's avatar Dave Cooper

added god-parent concept.

parent fb33adba
...@@ -750,7 +750,8 @@ overview of <tt>define-object</tt> syntax." ...@@ -750,7 +750,8 @@ overview of <tt>define-object</tt> syntax."
(defun make-standard-slots () (defun make-standard-slots ()
`((gdl-acc::%version-tree% :accessor gdl-acc::%version-tree% :initform nil) `((gdl-acc::%version-tree% :accessor gdl-acc::%version-tree% :initform nil)
(gdl-acc::%toplevel-inputs% :accessor gdl-acc::%toplevel-inputs% :initform nil :initarg :%toplevel-inputs%) (gdl-acc::%toplevel-inputs% :accessor gdl-acc::%toplevel-inputs% :initform nil :initarg :%toplevel-inputs%)
(gdl-acc::%root% :accessor gdl-acc::%root% :initform nil :initarg :%root%))) (gdl-acc::%root% :accessor gdl-acc::%root% :initform nil :initarg :%root%)
(gdl-acc::%god-parents% :accessor gdl-acc::%god-parents% :initform nil :initarg :%god-parents%)))
(defun first-symbol (list) (defun first-symbol (list)
......
...@@ -74,16 +74,20 @@ The argument ~s, and its value ~s, have been ignored ...@@ -74,16 +74,20 @@ The argument ~s, and its value ~s, have been ignored
:arguments (object-name \"Symbol. Should name a GDL object type.\" :arguments (object-name \"Symbol. Should name a GDL object type.\"
arguments \"spliced-in plist. A plist of keyword symbols and values for initial <tt>input-slots</tt>.\")" arguments \"spliced-in plist. A plist of keyword symbols and values for initial <tt>input-slots</tt>.\")"
(let (*notify-cons* (let (*notify-cons*
(keys (plist-keys args)) (keys (plist-keys args))
(vals (plist-values args))) (vals (plist-values args)))
(let ((object (apply #'make-instance (let ((object (apply #'make-instance
object-type object-type
:allow-other-keys t :allow-other-keys t ;; FLAG -- tell me again why we should allow other keys?
(append (list :%name% (list (format nil "~a" object-type) nil t) (append (list :%name% (list (format nil "~a" object-type) nil t)
:%parent% (list nil nil t)) :%parent% (list nil nil t)
:%god-parents% (getf args :god-parents))
(mapcan #'(lambda(key val) (mapcan #'(lambda(key val)
(list key (list val nil t))) (unless (eql key :god-parents)
(list key (list val nil t))))
keys vals))))) keys vals)))))
(setf (gdl-acc::%root% object) object (setf (gdl-acc::%root% object) object
......
...@@ -28,7 +28,9 @@ ...@@ -28,7 +28,9 @@
extra parentheses around the message in the reference chain and using the index number. But the aggregate itself also supports certain extra parentheses around the message in the reference chain and using the index number. But the aggregate itself also supports certain
messages, documented here. One message, <tt>number-of-elements</tt>, is not listed in the normal messages section because it is messages, documented here. One message, <tt>number-of-elements</tt>, is not listed in the normal messages section because it is
internal. It can be used, and returns an integer representing the cardinality of the aggregate.") internal. It can be used, and returns an integer representing the cardinality of the aggregate.")
:input-slots
((remember-children? nil))
:computed-slots :computed-slots
((index nil) ((index nil)
......
...@@ -36,7 +36,7 @@ toplevel of the define-object form.") ...@@ -36,7 +36,7 @@ toplevel of the define-object form.")
:input-slots :input-slots
( (
(remote-id nil :settable) (remote-id nil :settable)
(quantify-box (or (the parent) self)) (quantify-box (or (the parent) self))
...@@ -99,7 +99,7 @@ nil "~a~a~a" (the :name-for-display) ...@@ -99,7 +99,7 @@ nil "~a~a~a" (the :name-for-display)
:computed-slots :computed-slots
( ((remember-children? nil)
(%corners% nil) (%corners% nil)
(%vertex-array% nil) (%vertex-array% nil)
...@@ -388,41 +388,41 @@ or all mixins from the entire inheritance hierarchy.\")" ...@@ -388,41 +388,41 @@ or all mixins from the entire inheritance hierarchy.\")"
:arguments (slot \"Keyword Symbol\") :arguments (slot \"Keyword Symbol\")
:key (force? \"Boolean. Specify as t if you want to force non-settable slots to recompute (e.g. :key (force? \"Boolean. Specify as t if you want to force non-settable slots to recompute (e.g.
reading from databases or external files). Defaults to nil.\")" reading from databases or external files). Defaults to nil.\")"
restore-slot-default! restore-slot-default!
(attribute &key (force? *force-restore-slot-default?*)) (attribute &key (force? *force-restore-slot-default?*))
(when (or force? (eql (the (slot-status attribute)) :set)) (when (or force? (eql (the (slot-status attribute)) :set))
(let (*leaf-resets*) (let (*leaf-resets*)
(let ((slot (glisp:intern (symbol-name attribute) :gdl-acc))) (let ((slot (glisp:intern (symbol-name attribute) :gdl-acc)))
(unless (eq (first (ensure-list (slot-value self slot))) 'gdl-rule::%unbound%) (unless (eq (first (ensure-list (slot-value self slot))) 'gdl-rule::%unbound%)
(unbind-dependent-slots self slot) (unbind-dependent-slots self slot)
(setf (slot-value self slot) (setf (slot-value self slot)
(if *remember-previous-slot-values?* (if (or *remember-previous-slot-values?* (the remember-children?))
(list 'gdl-rule::%unbound% nil nil (first (slot-value self slot))) (list 'gdl-rule::%unbound% nil nil (first (slot-value self slot)))
'gdl-rule::%unbound%)))) 'gdl-rule::%unbound%))))
(let ((root (let ((maybe-root (the :root))) (let ((root (let ((maybe-root (the :root)))
(if (the-object maybe-root root?) (if (the-object maybe-root root?)
maybe-root maybe-root
(the-object maybe-root parent)))) (the-object maybe-root parent))))
;;(root-path (remove :root-object-object (the root-path))) ;;(root-path (remove :root-object-object (the root-path)))
(root-path (the root-path)) (root-path (the root-path))
) )
;; ;;
;; FLAG -- this pushnew should never be necessary... ;; FLAG -- this pushnew should never be necessary...
;; ;;
(pushnew (list root-path) (pushnew (list root-path)
(gdl-acc::%version-tree% root) :test #'equalp :key #'(lambda(item) (list (first item)))) (gdl-acc::%version-tree% root) :test #'equalp :key #'(lambda(item) (list (first item))))
(setf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp)) (setf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp))
(remove-plist-key (rest (assoc root-path (remove-plist-key (rest (assoc root-path
(gdl-acc::%version-tree% root) :test #'equalp)) attribute)) (gdl-acc::%version-tree% root) :test #'equalp)) attribute))
(setf (gdl-acc::%version-tree% root) (setf (gdl-acc::%version-tree% root)
(double-length-sort (gdl-acc::%version-tree% root)))) (double-length-sort (gdl-acc::%version-tree% root))))
(when *eager-setting-enabled?* (when *eager-setting-enabled?*
(dolist (reset *leaf-resets*) (dolist (reset *leaf-resets*)
(the-object (first reset) (evaluate (second reset)))))))) (the-object (first reset) (evaluate (second reset))))))))
;; ;;
;; FLAG -- remove this defunct version. ;; FLAG -- remove this defunct version.
...@@ -1267,7 +1267,8 @@ a separate object hierarchy." object self))) ...@@ -1267,7 +1267,8 @@ a separate object hierarchy." object self)))
(if (third slot-value) (if (third slot-value)
(setf (second (slot-value object slot)) nil) (setf (second (slot-value object slot)) nil)
(setf (slot-value object slot) (setf (slot-value object slot)
(if (or updating? (not *remember-previous-slot-values?*)) (if (and (not (the-object object remember-children?))
(or updating? (not *remember-previous-slot-values?*)))
'gdl-rule::%unbound% 'gdl-rule::%unbound%
(list 'gdl-rule::%unbound% nil nil (first (slot-value object slot)))))))) (list 'gdl-rule::%unbound% nil nil (first (slot-value object slot))))))))
(when (and (find-class 'gdl-remote nil) (typep object 'gdl-remote)) (when (and (find-class 'gdl-remote nil) (typep object 'gdl-remote))
......
...@@ -213,7 +213,7 @@ to the src/ directory distributed with GDL. ...@@ -213,7 +213,7 @@ to the src/ directory distributed with GDL.
:objects :objects
((base :type 'robot-base ((base :type 'robot-base
:display-controls (merge-display-controls (list :color :blue-sky)) :display-controls (merge-display-controls (list :color :orange))
:height (* (the height) 0.4) :height (* (the height) 0.4)
:width (* (the width) 0.2) :width (* (the width) 0.2)
:length (* (the length) 0.2) :length (* (the length) 0.2)
......
...@@ -67,7 +67,7 @@ makes sense for viewing it." ...@@ -67,7 +67,7 @@ makes sense for viewing it."
:input-slots :input-slots
( (
(empty-display-list-message nil)
;;(touched-geometry nil) ;;(touched-geometry nil)
(width (the page-width)) (width (the page-width))
......
...@@ -27,6 +27,7 @@ ...@@ -27,6 +27,7 @@
(local-object-boxes (remove nil (mapcar #'(lambda(object) (when (typep object 'base-object) (local-object-boxes (remove nil (mapcar #'(lambda(object) (when (typep object 'base-object)
(the-object object local-box))) (the-object object local-box)))
local-objects)))) local-objects))))
(let (xmin ymin zmin xmax ymax zmax) (let (xmin ymin zmin xmax ymax zmax)
(mapcar #'(lambda(box) (mapcar #'(lambda(box)
(let ((min (first box)) (max (second box))) (let ((min (first box)) (max (second box)))
......
...@@ -36,6 +36,8 @@ Raphael vector graphics." ...@@ -36,6 +36,8 @@ Raphael vector graphics."
:input-slots :input-slots
((respondent (the bashee) :defaulting) ((respondent (the bashee) :defaulting)
(empty-display-list-message nil)
("Number. Thickness of default border around graphics viewport. ("Number. Thickness of default border around graphics viewport.
Default is 1." viewport-border-default 1) Default is 1." viewport-border-default 1)
...@@ -153,13 +155,16 @@ value of the image-format-selector, which itself defaults to :raphael." ...@@ -153,13 +155,16 @@ value of the image-format-selector, which itself defaults to :raphael."
(write-the view-object cad-output)))))) (write-the view-object cad-output))))))
(svg-string (unless (the no-graphics?) (svg-string (if (the no-graphics?)
(with-error-handling () (with-cl-who-string ()
(with-output-to-string (ss) ((:div :id "empty-viewport" :class "empty-viewport")
(with-format (svg ss (:p (:h2 (str (the empty-display-list-message))))))
:background-color (the background-color) (with-error-handling ()
:foreground-color (the foreground-color)) (with-output-to-string (ss)
(write-the view-object cad-output)))))) (with-format (svg ss
:background-color (the background-color)
:foreground-color (the foreground-color))
(write-the view-object cad-output))))))
("String of valid HTML. This can be used to ("String of valid HTML. This can be used to
...@@ -259,6 +264,7 @@ x3draw(); ...@@ -259,6 +264,7 @@ x3draw();
zoom-factor-renderer) zoom-factor-renderer)
:page-length (the length) :page-length (the length)
:page-width (the width) :page-width (the width)
:empty-display-list-message (the empty-display-list-message)
:objects (the display-list-objects) :objects (the display-list-objects)
:object-roots (the display-list-object-roots)) :object-roots (the display-list-object-roots))
...@@ -448,28 +454,13 @@ to call the :write-embedded-x3d-world function.")) ...@@ -448,28 +454,13 @@ to call the :write-embedded-x3d-world function."))
) )
(:|Scene| (:|Scene|
((:|navigationinfo| :|id| "navi" :|transitionTime| "0.1")) ((:|navigationinfo| :|id| "navi" :|transitionTime| "0.0"
))
(with-format (x3d *stream*) (with-format (x3d *stream*)
(let ((*onclick-function* (the onclick-function))) (let ((*onclick-function* (the onclick-function)))
(write-the view-object cad-output)))))) (write-the view-object cad-output))))))))))))
((:script :type "text/javascript")
;;"x3draw();"
#+nil
(fmt
"
x3dom.reload();
// document.getElementById('view-~(~a~)').setAttribute('set_bind', 'true');
// xruntime = document.getElementById('x3dom-1').runtime;
//xruntime.resetView();
"
(the view-selector value)
)
)))))))
(raster-graphics (raster-graphics
......
...@@ -131,7 +131,7 @@ application-mixin, you can include one object of this type in the ui-display-lis ...@@ -131,7 +131,7 @@ application-mixin, you can include one object of this type in the ui-display-lis
from the base-ajax-graphics-sheet and based on its root-path, but can be specified manually from the base-ajax-graphics-sheet and based on its root-path, but can be specified manually
if you are making a web-drawing on your own. Defaults (in the standalone case) to \"RaphaelCanvas\"" if you are making a web-drawing on your own. Defaults (in the standalone case) to \"RaphaelCanvas\""
raphael-canvas-id "RaphaelCanvas") raphael-canvas-id "RaphaelCanvas")
("3D vector. This is the normal vector of the view plane onto which to project the 3D objects. Defaults to (getf *standard-views* :top)." ("3D vector. This is the normal vector of the view plane onto which to project the 3D objects. Defaults to (getf *standard-views* :top)."
projection-vector (getf *standard-views* :top)) projection-vector (getf *standard-views* :top))
......
...@@ -36,18 +36,18 @@ ...@@ -36,18 +36,18 @@
(when parent-scale (the-object child-view (set-slot! :user-scale parent-scale))) (when parent-scale (the-object child-view (set-slot! :user-scale parent-scale)))
(let ((width (the-object child-view width)) (let ((width (the-object child-view width))
(length (the-object child-view length))) (length (the-object child-view length)))
(with-html-output (*stream*) (with-html-output (*stream*)
((:div ((:div
:onmousedown (when (the parent vector-graphics-onclick?) :onmousedown (when (the parent vector-graphics-onclick?)
(the parent (gdl-ajax-call :function-key :dig-point :bashee (the parent) (the parent (gdl-ajax-call :function-key :dig-point :bashee (the parent)
:respondent (the parent :respondent))))) :respondent (the parent :respondent)))))
((:svg :id "svg-1" :viewBox (format nil "0 0 ~a ~a" width length) :width width :height length
) ((:svg :id "svg-1" :viewBox (format nil "0 0 ~a ~a" width length) :width width :height length)
(with-translated-state (:svg (make-point (- (get-x view-center)) (with-translated-state (:svg (make-point (- (get-x view-center))
(- (get-y view-center)))) (- (get-y view-center))))
(write-the-object child-view cad-output))) (write-the-object child-view cad-output)))
((:script :type "text/javascript") ((:script :type "text/javascript")
" "
var panZoomSVG1 = svgPanZoom('#svg-1', { var panZoomSVG1 = svgPanZoom('#svg-1', {
...@@ -58,6 +58,7 @@ ...@@ -58,6 +58,7 @@
minZoom: 0.01, minZoom: 0.01,
maxZoom: 100, maxZoom: 100,
center: true});")))) center: true});"))))
(when parent-scale (the-object child-view (set-slot! :user-scale old-scale))))) (when parent-scale (the-object child-view (set-slot! :user-scale old-scale)))))
(the views)))))))) (the views))))))))
......
...@@ -155,10 +155,13 @@ ...@@ -155,10 +155,13 @@
(when (and respondent (the-object respondent root) (when (and respondent (the-object respondent root)
(typep (the-object respondent root) 'session-control-mixin)) (typep (the-object respondent root) 'session-control-mixin))
(the-object respondent root (set-expires-at))) (the-object respondent root (set-expires-at)))
(when (and respondent (the-object respondent root) (when (and respondent (the-object respondent root)
(the-object respondent root (set-time-last-touched!)))) (typep (the-object respondent root) 'session-control-mixin))
(the-object respondent root (set-time-last-touched!)))
#+nil ;; FLAG -- add this back when cleaning up remote-objects.
(when (and respondent (the-object respondent root) (when (and respondent (the-object respondent root)
(the-object respondent root (set-remote-host! req)))) (the-object respondent root (set-remote-host! req))))
...@@ -248,11 +251,9 @@ ...@@ -248,11 +251,9 @@
(:document (:document
(mapc #'(lambda(replace-pair js-to-eval-status) (mapc #'(lambda(replace-pair js-to-eval-status)
(declare (ignore js-to-eval-status)) ;; this can play into the flag (declare (ignore js-to-eval-status)) ;; this can play into the flag
(print-variables (base64-decode-safe (getf replace-pair :dom-id))) (when *debug?* (print-variables (base64-decode-safe (getf replace-pair :dom-id))))
(destructuring-bind (&key dom-id inner-html js-to-eval) replace-pair (destructuring-bind (&key dom-id inner-html js-to-eval) replace-pair
(let ((js-to-eval? (and js-to-eval (not (string-equal js-to-eval ""))))) (let ((js-to-eval? (and js-to-eval (not (string-equal js-to-eval "")))))
(when (or inner-html js-to-eval?) (when (or inner-html js-to-eval?)
...@@ -305,6 +306,7 @@ You can reload to get previous state" *ajax-timeout*)) ...@@ -305,6 +306,7 @@ You can reload to get previous state" *ajax-timeout*))
(progn (progn
(when *debug?* (print-variables (the stale?) (the section root-path))) (when *debug?* (print-variables (the stale?) (the section root-path)))
;;(print-variables (the section root-path))
(when t ;; (the stale?) ;; already filtering for stale? before calling now. (when t ;; (the stale?) ;; already filtering for stale? before calling now.
(list :dom-id (the dom-id) (list :dom-id (the dom-id)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment