Commit 888019f0 authored by Dave Cooper's avatar Dave Cooper

rolled all leftover patches from release into main codebase, deleted patches files.

parent dbec3707
......@@ -135,6 +135,7 @@
(funcall (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs)) ,parent-arg)))
(t (not-handled self ,(make-keyword attr-sym) ,args-arg)))))))))))) input-slots))
(defun optional-input-slots-section (name input-slots &optional (defaulted? nil))
(mapcan
#'(lambda(input)
......@@ -164,18 +165,22 @@
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
(when (and *compile-for-dgdl?* (not (string-equal (symbol-name name) "remote-object")))
`(when (or (not (fboundp ',(glisp:intern attr-sym :gdl-slots)))
(not (find-method (symbol-function ',(glisp:intern attr-sym :gdl-slots))
nil (list (find-class 'gdl-remote)) nil)))
(defmethod ,(glisp:intern attr-sym :gdl-slots) ((self gdl-remote) &rest ,args-arg)
(the (send (:apply (cons ,(make-keyword (symbol-name attr-sym)) ,args-arg)))))))
`(unless (find-method (symbol-function ',(glisp:intern attr-sym :gdl-inputs))
nil (list (find-class 'gdl-remote) t (find-class 'gdl-basis)) nil)
(when (or (not (fboundp ',(glisp:intern attr-sym :gdl-slots)))
(not (find-method (symbol-function ',(glisp:intern attr-sym :gdl-slots))
nil (list (find-class 'gdl-remote)) nil)))
(defmethod ,(glisp:intern attr-sym :gdl-slots) ((self gdl-remote) &rest ,args-arg)
(the (send (:apply (cons ,(make-keyword (symbol-name attr-sym)) ,args-arg))))))))
(when *compile-for-dgdl?*
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-remote)
,part-arg
(,self-arg gdl-basis))
(the-object ,parent-arg (fetch-input ,(make-keyword attr-sym) ,part-arg ,self-arg))))
`(unless (find-method (symbol-function ',(glisp:intern attr-sym :gdl-inputs))
nil (list (find-class 'gdl-remote) t (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-remote)
,part-arg
(,self-arg gdl-basis))
(the-object ,parent-arg (fetch-input ,(make-keyword attr-sym) ,part-arg ,self-arg)))))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))
......@@ -188,8 +193,8 @@
(if ,parent-arg
(let (*error-on-not-handled?*)
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the :%name%) self))
'gdl-rule:%not-handled%)))
,parent-arg (the :%name%) self))
'gdl-rule:%not-handled%)))
,(if defaulted?
`(if (eql ,val-arg 'gdl-rule:%not-handled%)
(let ((,val-arg (if ,parent-arg
......@@ -197,7 +202,7 @@
(if (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs))
(,(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs) self)
'gdl-rule:%not-handled%))
,val-arg)))
,val-arg)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) ,attr-expr ,val-arg))
,val-arg)
`(if (eql ,val-arg 'gdl-rule:%not-handled%) ,attr-expr ,val-arg))))))))))) input-slots))
......
......@@ -206,6 +206,19 @@ future GenDL release."
(defparameter *message-list-hashes* (make-hash-table :size 100))
(defun evaluate-if-handled (object message &rest args)
(let* ((type (the-object object type))
(message-hash (or (gethash type *message-list-hashes*)
(setf (gethash type *message-list-hashes*)
(let* ((messages (the-object object message-list))
(hash (glisp:make-sans-value-hash-table :size (length messages))))
(dolist (message messages hash) (setf (gethash message hash) t)))))))
(let ((handled? (gethash (gdl::make-key message) message-hash)))
(cond ((and handled? args) (the-object object ((evaluate message) (:apply args))))
(handled? (the-object object (evaluate message)))
(t (values nil :not-handled))))))
(defmacro %define-object-amendment% (name mixin-list
&key input-slots
computed-slots
......@@ -411,6 +424,19 @@ future GenDL release."
(append object-syms quantified-object-syms hidden-object-syms
quantified-hidden-object-syms trickle-down-slot-syms))
(eval-when (:load-toplevel)
(let ((class (find-class ',name)))
(dolist (super (cons class (all-superclasses class)))
(let ((ht (or (gethash super *class-used-by-hash*)
(setf (gethash super *class-used-by-hash*)
(glisp:make-sans-value-hash-table)))))
(setf (gethash class ht) t)))
(maphash #'(lambda(key value)
(declare (ignore value))
(setf (gethash key *message-list-hashes*) nil))
(gethash class *class-used-by-hash*))))
)))))
......@@ -702,9 +728,22 @@ overview of <tt>define-object</tt> syntax."
(when (and (not (eql ,message-type-arg :local)) (next-method-p))
(call-next-method ,self-arg ,category-arg ,message-type-arg ,base-part-type-arg (1+ ,depth-arg)))))
(eval-when (:load-toplevel)
(let ((class (find-class ',name)))
(dolist (super (cons class (all-superclasses class)))
(let ((ht (or (gethash super *class-used-by-hash*)
(setf (gethash super *class-used-by-hash*)
(glisp:make-sans-value-hash-table)))))
(setf (gethash class ht) t)))
(maphash #'(lambda(key value)
(declare (ignore value))
(setf (gethash key *message-list-hashes*) nil))
(gethash class *class-used-by-hash*))))
(find-class ',name)))))
(find-class ',name)))))
......
......@@ -23,15 +23,17 @@
(define-object quantification ()
:documentation (:description "A quantification is an aggregate created as a result of specifying <tt>:sequence (:size ...))</tt> or
:documentation (:description "A quantification is an aggregate created as a result of specifying <tt>:sequence (:size ...))</tt> or
<tt>:sequence (:indices ...))</tt> in an <tt>:objects</tt> specification. Usually, the elements of a quantified set are referenced by using
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.")
:computed-slots
(("GDL Object. Returns the first element of the aggregate."
first nil)
:computed-slots
((index nil)
("GDL Object. Returns the first element of the aggregate."
first nil)
("GDL Object. Returns the last element of the aggregate."
last nil)))
("GDL Object. Returns the last element of the aggregate."
last nil)))
......@@ -164,6 +164,7 @@ If you are interested in this effort we would love to hear from you at open-sour
#:ensure-list
#:evaluate
#:evaluate-object
#:evaluate-if-handled
#:expandit
#:find-messages-used-by
#:find-messages-which-use
......
......@@ -148,49 +148,67 @@
(define-lens (pdf view-object-cache)()
:output-functions
((lines-and-curves
((pdf-command
(mode coords)
(ecase mode
(:move (let ((coord (first coords))) (pdf:move-to (%get-x% coord) (%get-y% coord))))
(:line (let ((coord (first coords))) (pdf:line-to (%get-x% coord) (%get-y% coord))))
(:curve (destructuring-bind (c1 c2 end) coords
(pdf:bezier-to (%get-x% c1) (%get-y% c1) (%get-x% c2)
(%get-y% c2) (%get-x% end) (%get-y% end))))))
(lines-and-curves
()
(when (typep (the object) 'gdl::gdl-basis)
(let ((object (the object)) (2d-vertices (the vertex-array-2d-scaled)))
(let ((line-index-pairs (the-object object %line-vertex-indices%))
(curve-index-quadruples (the-object object %curve-vertex-indices%)))
(curve-index-quadruples (the-object object %curve-vertex-indices%))
(path-info (the path-info-2d-scaled)))
(pdf:with-saved-state (write-the-object object line-thickness-setting)
(write-the-object object dash-pattern-setting)
(write-the-object object rgb-stroke-setting)
(mapc #'(lambda(line-index-pair)
(destructuring-bind (start-index end-index) line-index-pair
(let ((start (svref 2d-vertices start-index))
(end (svref 2d-vertices end-index)))
(pdf:move-to (%get-x% start) (%get-y% start))
(pdf:line-to (%get-x% end)(%get-y% end))))) line-index-pairs)
(if path-info
(let (mode coords)
(dolist (item path-info)
(if (keywordp item)
(progn
(print-variables mode coords)
(when (and mode coords) (write-the (pdf-command mode (nreverse coords))))
(setq mode item) (setq coords nil))
(push item coords)))
(write-the (pdf-command mode (nreverse coords))))
(progn
(mapc #'(lambda(line-index-pair)
(destructuring-bind (start-index end-index) line-index-pair
(let ((start (svref 2d-vertices start-index))
(end (svref 2d-vertices end-index)))
(pdf:move-to (%get-x% start) (%get-y% start))
(pdf:line-to (%get-x% end)(%get-y% end))))) line-index-pairs)
(let (start end prev-end)
(let (start end prev-end)
(mapc #'(lambda(curve-index-quadruple)
(destructuring-bind (start-index c1-index c2-index end-index)
curve-index-quadruple
(declare (ignorable start-index))
(mapc #'(lambda(curve-index-quadruple)
(destructuring-bind (start-index c1-index c2-index end-index)
curve-index-quadruple
(declare (ignorable start-index))
(setq prev-end end)
(setq start (svref 2d-vertices start-index)
end (svref 2d-vertices end-index))
(setq prev-end end)
(setq start (svref 2d-vertices start-index)
end (svref 2d-vertices end-index))
(let ((c1 (svref 2d-vertices c1-index))
(c2 (svref 2d-vertices c2-index)))
(let ((c1 (svref 2d-vertices c1-index))
(c2 (svref 2d-vertices c2-index)))
(unless (and start prev-end (coincident-point? start prev-end))
(pdf:move-to (%get-x% start) (%get-y% start)))
(unless (and start prev-end (coincident-point? start prev-end))
(pdf:move-to (%get-x% start) (%get-y% start)))
(pdf:bezier-to (%get-x% c1) (%get-y% c1) (%get-x% c2)
(%get-y% c2) (%get-x% end) (%get-y% end)))))
curve-index-quadruples))
(pdf:bezier-to (%get-x% c1) (%get-y% c1) (%get-x% c2)
(%get-y% c2) (%get-x% end) (%get-y% end)))))
curve-index-quadruples))))
(if (the-object object fill-color-decimal)
......@@ -198,6 +216,7 @@
(pdf:stroke)))))))))
;;
;; FLAG - update this lens to be like Raphael so the fill will work for closed shapes.
;;
......
......@@ -79,16 +79,23 @@ filleted-polyline."
(%renderer-info% (list :vrml? t :view-default :top))
(path-info (let ((first? t))
(mapcan #'(lambda(straight curve-set)
(append (if first? (progn (setq first? nil)
(list :move (first straight) :line (second straight)))
(list :line (second straight)))
(apply #'append
(mapcar #'(lambda(curve) (cons :curve (rest (reverse curve))))
(reverse (the-object curve-set %curves-to-draw%))))))
(the straights) (list-elements (the fillets)))))
(path-info (append
(let ((first? t))
(mapcan
#'(lambda(straight curve-set)
(append (if first? (progn (setq first? nil)
(list :move (first straight)
:line (second straight)))
(list :line (second straight)))
(apply #'append
(mapcar #'(lambda(curve)
(cons :curve (rest (reverse curve))))
(reverse (the-object curve-set %curves-to-draw%))))))
(the straights) (list-elements (the fillets))))
(when (> (length (the straights)) (the fillets number-of-elements))
(list :line (second (lastcar (the straights)))))))
(fillet-types (mapcar #'(lambda(test)
(if (the-object test valid?) 'fillet 'null-part))
......@@ -101,7 +108,8 @@ filleted-polyline."
:hidden-objects
((fillet-tests :type 'fillet-tester
:sequence (:size (the fillets number-of-elements))
:direction-vectors (list (reverse-vector (direction-vector (nth (the-child :index) (the :lines))))
:direction-vectors (list (reverse-vector
(direction-vector (nth (the-child :index) (the :lines))))
(if (and (the-child :last?) (the :closed?))
(direction-vector (first (the :lines)))
(direction-vector (nth (1+ (the-child :index)) (the :lines)))))
......
;;
;; Copyright 2016 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
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; 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
;; <http://www.gnu.org/licenses/>.
;;
(in-package :surf)
#+(or allegro lispworks)
(#+allegro
excl:without-package-locks #-allegro progn
(#+allegro
excl:without-redefinition-warnings #-allegro progn
(define-object normally-projected-curve (curve)
:input-slots (from-surface
curve to-surface
(number-of-points 200))
:computed-slots ((sample-points (the curve uv-curve (equi-spaced-points (the number-of-points))))
(normals (mapcar #'(lambda(point) (the from-surface (normal (get-u point) (get-v point)))) (the sample-points)))
(projected-points (mapcar #'(lambda(point normal)
(the to-surface (projected-point (the from-surface (point (get-u point) (get-v point))) normal)))
(the sample-points) (the normals)))
(projected-points-3d (mapcar #'get-3d-point-of (the projected-points)))
(projected-points-uv (mapcar #'get-uv-point-of (the projected-points)))
(built-from (the fitted-3d)))
:hidden-objects ((fitted :type 'fitted-curve
:points (the projected-points-3d))
(fitted-uv :type 'fitted-curve
:points (mapcar #'(lambda(point) (make-point (get-x point) (get-y point) 0)) (the projected-points-uv)))
(approximated :type 'approximated-curve
:curve-in (the fitted-uv)
:tolerance 0.00001)
(fitted-3d :type 'b-spline-curve
:knot-vector (the approximated knot-vector)
:degree (the approximated degree)
:weights (the approximated weights)
:control-points (mapcar #'(lambda(point)
(the to-surface (point (get-u point) (get-v point))))
(the approximated control-points)))))
(define-object-amendment curve ()
:computed-slots
((%curves-to-draw%
(unless (or *curve-tessellation?*
(near-to? (the total-length) 0))
(if (typep self 'arc-curve)
(call-next-method)
(if (or (the %decomposed?%) (= (the %decomposed% curves number-of-elements) 1))
(unless (and (= (the degree) 1) (not (the rational?)))
(when (list-elements (the beziers))
(let (result)
(dolist (bezier
(if t ;;*chain-beziers-for-display?*
(chain-nurbs-curves (list-elements (the beziers)))
(list-elements (the beziers)))
result)
(if (null result)
(setq result (the-object bezier %curves-to-draw%))
(nconc result (the-object bezier %curves-to-draw%)))))))
(append-elements (the %decomposed% curves)
(the-element %curves-to-draw%))))))))))
(in-package :gdl)
(#+allegro
excl:without-package-locks #-allegro progn
(#+allegro
excl:without-redefinition-warnings #-allegro progn
(define-object quantification ()
:documentation (:description "A quantification is an aggregate created as a result of specifying <tt>:sequence (:size ...))</tt> or
<tt>:sequence (:indices ...))</tt> in an <tt>:objects</tt> specification. Usually, the elements of a quantified set are referenced by using
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.")
:computed-slots
((index nil)
("GDL Object. Returns the first element of the aggregate."
first nil)
("GDL Object. Returns the last element of the aggregate."
last nil)))))
This diff is collapsed.
;;
;; Copyright 2002-2011 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
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; 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
;; <http://www.gnu.org/licenses/>.
;;
(in-package :surf)
#+(or allegro lispworks)
(#+allegro
excl:without-package-locks #-allegro progn
(#+allegro
excl:without-redefinition-warnings #-allegro progn
(define-object edge (curve)
:documentation (:description "Represents one edge in a brep. This object is a type of curve and answers all curve messages.")
:input-slots (%native-edge%
%native-brep%
brep
)
:computed-slots ((native-curve-iw
(get-bspline-curve-from-edge *geometry-kernel* (the %native-edge%)))
("List of GDL Face objects. The faces connected to this edge."
faces (let ((faces-ht (the brep faces-ht)))
(mapcar #'(lambda(native-face) (gethash native-face faces-ht))
(the %native-faces%))))
(%native-faces% (get-faces-from-edge *geometry-kernel* (the %native-edge%)))
(%unique-id% (get-long *geometry-kernel* self)))
:functions (("GDL Curve object. This represents the UV curve for this edge on the given surface.
Note that you have to pass in the surface, which should be the basis-surface of a face connected
to this edge. The GDL edge object will be supplemented with a sequence of faces which are connected
with this edge."
uv-curve
(surface)
(make-object 'curve
:native-curve-iw
(get-uv-curve-from-edge *geometry-kernel* (the %native-edge%)
(the-object surface native-surface-iw))))))
(define-object-amendment face ()
:computed-slots
((brep-id (the brep %unique-id%))))
(define-object geometry-kernel-object-mixin ()
:documentation (:description "This mixin provides messages common to all NURBS-based objects whose underlying implementation
comes from a modular geometry kernel such as SMLib.")
:input-slots ((from-iges? nil))
:input-slots
(
("List of integers. The IGES-compatible levels (layers) on which this object resides. GDL does not currently support writing
out multiple levels (layers) through the IGES writer ; only the first of these will be output if the object is exported with
the IGES output-format (please contact Genworks if you need all levels (layers) to be written out)."
levels (get-levels *geometry-kernel* self))
("Integer. The primary IGES-compatible level (layer) on which this object resides. Defaults to the first of the levels. This
slot can be overridden in user code to specify a new layer which will be written out when this object is exported with the IGES
output-format."
layer (first (the levels)))
("Integer. Synonym for the layer."
iges-level (the layer))
(color-hex (lookup-color (the color-decimal) :format :hex))
("Vector of three real numbers. The RGB color of this object as imported from an external format (e.g. IGES) or as 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 (let ((color (when (the from-iges?) (get-color *geometry-kernel* self))))
(or color (multiple-value-bind (result found?) (lookup-color (getf (the display-controls) :color))
(when found? result))))))
:computed-slots
((%line-vertex-indices% (let ((count -1))
(mapcar #'(lambda(line)
(declare (ignore line))
(list (incf count) (incf count)))
(the %lines-to-draw%))))
(%vertex-array% (append (flatten-lines (the %lines-to-draw%)) (flatten-curves (the %curves-to-draw%))))
(%unique-id% (or (get-long *geometry-kernel* self)
(let ((id (read-from-string (subseq (string (gensym)) 1))))
(format t "Setting object unique-id on-demand for object ~s.~%" self)
(set-long *geometry-kernel* self id)
id)))))))
;;
;; Copyright 2002-2011 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
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; 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
;; <http://www.gnu.org/licenses/>.
;;
(in-package :geom-base)
(#+allegro
excl:without-package-locks #-allegro progn
(#+allegro
excl:without-redefinition-warnings #-allegro progn
(define-object-amendment global-filleted-polyline-mixin ()
:computed-slots
((path-info (append
(let ((first? t))
(mapcan #'(lambda(straight curve-set)
(append (if first? (progn (setq first? nil)
(list :move (first straight) :line (second straight)))
(list :line (second straight)))
(apply #'append
(mapcar #'(lambda(curve) (cons :curve (rest (reverse curve))))
(reverse (the-object curve-set %curves-to-draw%))))))
(the straights) (list-elements (the fillets))))
(when (> (length (the straights)) (the fillets number-of-elements))
(list :line (second (lastcar (the straights)))))))))))
(in-package :geom-base)
;;
;; FLAG -- update compiler to do proper eval-when for gdl-output::
;; methods, to make the following unecessary to avoid warning.
;;
(defgeneric gdl-output::pdf-command (format object skin &rest args))
(#+allegro
excl:without-package-locks #-allegro progn
(#+allegro
excl:without-redefinition-warnings
#-allegro progn
(define-lens (pdf view-object-cache)()
:output-functions
((pdf-command
(mode coords)
(ecase mode
(:move (let ((coord (first coords))) (pdf:move-to (%get-x% coord) (%get-y% coord))))
(:line (let ((coord (first coords))) (pdf:line-to (%get-x% coord) (%get-y% coord))))
(:curve (destructuring-bind (c1 c2 end) coords
(pdf:bezier-to (%get-x% c1) (%get-y% c1) (%get-x% c2)
(%get-y% c2) (%get-x% end) (%get-y% end))))))
(lines-and-curves
()
(when (typep (the object) 'gdl::gdl-basis)
(let ((object (the object)) (2d-vertices (the vertex-array-2d-scaled)))
(let ((line-index-pairs (the-object object %line-vertex-indices%))
(curve-index-quadruples (the-object object %curve-vertex-indices%))
(path-info (the path-info-2d-scaled)))
(pdf:with-saved-state (write-the-object object line-thickness-setting)
(write-the-object object dash-pattern-setting)
(write-the-object object rgb-stroke-setting)
(if path-info
(let (mode coords)
(dolist (item path-info)
(if (keywordp item)
(progn
(print-variables mode coords)
(when (and mode coords) (write-the (pdf-command mode (nreverse coords))))
(setq mode item) (setq coords nil))
(push item coords)))
(write-the (pdf-command mode (nreverse coords))))
(progn
(mapc #'(lambda(line-index-pair)
(destructuring-bind (start-index end-index) line-index-pair
(let ((start (svref 2d-vertices start-index))
(end (svref 2d-vertices end-index)))
(pdf:move-to (%get-x% start) (%get-y% start))
(pdf:line-to (%get-x% end)(%get-y% end))))) line-index-pairs)
(let (start end prev-end)
(mapc #'(lambda(curve-index-quadruple)
(destructuring-bind (start-index c1-index c2-index end-index)
curve-index-quadruple
(declare (ignorable start-index))
(setq prev-end end)
(setq start (svref 2d-vertices start-index)
end (svref 2d-vertices end-index))
(let ((c1 (svref 2d-vertices c1-index))
(c2 (svref 2d-vertices c2-index)))
(unless (and start prev-end (coincident-point? start prev-end))
(pdf:move-to (%get-x% start) (%get-y% start)))
(pdf:bezier-to (%get-x% c1) (%get-y% c1) (%get-x% c2)
(%get-y% c2) (%get-x% end) (%get-y% end)))))
curve-index-quadruples))))
(if (the-object object fill-color-decimal)
(pdf:fill-and-stroke)
(pdf:stroke)))))))))))
;;
;; Copyright 2002-2011 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
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; 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
;; <http://www.gnu.org/licenses/>.
;;
(in-package :gdl)
(#+allegro
excl:without-package-locks
#-allegro progn
(#+allegro
excl:without-redefinition-warnings
#-allegro progn
(defun optional-input-slots-section (name input-slots &optional (defaulted? nil))
(mapcan
#'(lambda(input)
(let ((attr-remarks (message-strings input))
(attr-sym (glisp:intern (symbol-name (message-symbol input)) :gdl-acc))
(attr-expr (message-source-code input)))
(remove
nil