Commit a80b37d9 authored by Dave Cooper's avatar Dave Cooper
Browse files

merged 1588 patches from the year

parent 1ec05ea0
......@@ -69,7 +69,35 @@ The argument ~s, and its value ~s, have been ignored
(defun make-object (object-type &rest args)
"GDL Object. Instantiates an object with specified initial values for input-slots.
: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
(append (list :%name% (list (format nil "~a" object-type) nil t)
:%parent% (list nil nil t))
(mapcan #'(lambda(key val)
(list key (list val nil t)))
keys vals)))))
(setf (gdl-acc::%root% object) object
(gdl-acc::%toplevel-inputs% object) args)
(the-object object initialize-instance!) object)))
;;
;; FLAG -- remove this defunct version.
;;
#+nil
(defun make-object (object-type &rest args)
"GDL Object. Instantiates an object with specified initial values for input-slots.
......@@ -90,6 +118,12 @@ The argument ~s, and its value ~s, have been ignored
(setf (gdl-acc::%root% object) object
(gdl-acc::%toplevel-inputs% object) args) object)))
(defun make-object-internal (object-type &rest args)
(let ((object (apply #'make-instance object-type :allow-other-keys t args)))
(the-object object initialize-instance!) object))
#+nil
(defun make-object-internal (object-type &rest args)
(apply #'make-instance object-type :allow-other-keys t args))
......
......@@ -238,7 +238,7 @@ re-evaluates the expression to compute the original list of indices)"
delete!
(index)
(bt:with-lock-held ((the lock))
(the (:set-slot! :ht (the :ht)))
(the (:set-slot! :ht (the :ht) :remember? nil))
(remhash index (the ht))
(the (:modify-attribute! :element-index-list
(remove index (the :element-index-list))))))
......@@ -258,7 +258,7 @@ re-evaluates the expression to compute the original list of indices)"
(if (not found?)
(bt:with-lock-held ((the lock))
(setf (gethash index (the ht)) nil)
(the (set-slot! :ht (the ht)))
(the (set-slot! :ht (the ht) :remember? nil))
(the (set-slot! :element-index-list
(append (the element-index-list) (list index)))))
(error "The element ~a is already active in ~s" index self))))))
......
......@@ -612,6 +612,17 @@ CL \"fround\" function.
(truncate (* (second color) 255))
(truncate (* (third color) 255))) t)))))
;;
;; FLAG -- remove this defunct version.
;;
#+nil
(defmethod lookup-color ((color null) &key (format :decimal) (ground :foreground))
(unless (and (eql ground :foreground)
(eql (getf *colors-default* :foreground) :black))
(values (lookup-color (getf *colors-default* ground) :format format) nil)))
(defmethod lookup-color ((color null) &key (format :decimal) (ground :foreground))
(values (lookup-color (getf *colors-default* ground) :format format) nil))
......@@ -696,6 +707,81 @@ an iso-8601 date, optionally with time, e.g. 2012-07-08 or 2012-07-08T13:33 or 2
(apply #'make-object (the-object object type) make-object-args))
(defun read-snapshot (&key (filename "/tmp/snap.gdl") object keep-bashed-values? make-object-args
keys-to-ignore
(keys-to-ignore-default (list :query-plist :view-toggle :cookies-received)))
"GDL Instance. Reads the snapshot file indicated by filename. If no optional keyword <tt>object</tt>
argument is given, a new GDL instance based on the data in the snapshot file is returned. If an
<tt>object</tt> is given, the object should be compatible in type to that specified in the
snapshot file, and this existing object will be modified to contain the set slot values and
toplevel inputs as specified in the snapshot file.
:&key ((filename \"/tmp/snap.gdl\") \"String or pathname. File to be read.\"
(keep-bashed-values? nil) \"Boolean. Indicates whether to keep the currently bashed values in object before reading snap values into it.\"
(object nil) \"GDL object. Existing object to be modified with restored values.\")"
(let ((keys-to-ignore (append keys-to-ignore keys-to-ignore-default)))
(with-open-file (in filename)
(let ((package-form (read in)))
(when (or (null package-form) (not (find-package (second package-form))))
(error "Invalid package specification at beginning of ~a.~%" filename))
(let* ((*package* (find-package (second package-form))) (root-form (read in)))
(when (or (null root-form)
(not (eql (class-of (find-class (first root-form))) (find-class 'gdl-class))))
(error "Invalid object type specifier as first element of second form in ~a.~%" root-form))
(let* ((object (cond ((and object keep-bashed-values?) object)
(object (the-object object restore-tree!) object)
(t (progn
(apply #'make-object (first root-form) make-object-args))))))
(let ((self object) (value-plist (rest root-form)))
(mapc #'(lambda(key expression)
(unless (member key keys-to-ignore)
(when self (the-object self (set-slot! key (eval expression) :re-sort? nil)))))
(plist-keys value-plist) (plist-values value-plist)))
(let (forms)
(do ((form (read in nil nil) (read in nil nil)))
((null form) forms)
(push form forms))
(setq forms (nreverse forms))
(let* ((forms (double-length-sort forms))
(primaries (remove-if-not #'(lambda(item) (or (getf (rest item) :%primary?%)
(getf (rest item) :element-index-list))) forms))
(non-primaries (remove-if #'(lambda(item) (or (getf (rest item) :%primary?%)
(getf (rest item) :element-index-list))) forms))
(forms (append primaries non-primaries)))
(dolist (form forms)
(let ((root-path (first form)) (value-plist (rest form)))
(let ((self
(with-error-handling (:timeout nil)
(the-object object (follow-root-path root-path)))))
(when self
(mapc #'(lambda(key expression)
(unless (member key keys-to-ignore)
(the-object self (set-slot! key (eval `(let ((self ,self)) ,expression)) :re-sort? nil))))
(plist-keys value-plist) (plist-values value-plist))))))))
object))))))
;;
;; FLAG -- remove this defunction version.
;;
#+nil
(defun read-snapshot (&key (filename "/tmp/snap.gdl") object keep-bashed-values? make-object-args keys-to-ignore)
"GDL Instance. Reads the snapshot file indicated by filename. If no optional keyword <tt>object</tt>
argument is given, a new GDL instance based on the data in the snapshot file is returned. If an
......@@ -819,8 +905,6 @@ toplevel inputs as specified in the snapshot file.
(defparameter *invalid-aggregate-behavior* :error)
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '*invalid-aggregate-behavior* :gdl))
(defun add-notify-cons (notify-cons value &optional self message)
;;
......@@ -939,3 +1023,14 @@ toplevel inputs as specified in the snapshot file.
(defun double-length-sort (&optional (list))
(let ((first (safe-sort list #'(lambda(item1 item2)
(let ((first1 (first (first item1)))
(first2 (first (first item2))))
(< (if (consp first1) (length first1) 0)
(if (consp first2) (length first2) 0)))))))
(stable-sort first #'(lambda(x y) (< (length (first x)) (length (first y)))))))
This diff is collapsed.
......@@ -157,6 +157,8 @@ If you are interested in this effort we would love to hear from you at open-sour
#:distribute
#:distribute-dir
#:div
#:dumplisp
#:dump-image
#:encode-for-http
#:ensure-list
#:evaluate
......@@ -238,6 +240,7 @@ If you are interested in this effort we would love to hear from you at open-sour
#:remove-plist-keys
#:replace-substring
#:restore-ui-object
#:reset-glm
#:retitle-emacs
#:retrieve
#:rgb-cube-colors
......@@ -292,7 +295,9 @@ If you are interested in this effort we would love to hear from you at open-sour
#:*loaded-hotpatches*
#:*packages-to-lock*
#:*patch-url-base*
#:*warn-on-invalid-toplevel-inputs?))
#:*warn-on-invalid-toplevel-inputs?
#:*invalid-aggregate-behavior*
))
#-(or allegro lispworks sbcl ccl abcl ecl clisp) (error "Need package for mop:validate-superclass for currently running lisp.~%")
......@@ -366,6 +371,7 @@ If you are interested in this effort we would love to hear from you at open-sour
#:file-directory-p
#:run-command
#:temporary-folder
#:*temporary-folder-function*
#:temporary-file
#:find-gs-path
......@@ -971,3 +977,5 @@ If you are interested in this effort we would love to hear from you at open-sour
(gdl:define-package :enterprise (:export #:gdl-app #:make-gdl-app #:*newspace* #:*oldspace*))
(gdl:define-package :glm (:export #:assembly))
......@@ -22,7 +22,7 @@
(in-package :gdl)
(defparameter *gendl-version* "1590devo")
(defparameter *gendl-version* "1590devo001")
(defparameter *gendl-patch-level* nil)
......
......@@ -2,21 +2,23 @@
Welcome to the Genworks® GDL and Gendl® Environment
===========================
GDL1588
===========================
================================================
GDL1590-devo (nightly pre-release build)
================================================
Release Schedule
================
2015-01-15: GDL1588 release
2016-01-15: GDL1590 release
2016-01-15: The next major GDL release will be made available (number
2016-12-15: GDL1588 will be sunsetted.
2017-01-15: The next major GDL release will be made available (number
TBD).
2017-01-14: Support for GDL1588 will be sunsetted.
2017-12-15: Support for GDL1590 will be sunsetted.
----------------------------------------------------------------------
......@@ -49,7 +51,7 @@ Updating
The function (update-gdl) will pull down a bootstrap file which knows
how to fetch and install the currently available patches for this
version of GDL.
version of GDL. (Note: this is not yet functional in this release).
Documentation
......@@ -60,8 +62,6 @@ Documentation
http://genworks.com/downloads/tutorial.pdf
==================
Authoring GDL Code
==================
......
......@@ -205,9 +205,9 @@
(when (find-package :gendl) (funcall (symbol-function (read-from-string \"gendl::startup-banner\"))))
(let ((gendl-loaded? (find-package :gendl)) (genworks-gdl-loaded? (find-package :genworks-gdl)))
(cond (genworks-gdl-loaded? (funcall (symbol-function (read-from-string \"gdl:start-gdl!\"))))
;;(gendl-loaded? (funcall (symbol-function (read-from-string \"gendl:start-gendl!\"))))
;;(t (format t \"~%%~%%***~%%Gendl or GDL is not loaded and did not load successfully from .load-gendl.lisp in your home directory.~%%***~%%~%%\"))
))
(gendl-loaded? (funcall (symbol-function (read-from-string \"gendl:start-gendl!\"))))
(t (format t \"~%%~%%***~%%Gendl or GDL is not loaded and did not load successfully
from .load-gendl.lisp in your home directory.~%%***~%%~%%\"))))
(when (find-package :gendl) (in-package :gdl-user)))" *gendl-home*))
......
......@@ -296,6 +296,15 @@ with this matrix will always result in the absolute orientation for this part.
(setf (gethash ob-key *standard-face-hts*)
ht))))))
("Vector of three real numbers. The RBG color of this object specified in :display-controls.
Defaults to the foreground color specified in <tt>*colors-default*</tt>. This message should not normally be overridden in user application code."
color-decimal (lookup-color (getf (the display-controls) :color)))
;;
;; FLAG -- remove this defunct version.
;;
#+nil
("Vector of three real numbers. The RBG color of this object specified in :display-controls.
Defaults to the foreground color specified in <tt>*colors-default*</tt>. This message should not normally be overridden in user application code."
color-decimal (multiple-value-bind (result found?)
......
......@@ -60,6 +60,25 @@
(define-lens (pdf base-object)()
:output-functions
((rgb-stroke-setting
()
(let* ((display-controls (find-in-hash self *display-controls*))
(color (or (getf display-controls :color)
(the color-decimal)))
(color-decimal (if (consp color) color
(coerce (lookup-color (or color (format-slot foreground-color))) 'list)))
(fill-color-decimal (coerce (lookup-color (getf (the display-controls) :fill-color)) 'list)))
(print-variables color color-decimal)
(apply #'pdf:set-rgb-stroke color-decimal)
(apply #'pdf:set-rgb-fill (or fill-color-decimal color-decimal))))
;;
;; FLAG -- remove this defunct version.
;;
#+nil
(rgb-stroke-setting
()
(let* ((display-controls (find-in-hash self *display-controls*))
(color (or (getf display-controls :color)
......
......@@ -30,6 +30,8 @@
#+clisp "fas"
#-(or allegro lispworks sbcl ccl abcl clisp) (error "Need fasl extension string for the currently running lisp.~%"))
(defparameter *temporary-folder-function* #'(lambda() (merge-pathnames "tmp/" (user-homedir-pathname))))
#-(or allegro lispworks sbcl ccl)
(warn "~&Please implement concatenate-fasls for the currently running lisp.~%")
......@@ -163,8 +165,9 @@ The command line was: ~%~%~s~%" command result error command-line)))))
;; temporary-folder is potentially platform-specific so it is defined here.
;;
(defun temporary-folder (&key (create? t))
(let ((folder (merge-pathnames "tmp/" (user-homedir-pathname))))
(when create? (ensure-directories-exist folder))))
(let ((folder (funcall *temporary-folder-function*)))
(if create? (ensure-directories-exist folder) folder)))
(defun temporary-file (&key (extension nil) create?)
(let ((file (merge-pathnames (make-pathname :name (string (gensym))
......
......@@ -29,6 +29,64 @@
(define-lens (raphael base-drawing)()
:output-functions
((raphael-paper-def
(&key width length)
(format *stream* "var paper = Raphael('~a', ~a, ~a);
paper.canvas.style.backgroundColor = '~a';
if (typeof start === 'undefined') {
var start = function () {
this.lastdx ? this.odx += this.lastdx : this.odx = 0;
this.lastdy ? this.ody += this.lastdy : this.ody = 0;
this.animate({opacity: .5}, 500, \">\");
},
move_cb = function (dx, dy) {
this.transform(\"T\"+(dx+this.odx)+\",\"+(dy+this.ody));
this.lastdx = dx;
this.lastdy = dy;
this.animate({opacity: .5}, 500, \">\");
~a
},
move = function (dx, dy) {
this.transform(\"T\"+(dx+this.odx)+\",\"+(dy+this.ody));
this.lastdx = dx;
this.lastdy = dy;
this.animate({opacity: .5}, 500, \">\");
},
up = function () {
this.animate({opacity: 1.0}, 500, \">\");
~a
},
touchcoords = function () {~a}};
"
(the raphael-canvas-id) width length
(lookup-color (format-slot background-color) :format :hex)
;;
;; FLAG -- pass in the containing
;; base-ajax-graphics-sheet and refer
;; to that, instead of referring to
;; the parent here.
;;
(the parent (gdl-sjax-call :null-event? t :js-vals? t :function-key :on-drag))
(the parent (gdl-sjax-call :null-event? t :js-vals? t :function-key :on-drop))
(the parent (gdl-sjax-call :null-event? t :js-vals? t :function-key :on-touchmove))))
;;
;; FLAG -- remove this defunct version.
;;
#+nil
(raphael-paper-def
(&key width length)
(format *stream* "var paper = Raphael('~a', ~a, ~a);~%
......
......@@ -155,7 +155,16 @@
:js-to-eval-previi js-to-eval-previi))))
(publish :path "/gdlAjax" :function 'gdlAjax)
(defun publish-gdlajax ()
(with-all-servers (server)
(publish :path "/gdlAjax" :function 'gdlAjax :server server)))
(publish-gdlajax)
;;
;; FLAG -- remove this defunct version.
;;
;; (publish :path "/gdlAjax" :function 'gdlAjax)
(defun wrap-cdata (string)
......
......@@ -102,7 +102,9 @@ mixes this in, or in a <tt>main-sheet</tt> output-function in an html-format vi
object.")
:input-slots
(("GDL object. Default object to which control will return with the write-back-link method"
((respondent (the bashee))
("GDL object. Default object to which control will return with the write-back-link method"
return-object (the :parent))
("String. Name of a browser frame or window to display this page. Default of NIL indicates to use the same window."
target nil)
......
......@@ -63,6 +63,8 @@
:port (the port))
(the input-parameters)))
;;(remote-object-args-json (cl-json: ) ;; FLAG -- fill in!
(parent-form (encode-for-http (the parent)))
(local-remote-id nil :settable)
......
......@@ -58,8 +58,8 @@
:amend? t
:output-functions
((raphael-paper-def
(&key width length)
(format *stream* "var paper = Raphael('~a', ~a, ~a);
(&key width length)
(format *stream* "var paper = Raphael('~a', ~a, ~a);
paper.canvas.style.backgroundColor = '~a';
......@@ -96,19 +96,19 @@
touchcoords = function () {~a}};
"
(the raphael-canvas-id) width length
(the raphael-canvas-id) width length
(lookup-color (format-slot background-color) :format :hex)
(lookup-color (format-slot background-color) :format :hex)
;;
;; FLAG -- pass in the containing
;; base-ajax-graphics-sheet and refer
;; to that, instead of referring to
;; the parent here.
;;
(the parent (gdl-sjax-call :null-event? t :js-vals? t :function-key :on-drag))
(the parent (gdl-sjax-call :null-event? t :js-vals? t :function-key :on-drop))
;;
;; FLAG -- pass in the containing
;; base-ajax-graphics-sheet and refer
;; to that, instead of referring to
;; the parent here.
;;
(the parent (gdl-sjax-call :null-event? t :js-vals? t :function-key :on-drag))
(the parent (gdl-sjax-call :null-event? t :js-vals? t :function-key :on-drop))
(the parent (gdl-sjax-call :null-event? t :js-vals? t :function-key :on-touchmove))))))))
(the parent (gdl-sjax-call :null-event? t :js-vals? t :function-key :on-touchmove))))))))
p019: removed superfluous ht (hash-table) from showing up in
variable-sequence for saved snapshot files.
p018: Implement random back-off strategy for starting webserver in
gwl:start-gwl, when port is already busy.
p017: Add explanatory error message in add-notify-cons for the case
when aggregate is nil (which should not normally happen).
p016: Improve sort ordering for input forms from snap files and stored
in version-tree root data structure"
p015: Adds overridable initialize-instance! function to vanilla-mixin
and calls this from make-object and make-object-internal.
p014: improve definition of glisp:temporary-folder, establish
glisp:*temporary-folder-function* which can be overridden by
user code.
p012: Improve definition of write-snapshot.
p009: Makes web-drawing and tasty respect background and foreground in *colors-default*.
p008: Make gdlAjax work with SSL by publishing through with-all-servers.
p007: Make sew-and-orient default to t only for merge operation.
p006: Improve behavior of restore-slot-default!
p005: Fix the order of the returned u,v point for the point function of uv-iso-curve.
p004: Fix restore-tree to restore to true root, and protect root-object-object
(the object of tasty or ta2) from being blown away and replaced with new object.
p001: Make the respondent default to the bashee for base-html-sheet, same as for base-ajax-sheet.
......@@ -117,6 +117,14 @@ defaults to t." error-on-invalid? *boolean-error-on-invalid-brep?*)
angle-tolerance *angle-tolerance-radians-default*)
("Boolean. Indicates whether we should try to sew and orient the
resulting brep. This defaults to t for merge operation and nil otherwise."
sew-and-orient? (eql (the operation) :merge))
;;
;; FLAG -- remove this defunct version.
;;
#+nil
("Boolean. Indicates whether we should try to sew and orient the
resulting brep. Usually a good idea and this is defaulted to t, except
for merged-solid where we default this to nil." sew-and-orient? t)
......@@ -125,10 +133,70 @@ for merged-solid where we default this to nil." sew-and-orient? t)
:computed-slots
(
((%merge-and-brep
(progn
(when (or (> (the first-brep regions number-of-elements) 2)
(not (every #'(lambda(number) (<= number 2))
(mapcar #'(lambda(object) (the-object object regions number-of-elements))
(the rest-breps)))))
(let ((message (format nil "~%~%in ~a -~%~%Attempting booleans where brep has ~~a non-infinite regions.~%"
(cons 'the (reverse (the root-path))))))
(if (the allow-multiple-regions?)
(warn message
(1- (the first-brep regions number-of-elements)))
(error message
(1- (the first-brep regions number-of-elements))))))
(let ((count -1) (length (length (the rest-breps)))
merge-container current-breps (current-brep (the first-brep %native-brep%)))
(dolist (other-brep (the rest-breps))
(incf count)
(when *debug?*
(print-variables (the root-path)
(the first-brep root-path)
(the-object other-brep root-path)))
(when *debug?* (print-variables (the approximation-tolerance) (the angle-tolerance)))
(setq merge-container (make-merge-container *geometry-kernel*
current-brep
(the-object other-brep %native-brep%)