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
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)
:%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,7 +28,9 @@
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.")
:input-slots
((remember-children? nil))
:computed-slots
((index nil)
......
......@@ -36,7 +36,7 @@ toplevel of the define-object form.")
:input-slots
(
(remote-id nil :settable)
(quantify-box (or (the parent) self))
......@@ -99,7 +99,7 @@ nil "~a~a~a" (the :name-for-display)
:computed-slots
(
((remember-children? nil)
(%corners% nil)
(%vertex-array% nil)
......@@ -388,41 +388,41 @@ or all mixins from the entire inheritance hierarchy.\")"
:arguments (slot \"Keyword Symbol\")
: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.\")"
restore-slot-default!
(attribute &key (force? *force-restore-slot-default?*))
(when (or force? (eql (the (slot-status attribute)) :set))
(let (*leaf-resets*)
(let ((slot (glisp:intern (symbol-name attribute) :gdl-acc)))
(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?*
(list 'gdl-rule::%unbound% nil nil (first (slot-value self slot)))
'gdl-rule::%unbound%))))
(let ((root (let ((maybe-root (the :root)))
(if (the-object maybe-root root?)
maybe-root
(the-object maybe-root parent))))
restore-slot-default!
(attribute &key (force? *force-restore-slot-default?*))
(when (or force? (eql (the (slot-status attribute)) :set))
(let (*leaf-resets*)
(let ((slot (glisp:intern (symbol-name attribute) :gdl-acc)))
(unless (eq (first (ensure-list (slot-value self slot))) 'gdl-rule::%unbound%)
(unbind-dependent-slots self slot)
(setf (slot-value self slot)
(if (or *remember-previous-slot-values?* (the remember-children?))
(list 'gdl-rule::%unbound% nil nil (first (slot-value self slot)))
'gdl-rule::%unbound%))))
(let ((root (let ((maybe-root (the :root)))
(if (the-object maybe-root root?)
maybe-root
(the-object maybe-root parent))))
;;(root-path (remove :root-object-object (the root-path)))
(root-path (the root-path))
;;(root-path (remove :root-object-object (the root-path)))
(root-path (the root-path))
)
;;
;; FLAG -- this pushnew should never be necessary...
;;
(pushnew (list root-path)
(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))
(remove-plist-key (rest (assoc root-path
(gdl-acc::%version-tree% root) :test #'equalp)) attribute))
(setf (gdl-acc::%version-tree% root)
(double-length-sort (gdl-acc::%version-tree% root))))
(when *eager-setting-enabled?*
(dolist (reset *leaf-resets*)
(the-object (first reset) (evaluate (second reset))))))))
)
;;
;; FLAG -- this pushnew should never be necessary...
;;
(pushnew (list root-path)
(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))
(remove-plist-key (rest (assoc root-path
(gdl-acc::%version-tree% root) :test #'equalp)) attribute))
(setf (gdl-acc::%version-tree% root)
(double-length-sort (gdl-acc::%version-tree% root))))
(when *eager-setting-enabled?*
(dolist (reset *leaf-resets*)
(the-object (first reset) (evaluate (second reset))))))))
;;
;; FLAG -- remove this defunct version.
......@@ -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?*)))
'gdl-rule::%unbound%
(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.
:objects
((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."
:input-slots
(
(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)))
local-objects))))
(let (xmin ymin zmin xmax ymax zmax)
(mapcar #'(lambda(box)
(let ((min (first box)) (max (second box)))
......
......@@ -36,6 +36,8 @@ Raphael vector graphics."
:input-slots
((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,13 +155,16 @@ value of the image-format-selector, which itself defaults to :raphael."
(write-the view-object cad-output))))))
(svg-string (unless (the no-graphics?)
(with-error-handling ()
(with-output-to-string (ss)
(with-format (svg ss
:background-color (the background-color)
:foreground-color (the foreground-color))
(write-the view-object cad-output))))))
(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
: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
......@@ -259,6 +264,7 @@ x3draw();
zoom-factor-renderer)
: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."))
)
(:|Scene|
((:|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")
;;"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)
)
)))))))
(write-the view-object cad-output))))))))))))
(raster-graphics
......
......@@ -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
if you are making a web-drawing on your own. Defaults (in the standalone case) to \"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)."
projection-vector (getf *standard-views* :top))
......
......@@ -36,18 +36,18 @@
(when parent-scale (the-object child-view (set-slot! :user-scale parent-scale)))
(let ((width (the-object child-view width))
(length (the-object child-view length)))
(with-html-output (*stream*)
((:div
: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
)
(with-translated-state (:svg (make-point (- (get-x view-center))
(- (get-y view-center))))
(write-the-object child-view cad-output)))
((: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))))
(write-the-object child-view cad-output)))
((:script :type "text/javascript")
"
var panZoomSVG1 = svgPanZoom('#svg-1', {
......@@ -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))))))))
......
......@@ -155,10 +155,13 @@
(when (and respondent (the-object respondent root)
(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!))))
(when (and respondent (the-object respondent root)
(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 @@
(:document
(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*))
(progn
(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