Commit e269264d authored by Dave Cooper's avatar Dave Cooper

got patched cleaned up

parent 7075b337
......@@ -75,12 +75,12 @@
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((self ,name) &rest ,args-arg)
(declare (ignore ,args-arg))
(let ((*error-on-not-handled?* t))
(with-dependency-tracking (,attr-sym)
,(if query? `(iq:qlet (()) ,attr-expr) attr-expr))
#+nil
(with-dependency-tracking (,attr-sym)
,(if query? `(iq:qlet (()) ,attr-expr) attr-expr))
#+nil
(with-dependency-tracking (,attr-sym)
,(if query? (error "Query-slots are not supported in this distribution of Genworks GDL.")
attr-expr)))))
attr-expr)))))
(when (and *compile-for-dgdl?* (not (string-equal (symbol-name name) "remote-object")))
`(when (or (not (fboundp ',(glisp:intern attr-sym :gdl-slots)))
......@@ -89,18 +89,16 @@
(defmethod ,(glisp:intern attr-sym :gdl-slots) ((,self-arg gdl-remote) &rest ,args-arg)
(the-object ,self-arg (send (:apply (cons ,(make-keyword (symbol-name attr-sym))
,args-arg)))))))
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
;;(declare (ignore ,args-arg))
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg)
(let ((,val-arg (let (*error-on-not-handled?*)
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg))))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg) ,val-arg))))))))))
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
;;(declare (ignore ,args-arg))
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg)
(let ((,val-arg (let (*error-on-not-handled?*)
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg))))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg) ,val-arg))))))))))
computed-slots))
......
......@@ -66,14 +66,14 @@
,(if has-declare? (first body) `(declare))
,(when *compile-circular-reference-detection?*
`(when (and *run-with-circular-reference-detection?*
(member (list self ',attr-sym) *till-now* :test #'equalp))
(error "Circular reference detected")))
`(when (and *run-with-circular-reference-detection?*
(member (list self ',attr-sym) *till-now* :test #'equalp))
(error "Circular reference detected")))
(let ,(remove nil
(list (when *compile-circular-reference-detection?*
`(*till-now* (when *run-with-circular-reference-detection?*
(cons (list self ',attr-sym) *till-now*))))))
(list (when *compile-circular-reference-detection?*
`(*till-now* (when *run-with-circular-reference-detection?*
(cons (list self ',attr-sym) *till-now*))))))
(block ,(make-keyword attr-sym)
(let ((*error-on-not-handled?* t))
,@(if has-declare? (rest body) body))))) ,args-arg))
......@@ -86,9 +86,9 @@
(defmethod ,(glisp:intern attr-sym :gdl-slots) ((,self-arg gdl-remote) &rest ,args-arg)
(the-object ,self-arg (send (:apply (cons ,(make-keyword (symbol-name attr-sym)) ,args-arg)))))))
;;
;; FLAG -- why is this needed??
;;
;;
;; FLAG -- why is this needed??
;;
`(when (or (not (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-slots)))
(not (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)))
......@@ -96,8 +96,8 @@
;;(declare (ignore ,args-arg))
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg)
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg))))))))))
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg))))))))))
......
......@@ -24,7 +24,7 @@
(defun not-handled (object message &optional args)
(if *error-on-not-handled?*
(not-handled-error object message args)
'gdl-rule:%not-handled%))
'gdl-rule:%not-handled%))
(defun input-slots-generics (input-slots)
......@@ -76,8 +76,8 @@
(mapcan
#'(lambda(input)
(let* ((attr-sym (glisp:intern (symbol-name (if (symbolp input)
input
(message-symbol input))) :gdl-acc))
input
(message-symbol input))) :gdl-acc))
(attr-remarks (when (consp input) (message-strings input))))
(remove
nil
......@@ -91,26 +91,28 @@
(when (and *compile-for-dgdl?* (not (eql attr-sym 'gdl-acc::type)))
`(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 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)))))
nil (list (find-class 'gdl-remote) t (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern 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)))))
;;
;; FLAG -- added recently, because why wouldn't we need default message handlers for input-slots?
;;
;; FLAG -- did this cause problems for DAP? Keep an eye out for this.
;;
;; FLAG -- added recently, because why wouldn't we need default message handlers for input-slots?
;;
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
;;(declare (ignore ,args-arg))
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg)
(let ((,val-arg (let (*error-on-not-handled?*)
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg))))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg) ,val-arg))))))
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg)
(let ((,val-arg (let (*error-on-not-handled?*)
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg))))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg) ,val-arg))))))
......@@ -123,14 +125,14 @@
(if ,parent-arg
(let (*error-on-not-handled?*)
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object self %name%) self))
'gdl-rule:%not-handled%)))
,parent-arg (the-object self %name%) self))
'gdl-rule:%not-handled%)))
(cond ((not (eql ,val-arg 'gdl-rule:%not-handled%)) ,val-arg)
((and ,parent-arg (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs)))
(if ;;(member ,(make-key attr-sym) (the-object ,parent-arg :%trickle-down-slots%))
(gethash ,(make-keyword attr-sym) (the-object ,parent-arg :%trickle-down-slots%))
(,(glisp:intern (symbol-name attr-sym) :gdl-slots) ,parent-arg)
(funcall (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs)) ,parent-arg)))
(gethash ,(make-keyword attr-sym) (the-object ,parent-arg :%trickle-down-slots%))
(,(glisp:intern (symbol-name attr-sym) :gdl-slots) ,parent-arg)
(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))
......@@ -161,12 +163,13 @@
`(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 (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)))))))
(when *compile-for-dgdl?*
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-remote)
......@@ -191,13 +194,13 @@
`(if (eql ,val-arg 'gdl-rule:%not-handled%)
(let ((,val-arg (if ,parent-arg
(let (*error-on-not-handled?*)
(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%))
(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)))
(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))
,val-arg)
`(if (eql ,val-arg 'gdl-rule:%not-handled%) ,attr-expr ,val-arg))))))))))) input-slots))
......
......@@ -25,28 +25,28 @@
(defun object-inputs-generics-section (cooked-data &key special-keys)
(let ((object-input-keys (remove-duplicates
(cons :%parameters%
(apply #'append (mapcar #'(lambda(data)
(let ((plist-keys (mapcar #'make-keyword (append (plist-keys (getf data :plist))
(getf data :with-attribute-keys)))))
(set-difference plist-keys special-keys))) cooked-data))))))
(cons :%parameters%
(apply #'append (mapcar #'(lambda(data)
(let ((plist-keys (mapcar #'make-keyword (append (plist-keys (getf data :plist))
(getf data :with-attribute-keys)))))
(set-difference plist-keys special-keys))) cooked-data))))))
`((eval-when (:compile-toplevel :load-toplevel :execute)
,@(append
(mapcar #'(lambda(key)
`(unless (fboundp ',(glisp:intern key :gdl-inputs))
(defgeneric ,(glisp:intern key :gdl-inputs) (,parent-arg ,val-arg ,self-arg)))) object-input-keys)
(mapcar #'(lambda(key)
`(unless (fboundp ',(glisp:intern key :gdl-slots))
(defgeneric ,(glisp:intern key :gdl-slots) (,self-arg &rest ,args-arg)))) object-input-keys)))
,@(append
(mapcar #'(lambda(key)
`(unless (fboundp ',(glisp:intern key :gdl-inputs))
(defgeneric ,(glisp:intern key :gdl-inputs) (,parent-arg ,val-arg ,self-arg)))) object-input-keys)
(mapcar #'(lambda(key)
`(unless (fboundp ',(glisp:intern key :gdl-slots))
(defgeneric ,(glisp:intern key :gdl-slots) (,self-arg &rest ,args-arg)))) object-input-keys)))
,@(mapcar #'(lambda(key)
`(unless (find-method (symbol-function ',(glisp:intern key :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern key :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
;;(declare (ignore ,args-arg))
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword key) ,args-arg)
(,(glisp:intern key :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg)))))) object-input-keys))))
`(unless (find-method (symbol-function ',(glisp:intern key :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern key :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
;;(declare (ignore ,args-arg))
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword key) ,args-arg)
(,(glisp:intern key :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg)))))) object-input-keys))))
......
This diff is collapsed.
......@@ -72,36 +72,36 @@ set of arms contained in the body which is contained in the robot which is conta
(setq apply? t)(second (first (rest first))))
((listp first) (rest first))))
;;(new-object (gensym))
(new-object '+new-object+)
)
(new-object '+new-object+)
)
`(the-object ,(if *undeclared-parameters-enabled?*
(if evaluate?
`(if (fboundp (glisp:intern (symbol-name ,message) :gdl-slots))
(funcall (symbol-function (glisp:intern (symbol-name ,message) :gdl-slots)) ,object ,@args)
(let ((,new-object (getf (gdl-slots::%parameters% ,object)
(make-keyword ,message) 'gdl-rule:%not-handled%)))
(if (eql ,new-object 'gdl-rule:%not-handled%)
(not-handled-error ,object ',message ',args) ,new-object)))
`(if (fboundp ',message) (,message ,object ,@args)
(let ((,new-object (getf (gdl-slots::%parameters% ,object)
,(make-keyword message) 'gdl-rule:%not-handled%)))
(if (eql ,new-object 'gdl-rule:%not-handled%)
(not-handled-error ,object ',message ',args) ,new-object))))
(cond ((and evaluate? apply?)
`(apply (symbol-function (glisp:intern (symbol-name ,message) :gdl-slots)) ,object
(let ((,new-object (getf (gdl-slots::%parameters% ,object)
(make-keyword ,message) 'gdl-rule:%not-handled%)))
(if (eql ,new-object 'gdl-rule:%not-handled%)
(not-handled-error ,object ',message ',args) ,new-object)))
`(if (fboundp ',message) (,message ,object ,@args)
(let ((,new-object (getf (gdl-slots::%parameters% ,object)
,(make-keyword message) 'gdl-rule:%not-handled%)))
(if (eql ,new-object 'gdl-rule:%not-handled%)
(not-handled-error ,object ',message ',args) ,new-object))))
(cond ((and evaluate? apply?)
`(apply (symbol-function (glisp:intern (symbol-name ,message) :gdl-slots)) ,object
,args))
(evaluate?
`(funcall (symbol-function (glisp:intern (symbol-name ,message) :gdl-slots)) ,object
,@args))
(apply?
`(apply ',message ,object ,args))
(evaluate?
`(funcall (symbol-function (glisp:intern (symbol-name ,message) :gdl-slots)) ,object
,@args))
(apply?
`(apply ',message ,object ,args))
(t `(,message ,object ,@args))))
(t `(,message ,object ,@args))))
,@(rest reference-chain))))
object))
object))
......@@ -114,16 +114,16 @@ This is often used for sending the <tt>index</tt> message to an element of a qua
(defun not-handled-error (object message &optional args)
(if (the-object object root?)
(error "~s, which is the root object, could not handle the ~s message~a."
object (make-keyword message)
(if args (format nil "~%with args: ~s " args) ""))
(error "Neither ~s nor any of its ancestor instances could handle the ~s message~a
(if (the-object object root?)
(error "~s, which is the root object, could not handle the ~s message~a."
object (make-keyword message)
(if args (format nil "~%with args: ~s " args) ""))
(error "Neither ~s nor any of its ancestor instances could handle the ~s message~a
The path to the containing object is: ~s"
object (make-keyword message)
(if args (format nil "~%with args: ~s " args) "")
(append '(the :root) (symbols-as-keywords
(reverse (the-object object :root-path)))))))
object (make-keyword message)
(if args (format nil "~%with args: ~s " args) "")
(append '(the :root) (symbols-as-keywords
(reverse (the-object object :root-path)))))))
(defmacro with-format ((format stream-or-file &rest args) &body body)
"Void [Macro]. Used to establish an output format and a stream to which data is to be sent. This is the experimental
......
......@@ -37,26 +37,29 @@
(defun chase-up-trickle-down (slot-symbol self args)
(let ((keyword (make-keyword slot-symbol)))
(let ((parent (the-object self parent)))
;;
;; FLAG -- make sure 'args' below is correct - it was removed in 1590 p002.lisp (which is now gone).
;;
(if (null parent) (not-handled self keyword args)
(let ((result
(let (*error-on-not-handled?*)
(funcall (symbol-function (glisp:intern slot-symbol :gdl-inputs)) parent (the %name%) self))))
(if (eql result 'gdl-rule:%not-handled%)
(let ((result
(let (*error-on-not-handled?*)
(cond (;;(member keyword (the-object parent %trickle-down-slots%))
(gethash keyword (the-object parent %trickle-down-slots%))
(apply (symbol-function slot-symbol) parent args))
(t (apply (symbol-function (glisp:intern slot-symbol :gdl-trickle-downs)) parent args))))))
(if (eql result 'gdl-rule:%not-handled%) (not-handled self keyword args) result))
result))))))
(let ((result
(let (*error-on-not-handled?*)
(funcall (symbol-function (glisp:intern slot-symbol :gdl-inputs)) parent (the %name%) self))))
(if (eql result 'gdl-rule:%not-handled%)
(let ((result
(let (*error-on-not-handled?*)
(cond (;;(member keyword (the-object parent %trickle-down-slots%))
(gethash keyword (the-object parent %trickle-down-slots%))
(apply (symbol-function slot-symbol) parent args))
(t (apply (symbol-function (glisp:intern slot-symbol :gdl-trickle-downs)) parent args))))))
(if (eql result 'gdl-rule:%not-handled%) (not-handled self keyword args) result))
result))))))
(defun trickle-down-basis (self slot args)
(let ((keyword (make-keyword slot)))
(let (*error-on-not-handled?* (parent (the parent)))
(cond ((null parent) (not-handled self keyword args))
(;;(member keyword (the-object parent %trickle-down-slots%))
(gethash keyword (the-object parent %trickle-down-slots%))
(apply (symbol-function (glisp:intern slot :gdl-slots)) parent args))
(t (apply (symbol-function (glisp:intern slot :gdl-trickle-downs)) parent args))))))
(;;(member keyword (the-object parent %trickle-down-slots%))
(gethash keyword (the-object parent %trickle-down-slots%))
(apply (symbol-function (glisp:intern slot :gdl-slots)) parent args))
(t (apply (symbol-function (glisp:intern slot :gdl-trickle-downs)) parent args))))))
......@@ -79,23 +79,16 @@ filleted-polyline."
(%renderer-info% (list :vrml? t :view-default :top))
(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)))))))
(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)))))
(fillet-types (mapcar #'(lambda(test)
(if (the-object test valid?) 'fillet 'null-part))
......
;;
;; Copyright 2002-2012 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 load-hotpatches (&key force? (directory (merge-pathnames "hotpatches/" (glisp:executable-homedir-pathname))))
(if (not (and (probe-file directory)
(glisp:file-directory-p directory)))
(warn "~s does not exist and/or is not a directory~%" directory)
(let* ((files (glisp:directory-list directory))
(source-files (sort (remove-if-not #'(lambda(file)
(let ((type (pathname-type file)))
(or (string-equal type "lisp")
(string-equal type "gdl")
(string-equal type "gendl")))) files)
#'string-lessp :key #'namestring)))
(when (or (not (glisp:featurep :allegro))
(glisp:featurep :compiler))
(dolist (file source-files)
(with-error-handling ()
(format t "~&Compiling patch file ~a...~%" file)
(#+allegro excl:compile-file-if-needed #-allegro compile-file file))))
(setq files (remove-if #'(lambda(file)(string-equal (pathname-name file) "load")) (glisp:directory-list directory)))
(let ((compiled-files (sort (remove-if-not #'(lambda(file)
(string-equal (pathname-type file) glisp:*fasl-extension*)) files)
#'string-lessp :key #'namestring)))
(dolist (file compiled-files)
(unless (and (not force?) (find file *loaded-hotpatches* :test #'equalp))
(with-error-handling ()
(format t "~&Loading patch file ~a...~%" file)
(load file)
(pushnew file *loaded-hotpatches* :test #'equalp))))))))))
(load-hotpatches :directory (make-pathname :directory (pathname-directory *load-truename*) :defaults nil) :force? t)
This diff is collapsed.
(in-package :gdl)
(excl:without-package-locks
(excl:without-redefinition-warnings
(defun chase-up-trickle-down (slot-symbol self args)
(let ((keyword (make-keyword slot-symbol)))
(let ((parent (the-object self parent)))
(if (null parent) (not-handled self keyword)
(let ((result
(let (*error-on-not-handled?*)
(funcall (symbol-function (glisp:intern slot-symbol :gdl-inputs)) parent (the %name%) self))))
(if (eql result 'gdl-rule:%not-handled%)
(let ((result
(let (*error-on-not-handled?*)
(cond ( ;;(member keyword (the-object parent %trickle-down-slots%))
(gethash keyword (the-object parent %trickle-down-slots%))
(apply (symbol-function slot-symbol) parent args))
(t (apply (symbol-function (glisp:intern slot-symbol :gdl-trickle-downs)) parent args))))))
(if (eql result 'gdl-rule:%not-handled%) (not-handled self keyword args) result))
result))))))
(defun trickle-down-basis (self slot args)
(let ((keyword (make-keyword slot)))
(let (*error-on-not-handled?* (parent (the parent)))
(cond ((null parent) (not-handled self keyword args))
( ;;(member keyword (the-object parent %trickle-down-slots%))
(gethash keyword (the-object parent %trickle-down-slots%))
(apply (symbol-function (glisp:intern slot :gdl-slots)) parent args))
(t (apply (symbol-function (glisp:intern slot :gdl-trickle-downs)) parent args))))))))
......@@ -21,90 +21,74 @@
(in-package :surf)
(define-object normally-projected-curve (curve)
#+(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))
: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))))
: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)))
(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 (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-3d (mapcar #'get-3d-point-of (the projected-points)))
(projected-points-uv (mapcar #'get-uv-point-of (the projected-points)))
(projected-points-uv (mapcar #'get-uv-point-of (the projected-points)))
(built-from (the fitted-3d)))
(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%))))))))
#+nil
(define-object normally-projected-curve-test (normally-projected-curve)
:computed-slots ((from-surface (the test-fitted-surface))
(curve (the projected))
(to-surface (the offset-surface)))
:objects ((test-fitted-surface :type 'test-fitted-surface
:grid-height 1)
(offset-surface :type 'rectangular-surface
:length 5 :width 5 :center (make-point 2 2 1.5))
(projected :type 'projected-curve
:curve-in (the segment)
:surface (the test-fitted-surface)
:projection-vector (the (face-normal-vector :bottom)))
(segment :type 'linear-curve
:start (make-point 1 1 3)
:end (make-point 3 3 3))))
: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