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

Issues 65, 67, 68, 69.

parent 7f6bd0f4
......@@ -37,19 +37,22 @@
((:div :class "people")
(:h4 "Head of Product Development")
(:p
"Dave started as Head of Product Development with the first commercial release of
Genworks GDL (GenDL) in August, 2002. Prior to that, he performed contract KBE programming with
The ICAD System® at Ford Motor Company, General Motors, Raytheon Aircraft, Embraer, and elsewhere.
Prior to that Dave was an employee at Ford Motor Company for several years, involved with ICAD application
development and systems deployment.")
"Dave started as Head of Product Development with the first
commercial release of Genworks GDL (GenDL) in 2002. Prior to that, he
performed contract KBE programming with The ICAD System® at Ford
Motor Company, General Motors, Raytheon Aircraft, Embraer, and
elsewhere. Prior to that Dave was an employee at Ford Motor Company
for several years, involved with ICAD application development and
systems deployment.")
(:p "Dave holds B.S and M.S degrees in Computer Science and Engineering,
both from the University of Michigan in Ann Arbor, MI.")
(:p "Dave is also the founder of the Common Lisp Foundation, dedicated to propogating
the CL programming language, and is a Director on the Association of Lisp Users.")
(:p "Dave has spoken and delivered papers at numerous
(:p "He has spoken and delivered papers at numerous
Conferences in the U.S., Europe and Japan. The
presentations have focused on KBE issues and the Lisp programming
language. Below are some representative papers.")
(:p "He is currently President of the Association of Lisp Users.")
(:p ((:a :href "http://downloads.genworks.com/kbe2008.pdf")
"2008 SAE Aerospace Conference, presented in Wichita, Kansas"))
(:p ((:a :href "http://downloads.genworks.com/kbe2007.pdf")
......@@ -83,18 +86,23 @@ seamlessly available in the GenDL environment.")))
((:div :class "profile")
((:div :class "people")
(:h4 "Vice-President and General Manager")
(:p "Mr Cooper's background is in the law. His legal background is extensive,
based mainly around Contracts and Insurance law. He has been in practice continuously
for 50 years, is a graduate of the University of Michigan Law School, is the past-president
of the organized civil defense bar in the State of Michigan, and has been continuously
listed in the elite publication Best Lawyers in America since that publication's
inception in the late 1980's (less than 1% of practicing attorneys are included in
Best Lawyers). Mr Cooper has also recently been added to Super Lawyers as a specialist
in Insurance Coverage and Contracts Law.")
(:p "At Genworks, He performs a managerial role for the company, and acts as
General Counsel reviewing contracts and in general keeping Genworks' business
relationships running smoothly.")))
(:p "Mr Cooper's background is in the law. His legal
background is extensive, based mainly around Trial, Contracts and
Insurance Coverage issues. He has been in practice continuously for 52
years, is a graduate of the University of Michigan Law School, is the
past-president of the organized civil defense bar in the State of
Michigan, and has been continuously listed in the elite publication"
(:i "Best Lawyers in America")
" since that publication's inception in the late
1980s (less than 1% of practicing attorneys are included in "
(:i "Best Lawyers")
"). Mr Cooper has also recently been added to "
(:i "Super Lawyers")
" as a specialist in Insurance Coverage and Contracts Law.")
(:p "At Genworks, he performs a managerial role for the
company, and acts as General Counsel drafting and reviewing contracts
and in general keeping Genworks' business relationships running
smoothly.")))
(:h3 "Kai Yan Cooper")
((:div :class "profile")
......
......@@ -39,8 +39,10 @@ development of the Common Lisp programming language by:
<p>
Currently, the Foundation is active in sponsorship and financial
administration for the 2011 European Common Lisp Meeting scheduled to
take place in Amsterdam in October, 2011.
administration for the <a href=http://weitz.de/eclm2013/>2013 European Common Lisp Meeting</a>
scheduled to take place June 2, 2013 in Madrid. The Foundation is also
investigating the possibility of managing donations for Common Lisp
related community projects.
</p>
<p>&nbsp;</p>
......
......@@ -21,6 +21,7 @@
(pushnew (list definition-keywords 0 font-lock-keyword-face) lisp-font-lock-keywords)
(pushnew (list keyword-keywords 0 font-lock-type-face) lisp-font-lock-keywords)))
(add-gdl-font-lock-keywords)
(defmacro defindent (name indentation)
(let* ((keyword-list '(lisp-font-lock-keywords t t t nil nil nil "&allow-other-keys"))
......@@ -36,7 +37,7 @@
(defindent defcompanion (like define-object)))
(add-gdl-font-lock-keywords)
(gdl:define-indents)
(setq font-lock-verbose nil)
......
......@@ -273,7 +273,7 @@
(defmacro w-o-interrupts (&body body)
(format t "~&NOTE: Without-interrupts is deprecated in multiprocessing Lisp - replace usage with something else in glisp:w-o-interrupts.~%")
#-(or allegro lispworks cmu sbcl ccl) (error "Need implementation for without-interrupts for currently running lisp.~%")
#-(or allegro lispworks cmu sbcl ccl abcl) (error "Need implementation for without-interrupts for currently running lisp.~%")
`(#+allegro excl:without-interrupts
#+lispworks progn
#+ccl progn
......
......@@ -21,7 +21,7 @@
(in-package :common-lisp-user)
#-(or allegro lispworks sbcl ccl) (error "
#-(or allegro lispworks sbcl ccl abcl) (error "
D'oh! GenDL is not yet supported on ~a. If you would like to try porting it, start with this file,
gdl/base/common/genworks.lisp.
......
......@@ -207,6 +207,51 @@ You have a dependency on caffeine. Your children are your dependants.
(find-messages-used-by instance message-key))
(let ((value (gensym)) (need? (gensym)))
(defmacro with-dependency-tracking ((message-symbol &optional (self-sym 'self)) &rest body)
`(let ((,value (,message-symbol ,self-sym))
(,need? (and *run-with-dependency-tracking?* *notify-cons* *root-checking-enabled?*
;;
;; FLAG -- check that remotes are effectively from same tree as well
;;
(or (and (find-class 'gdl-remote nil) (typep (first *notify-cons*) 'gdl-remote))
(same-tree? ,self-sym (first *notify-cons*))))))
,(when *compile-circular-reference-detection?*
`(when (and *run-with-circular-reference-detection?*
(member (list ,self-sym ',message-symbol) *till-now* :test #'equalp))
(error "Circular reference detected")))
(if (eq (first (ensure-list ,value)) 'gdl-rule::%unbound%)
(progn (setq ,value (list (let* ,(remove nil
(list (when *compile-dependency-tracking?*
`(*notify-cons* (when *run-with-dependency-tracking?*
(list ,self-sym ',message-symbol))))
(when *compile-circular-reference-detection?*
`(*till-now* (when *run-with-circular-reference-detection?*
(cons (list ,self-sym ',message-symbol)
*till-now*))))))
,@body)
(when ,need? (list (copy-list *notify-cons*)))))
(if (not (eql (first ,value) 'gdl-rule:%not-handled%))
(setf (,message-symbol ,self-sym) ,value)
;;(without-interrupts (setf (,message-symbol ,self-sym) ,value))
(progn (setq ,need? nil)
(not-handled ,self-sym ',message-symbol))))
(when ,need? (add-notify-cons *notify-cons* ,value ,self-sym ',message-symbol)))
(first ,value))))
;;
;; FLAG - this is current
;;
#+nil
(let ((value (gensym)) (need? (gensym)))
(defmacro with-dependency-tracking ((message-symbol &optional (self-sym 'self)) &rest body)
`(let ((,value (,message-symbol ,self-sym))
......@@ -245,6 +290,9 @@ You have a dependency on caffeine. Your children are your dependants.
(first ,value))))
#+nil
(defun add-notify-cons (notify-cons value)
(let ((matching-sublist (assoc (first notify-cons) (second value))))
(if matching-sublist (pushnew (second notify-cons) (rest matching-sublist))
......
......@@ -105,42 +105,43 @@ In ~s, it evaluated to ~s.
(get-member
(index)
(let ((child-types (the child-types))
(array (the array)))
(array (the array)))
(typecase index
(number
(if (>= index (length array))
(ecase *out-of-bounds-sequence-reference-action*
(:error
(error "Attempt to access element index ~a in sequence which only has ~a elements,
(number
(if (>= index (length array))
(ecase *out-of-bounds-sequence-reference-action*
(:error
(error "Attempt to access element index ~a in sequence which only has ~a elements,
the root-path to the sequence is ~s."
index (length array) (cons 'the (reverse (the root-path)))))
(:warn
(warn "Attempt to access element index ~a in sequence which only has ~a elements --
index (length array) (cons 'the (reverse (the root-path)))))
(:warn
(warn "Attempt to access element index ~a in sequence which only has ~a elements --
the root-path to the sequence is ~s.
*********** returning nil ************.
"
index (length array) (cons 'the (reverse (the root-path)))))
(:silent nil))
(or (aref array index)
(setf (aref array index)
(make-object-internal (if (atom child-types)
child-types
(or (nth index child-types)
(first
(last child-types))))
:%name% (list (glisp:intern (symbol-name (the :name-for-display)) :gdl-acc) nil t)
:%parent% (list (the :parent) nil t)
:%root% (gdl-acc::%root% self)
:%aggregate% (list self nil t)
:%index% (list index nil t))))))
(keyword
(ecase index
(:first (the :first))
(:last (the :last)))))))))
index (length array) (cons 'the (reverse (the root-path)))))
(:silent nil))
(or (aref array index)
(setf (aref array index)
(make-object-internal (if (atom child-types)
child-types
(or (nth index child-types)
(first
(last child-types))))
:%name% (list (glisp:intern (symbol-name (the :name-for-display)) :gdl-acc) nil t)
:%parent% (list (the :parent) nil t)
:%root% (gdl-acc::%root% self)
:%aggregate% (list self nil t)
:%index% (list index nil t))))))
(keyword
(ecase index
(:first (the :first))
(:last (the :last)))))))))
;; FLAG -- this needs a lot of work -- have to truly get rid of
......
......@@ -771,4 +771,53 @@ toplevel inputs as specified in the snapshot file.
(defun gdl-rule::lookup-parameters (self message)
(let ((value (getf (the %parameters%) message 'gdl-rule:%not-handled%)))
(if (eql value 'gdl-rule:%not-handled%) (not-handled self message) value)))
\ No newline at end of file
(if (eql value 'gdl-rule:%not-handled%) (not-handled self message) value)))
(defparameter *dep-hash-threshhold* 1000)
(defun add-notify-cons (notify-cons value &optional self message)
(when nil ;;(and self message)
(let ((aggregate (gdl-acc::%aggregate% (first notify-cons))))
(when (and (consp aggregate)
(not (consp (gdl-acc::%aggregate% self))))
(let ((num-value (gdl-acc::number-of-elements (first aggregate))))
(when (consp num-value)
(add-notify-cons (list self message) num-value))))))
(let ((second (second value)))
(if (and (listp second) (< (length second) *dep-hash-threshhold*))
(let ((matching-sublist (assoc (first notify-cons) (second value))))
(if matching-sublist (pushnew (second notify-cons) (rest matching-sublist))
(push (copy-list notify-cons) (second value))))
(progn
(when (listp second) (setf (second value) (alist-to-hash second)))
(pushnew (second notify-cons) (gethash (first notify-cons) (second value)))))))
(defun alist-to-hash (alist)
(let ((ht (make-hash-table :size (twice *dep-hash-threshhold*) :rehash-size *dep-hash-threshhold*)))
(dolist (entry alist ht)
(destructuring-bind (object . messages) entry
(setf (gethash object ht) messages)))))
#+nil
(defun add-notify-cons (notify-cons value &optional self message)
(when (and self message)
(let ((aggregate (gdl-acc::%aggregate% (first notify-cons))))
(when (consp aggregate)
(add-notify-cons (list self message)
(gdl-acc::number-of-elements (first aggregate))))))
(let ((matching-sublist (assoc (first notify-cons) (second value))))
(if matching-sublist (pushnew (second notify-cons) (rest matching-sublist))
(push (copy-list notify-cons) (second value)))))
......@@ -803,6 +803,39 @@ a separate object hierarchy." object self)))
(%unbind-dependent-slots% object slot :updating? updating?)))
(defun %unbind-dependent-slots% (object slot &key updating?)
(let ((current (gethash (list object slot) *unbound-slots*)))
(unless current
(setf (gethash (list object slot) *unbound-slots*) t)
(if (slot-exists-p object slot)
(let ((slot-value (slot-value object slot)))
(when (not (eq (first (ensure-list slot-value)) 'gdl-rule::%unbound%))
(when (and *eager-setting-enabled?* (null (second slot-value)))
(push (list object slot) *leaf-resets*))
(let ((list-or-hash (second (slot-value object slot))))
(if (listp list-or-hash)
(mapc #'(lambda(notify-cons)
(destructuring-bind (node . messages) notify-cons
(mapc #'(lambda(message)
(%unbind-dependent-slots% node message :updating? updating?)) messages))) list-or-hash)
(maphash #'(lambda(node messages)
(mapc #'(lambda(message)
(%unbind-dependent-slots% node message :updating? updating?)) messages)) list-or-hash)))
(setf (second (slot-value object slot)) nil)
(when (not (third slot-value))
(setf (slot-value object slot)
(if (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))
(the-object object (unbind-remote-slot slot)))))))
#+nil
(defun %unbind-dependent-slots% (object slot &key updating?)
(let ((current (gethash (list object slot) *unbound-slots*)))
......
......@@ -162,7 +162,9 @@ in the applicable lens for html-format."
("String or nil. Names the value of class attribute for the body tag. Default is nil."
body-class nil)
(body-onload nil)
("String of Javascript or nil. This Javascript will go into the :onload event of the body.
Default is nil."
body-onload nil)
("String or nil. Contains the string for the doctype at the top of the document. Default is:
......
......@@ -233,7 +233,7 @@ instance at what time should the recovery instance expire?"
;;
;;
(with-http-response (req ent :response *response-moved-permanently*)
(with-http-response (req ent :response *response-found*)
(setf (reply-header-slot-value req :cache-control) "no-cache")
(setf (reply-header-slot-value req :pragma) "no-cache")
......@@ -372,7 +372,7 @@ package-qualified object name\")
(the-object object set-time-last-touched!)
(the-object object (set-remote-host! req :original? t)))
(with-http-response (req ent :response *response-moved-permanently*)
(with-http-response (req ent :response *response-found*)
(setf (reply-header-slot-value req :location)
(format nil "~a" (the-object (first root-part-and-version) url)))
(setf (reply-header-slot-value req :cache-control) "no-cache")
......
......@@ -120,10 +120,11 @@ and this is defaulted to t, except for merged-solid where we default this to nil
(error message
(1- (the first-brep regions number-of-elements))))))
(let (merge-container current-breps (current-brep (the first-brep %native-brep%)))
(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)
......@@ -152,11 +153,14 @@ and this is defaulted to t, except for merged-solid where we default this to nil
)))
((:merge)
(format t "Merging ~s into merge object~%" (the-object other-brep root-path))
(setq current-brep (do-boolean-merge-operation *geometry-kernel* merge-container
(the operation) (the manifold?)
:make-manifold? (the make-manifold?)
:sew-and-orient? (the sew-and-orient?))))
(let ((try-manifold? (= count (1- length))))
(format t "Merging ~s into merge object~a~%"
(the-object other-brep root-path)
(if try-manifold? ", trying to make manifold..." ""))
(setq current-brep (do-boolean-merge-operation *geometry-kernel* merge-container
(the operation) try-manifold?
:make-manifold? try-manifold?
:sew-and-orient? (the sew-and-orient?)))))
(:extract_separate
(setq current-breps (do-boolean-separate-operation *geometry-kernel*
......
......@@ -22,47 +22,58 @@
(in-package :surf)
(define-object extruded-solid (brep)
:input-slots ("GDL Curve object. The profile to be extruded into a solid." profile
:input-slots ("GDL Curve object. The profile to be extruded into a solid."
profile
("3D Vector. The direction of extrusion. Defaults
("3D Vector. The direction of extrusion. Defaults
to (the (face-normal-vector :top))"
axis-vector (the (face-normal-vector :top)))
axis-vector (the (face-normal-vector :top)))
("Number. The distance to extrude the profile along the axis-vector.
("Number. The distance to extrude the profile along the axis-vector.
Defaults to (the height)."
distance (the height))
distance (the height))
("Number. Overall tolerance for the created brep solid. Defaults to nil.
("Number. Overall tolerance for the created brep solid. Defaults to nil.
Note that a value of nil indicates for SMLib a value of 1.0e-05 of the longest diagonal
length of the brep."
brep-tolerance nil))
brep-tolerance nil))
:computed-slots ((%native-brep%
(let ((brep (make-brep *geometry-kernel*
:tolerance (the brep-tolerance))))
(add-linear-sweep-primitive
*geometry-kernel* brep
(if (listp (the profile))
(mapcar #'(lambda(curve)
(the-object curve (copy-new :finalize? nil)))
(the profile))
(list (the profile (copy-new :finalize? nil))))
(if (or (and (atom (the profile))(the profile closed?))
(consp (the profile))
(and (atom (the profile))(> (the profile degree) 1)))
(let ((brep (make-brep *geometry-kernel*
:tolerance (the brep-tolerance))))
(add-linear-sweep-primitive
*geometry-kernel* brep
(if (listp (the profile))
(mapcar #'(lambda(curve)
(the-object curve (copy-new :finalize? nil)))
(the profile))
(list (the profile (copy-new :finalize? nil))))
(the axis-vector) (the distance))
(the axis-vector) (the distance))
;;(iwbrep-sew-faces *geometry-kernel* brep)
(tag-edges *geometry-kernel* brep (get-long *geometry-kernel* brep))
(tag-edges *geometry-kernel* brep (get-long *geometry-kernel* brep))
(unless (the brep-tolerance)
(brep-reset-tolerance *geometry-kernel* brep))
brep)
(the ruled-surface brep %native-brep%))))
(unless (the brep-tolerance)
(brep-reset-tolerance *geometry-kernel* brep))
brep)))
:hidden-objects
((decomposed-profile :type 'decomposed-curves
:curve-in (the profile))))
:curve-in (the profile))
(boxed-profile :type 'boxed-curve
:curve-in (the profile)
:center (translate-along-vector (the profile center)
(the axis-vector)
(the distance)))
(ruled-surface :type 'ruled-surface
:curve-1 (the profile)
:curve-2 (the boxed-profile))))
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