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."
(defun make-standard-slots ()
`((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::%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)
......@@ -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 \"spliced-in plist. A plist of keyword symbols and values for initial <tt>input-slots</tt>.\")"
(let (*notify-cons*
(keys (plist-keys args))
(vals (plist-values args)))
(let ((object (apply #'make-instance
: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)
:%parent% (list nil nil t))
:%parent% (list nil nil t)
:%god-parents% (getf args :god-parents))
(mapcan #'(lambda(key val)
(list key (list val nil t)))
(unless (eql key :god-parents)
(list key (list val nil t))))
keys vals)))))
(setf (gdl-acc::%root% object) object
......@@ -28,6 +28,8 @@
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
internal. It can be used, and returns an integer representing the cardinality of the aggregate.")
((remember-children? nil))
((index nil)
......@@ -99,7 +99,7 @@ nil "~a~a~a" (the :name-for-display)
((remember-children? nil)
(%corners% nil)
(%vertex-array% nil)
......@@ -396,7 +396,7 @@ reading from databases or external files). Defaults to nil.\")"
(unless (eq (first (ensure-list (slot-value self slot))) 'gdl-rule::%unbound%)
(unbind-dependent-slots 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)))
(let ((root (let ((maybe-root (the :root)))
......@@ -1267,7 +1267,8 @@ a separate object hierarchy." object self)))
(if (third slot-value)
(setf (second (slot-value object slot)) nil)
(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?*)))
(list 'gdl-rule::%unbound% nil nil (first (slot-value object slot))))))))
(when (and (find-class 'gdl-remote nil) (typep object 'gdl-remote))
......@@ -213,7 +213,7 @@ to the src/ directory distributed with GDL.
((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)
:width (* (the width) 0.2)
:length (* (the length) 0.2)
......@@ -67,7 +67,7 @@ makes sense for viewing it."
(empty-display-list-message nil)
;;(touched-geometry nil)
(width (the page-width))
......@@ -27,6 +27,7 @@
(local-object-boxes (remove nil (mapcar #'(lambda(object) (when (typep object 'base-object)
(the-object object local-box)))
(let (xmin ymin zmin xmax ymax zmax)
(mapcar #'(lambda(box)
(let ((min (first box)) (max (second box)))
......@@ -36,6 +36,8 @@ Raphael vector graphics."
((respondent (the bashee) :defaulting)
(empty-display-list-message nil)
("Number. Thickness of default border around graphics viewport.
Default is 1." viewport-border-default 1)
......@@ -153,7 +155,10 @@ value of the image-format-selector, which itself defaults to :raphael."
(write-the view-object cad-output))))))
(svg-string (unless (the no-graphics?)
(svg-string (if (the no-graphics?)
(with-cl-who-string ()
((:div :id "empty-viewport" :class "empty-viewport")
(:p (:h2 (str (the empty-display-list-message))))))
(with-error-handling ()
(with-output-to-string (ss)
(with-format (svg ss
......@@ -259,6 +264,7 @@ x3draw();
:page-length (the length)
:page-width (the width)
:empty-display-list-message (the empty-display-list-message)
:objects (the display-list-objects)
:object-roots (the display-list-object-roots))
......@@ -448,28 +454,13 @@ to call the :write-embedded-x3d-world function."))
((:|navigationinfo| :|id| "navi" :|transitionTime| "0.1"))
((:|navigationinfo| :|id| "navi" :|transitionTime| "0.0"
(with-format (x3d *stream*)
(let ((*onclick-function* (the onclick-function)))
(write-the view-object cad-output))))))
((:script :type "text/javascript")
// document.getElementById('view-~(~a~)').setAttribute('set_bind', 'true');
// xruntime = document.getElementById('x3dom-1').runtime;
(the view-selector value)
(write-the view-object cad-output))))))))))))
......@@ -42,8 +42,8 @@
:onmousedown (when (the parent vector-graphics-onclick?)
(the parent (gdl-ajax-call :function-key :dig-point :bashee (the parent)
: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))
(- (get-y view-center))))
......@@ -58,6 +58,7 @@
minZoom: 0.01,
maxZoom: 100,
center: true});"))))
(when parent-scale (the-object child-view (set-slot! :user-scale old-scale)))))
(the views))))))))
......@@ -156,9 +156,12 @@
(typep (the-object respondent root) 'session-control-mixin))
(the-object respondent root (set-expires-at)))
(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)
(the-object respondent root (set-remote-host! req))))
......@@ -248,11 +251,9 @@
(mapc #'(lambda(replace-pair js-to-eval-status)
(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
(let ((js-to-eval? (and js-to-eval (not (string-equal js-to-eval "")))))
(when (or inner-html js-to-eval?)
......@@ -305,6 +306,7 @@ You can reload to get previous state" *ajax-timeout*))
(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.
(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