Commit 003eb0a5 authored by Dave Cooper's avatar Dave Cooper

Merge branch 'hotfix/update-gdl'

parents d3608cf9 9a201cea
(in-package :gdl)
(defparameter *1588p010-doc*
" Correct snap output for objects not made with root-object-object.")
#-allegro progn
(define-object-amendment vanilla-mixin* ()
(("Void. Writes a file containing the toplevel inputs and modified settable-slots starting from the root of the
current instance. Typically this file can be read back into the system using the <tt>read-snapshot</tt> function.
:&key ((filename \"/tmp/snap.gdl\") \"String or pathname. The target file to be written.\"
(root-paths-to-ignore nil) \"List of root-paths or nil. Any objects with matching root-path will be ignored for the snapshot write.\"
(&key (filename "/tmp/snap.gdl") (root-paths-to-ignore nil))
(let (*print-level*
(root-object-object? (and (the parent) (the parent root?)
(defaulting (the parent root-object-object))
(eql (the parent root-object-object) self))))
(let ((root (if root-object-object? (the root parent) (the root))))
(setf (gdl-acc::%version-tree% root)
(sort (gdl-acc::%version-tree% root)
#'(lambda(item1 item2)
(< (length (first item1)) (length (first item2))))))
(with-open-file (out filename :direction :output :if-exists :supersede :if-does-not-exist :create)
(print `(in-package ,(make-keyword (package-name *package*))) out)
(mapcar #'(lambda(node)
(let ((root-path (first node)) (value-plist (rest node)))
(unless (or (member root-path root-paths-to-ignore :test #'equalp)
(and root-object-object?
(not (eql (lastcar root-path) :root-object-object))))
(when (or (and root-object-object? (null (rest root-path)))
(and (not root-object-object?) (null root-path)))
(setq root-path (the type)))
(when (and root-object-object? (consp (rest root-path)))
(setq root-path (butlast root-path)))
(setq root-path (if (consp (rest root-path))
(if root-object-object? (butlast root-path) root-path)
(the type)))
(let ((keys (plist-keys value-plist)) (values (plist-values value-plist)))
(let ((snap (cons root-path
(append (when (atom root-path)
(let (result)
(let* ((toplevel-inputs
(remove-plist-key (the root active-inputs)
(toplevel-input-keys (plist-keys toplevel-inputs))
(toplevel-input-values (plist-values toplevel-inputs)))
(mapc #'(lambda(key value)
(when (not (member key keys))
(push key result) (push value result)))
toplevel-input-keys toplevel-input-values))
(nreverse result)))
(mapcan #'(lambda(key val)
(let ((expression (readable-expression val self)))
(unless (eql expression :%unreadable%)
(list key expression))))
keys values))))) (print snap out))))))
(or (gdl-acc::%version-tree% root) (list nil))))))
;; Copyright 2002-2015 Genworks International
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; Affero General Public License for more details.
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <>.
(in-package :geom-base)
(defparameter *1588p011-doc*
" Remove debug statements for x3d outpu9t")
#-allegro progn
(define-lens (x3d base-object) ()
:amend? t
(let* ((display-controls (find-in-hash self *display-controls*))
(color (getf display-controls :color))
(color (or color (getf (the display-controls) :color) :black)))
(cl-who:with-html-output (*stream* nil :indent nil)
(:|Material| :|diffuseColor| (write-the (rgb-color color))
:|ambientIntensity| (getf (the display-controls) :ambient-intensity)
:|emissiveColor| (write-the (rgb-color (getf (the display-controls) :emissive-color)))
:|shininess| (getf (the display-controls) :shininess)
:|specularColor| (write-the (rgb-color (getf (the display-controls) :specular-color)))
:|transparency| (getf (the display-controls) :transparency)
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