diff --git a/base/macros/source/define-object.lisp b/base/macros/source/define-object.lisp index 3d23a8606de14faaabdc1d5406bf829b8a534a52..b3f02b0097967e444c75f9a7b20336c8afe0e4c4 100755 --- a/base/macros/source/define-object.lisp +++ b/base/macros/source/define-object.lisp @@ -750,7 +750,8 @@ overview of define-object 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) diff --git a/base/rest/source/make-part.lisp b/base/rest/source/make-part.lisp index 304962a84a6a11cbacbb1074996c6a2881ec42af..d571bcd92e4451c48e9d37619966c0085d221cfa 100755 --- a/base/rest/source/make-part.lisp +++ b/base/rest/source/make-part.lisp @@ -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 input-slots.\")" + + (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 diff --git a/base/rest/source/quantification.lisp b/base/rest/source/quantification.lisp index 40dc8470cf9e374aab9eec9873fcfc4ab4fa97b4..762e85abdcffc9dccb00af0669e809aea98bf067 100755 --- a/base/rest/source/quantification.lisp +++ b/base/rest/source/quantification.lisp @@ -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, number-of-elements, 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) diff --git a/base/rest/source/vanilla-mixin.lisp b/base/rest/source/vanilla-mixin.lisp index 55f86eb3a0b3c2a17fc4bc9630d3d1f1856aae4c..d2444400214528150ee1b4bd61b69407f6b4e030 100644 --- a/base/rest/source/vanilla-mixin.lisp +++ b/base/rest/source/vanilla-mixin.lisp @@ -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)) diff --git a/demos/robot/source/assembly.lisp b/demos/robot/source/assembly.lisp index c644c69cf923ac2d21c5a6e212d5e529efa446cc..731667bca8434540459adc1b8b9768832496b69f 100755 --- a/demos/robot/source/assembly.lisp +++ b/demos/robot/source/assembly.lisp @@ -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) diff --git a/geom-base/drawing/source/base-view.lisp b/geom-base/drawing/source/base-view.lisp index 3aeb0c5f07066be90f5f399dcb2b574c95707b9a..746c579b2de4eb5d5440ce5f6161dcdb31402c74 100755 --- a/geom-base/drawing/source/base-view.lisp +++ b/geom-base/drawing/source/base-view.lisp @@ -67,7 +67,7 @@ makes sense for viewing it." :input-slots ( - + (empty-display-list-message nil) ;;(touched-geometry nil) (width (the page-width)) diff --git a/geom-base/wire/source/utilities.lisp b/geom-base/wire/source/utilities.lisp index 273f5ac3f212b7e8203273186725cd992680c790..23c0639b6991a11de234de444f302a94ffb9e7fb 100644 --- a/geom-base/wire/source/utilities.lisp +++ b/geom-base/wire/source/utilities.lisp @@ -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))) diff --git a/gwl-graphics/gwl/source/base-ajax-graphics-sheet.lisp b/gwl-graphics/gwl/source/base-ajax-graphics-sheet.lisp index 4658f9dd7c25db5214788829d788d3f07c4dc979..3bd5e01369e2f281c86144234b7c34be62150e31 100755 --- a/gwl-graphics/gwl/source/base-ajax-graphics-sheet.lisp +++ b/gwl-graphics/gwl/source/base-ajax-graphics-sheet.lisp @@ -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 diff --git a/gwl-graphics/gwl/source/web-drawing.lisp b/gwl-graphics/gwl/source/web-drawing.lisp index 45b16a706ccfb7d7f09602a0716de5e300bb7833..0ee66698a2a887fc8a2a5f4cd1ea5aa7b5e40268 100755 --- a/gwl-graphics/gwl/source/web-drawing.lisp +++ b/gwl-graphics/gwl/source/web-drawing.lisp @@ -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)) diff --git a/gwl-graphics/svg/source/lenses.lisp b/gwl-graphics/svg/source/lenses.lisp index c43741b33ad00be5cb0a2cf217f1178971d185f7..788c393b4e63ca8be73d6870113ce21da009f2c3 100755 --- a/gwl-graphics/svg/source/lenses.lisp +++ b/gwl-graphics/svg/source/lenses.lisp @@ -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)))))))) diff --git a/gwl/ajax/source/ajax.lisp b/gwl/ajax/source/ajax.lisp index 06123ac1ccf2c87b1162e5090887d2e7d62f027c..90ad322fd59a2103d27faff7b92fbfc0c32e545f 100644 --- a/gwl/ajax/source/ajax.lisp +++ b/gwl/ajax/source/ajax.lisp @@ -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)