Commit 71d5acb9 authored by Dave Cooper's avatar Dave Cooper

merged patches to support growlr.

parent 8120c87c
......@@ -121,6 +121,7 @@ If you are interested in this effort we would love to hear from you at open-sour
#:+kappa+
#:+phi+
#:2pi
#:add-godparent
#:alist2plist
#:always
#:append-elements
......
......@@ -383,8 +383,20 @@ You have a dependency on caffeine. Your children are your dependants.
#+nil
(defun same-tree? (obj1 obj2) (eql (gdl-acc::%root% obj1) (gdl-acc::%root% obj2)))
(defun same-tree? (obj1 obj2)
(or (eql (gdl-acc::%root% obj1) (gdl-acc::%root% obj2))
(let ((root-1 (gdl-acc::%root% obj1)) (root-2 (gdl-acc::%root% obj2)))
(let ((god-parents-1 (gdl-acc::%god-parents% root-1))
(god-parents-2 (gdl-acc::%god-parents% root-2)))
(member root-1 god-parents-2) (member root-2 god-parents-1)))))
(defun add-godparent (target new)
(pushnew new (gdl-acc::%god-parents% target)))
(defun merge-common-keys (plist)
;; FLAG - call recursively until no more non-standard keywords remain.
......
......@@ -31,10 +31,15 @@
:documentation (:description "Object mixed into the base-view to compute required values to provide
a rendered perspective view, as in VRML.")
:computed-slots
((camera-distance-discount 0.8))
:input-slots
(
(camera-distance-discount 0.8)
;;(camera-distance-discount 0.8)
"List of GDL Objects. Roots of the leaf objects to be displayed in this renderer view."
object-roots
......
......@@ -43,7 +43,8 @@
(warn "~&Please implement concatenate-fasls for the currently running lisp.~%")
;;
;; FLAG -- OBSOLETED by asdf/bundle:fasl-op and asdf/bundle:monolithic-fasl-op
;; FLAG -- OBSOLETED by asdf/bundle:compile-bundle-op and asdf/bundle:monolithic-compile-bundle-op
;; (except for current apparent bug where it leaves out a depended-upon uiop).
;;
(defun concatenate-fasls (files dest)
#-(or allegro lispworks sbcl ccl) (declare (ignore files dest))
......
......@@ -133,10 +133,30 @@ value of the image-format-selector, which itself defaults to :raphael."
(on-drop-function nil)
(on-touchmove-function nil))
(on-touchmove-function nil)
(viewport-js-text
(format nil "
function x3draw ()
{
if (x3dom.type != 'undefined') x3dom.reload();
var elem = document.getElementById('view-~(~a~)');
if (elem) elem.setAttribute('set_bind', 'true');
var x3dom1 = document.getElementById('x3dom-1');
if (x3dom1) xruntime= x3dom1.runtime;
xruntime.resetView();
}
x3draw();
" (the view-selector value)))
)
:computed-slots
((js-to-eval :parse :settable)
(js-always-to-eval nil)
......@@ -158,14 +178,14 @@ value of the image-format-selector, which itself defaults to :raphael."
(svg-string (if (the no-graphics?)
(with-cl-who-string ()
((:div :id "empty-viewport" :class "empty-viewport")
(:p (:h2 (str (the empty-display-list-message))))))
(str (the empty-display-list-message))))
(with-error-handling ()
(with-output-to-string (ss)
(with-format (svg ss
:background-color (the background-color)
:foreground-color (the foreground-color))
(write-the view-object cad-output))))))
("String of valid HTML. This can be used to
include the PNG or JPG raster-graphics of the geometry."
......@@ -226,6 +246,7 @@ bottom of the graphics inside a table."
This is not tested to see if it is part of the same object tree as current self."
dropped-object nil :settable)
(viewport-script
(progn
......@@ -234,25 +255,7 @@ This is not tested to see if it is part of the same object tree as current self.
(with-cl-who-string ()
(:div
((:script :type "text/javascript")
(fmt
"
function x3draw ()
{
if (x3dom.type != 'undefined') x3dom.reload();
var elem = document.getElementById('view-~(~a~)');
if (elem) elem.setAttribute('set_bind', 'true');
var x3dom1 = document.getElementById('x3dom-1');
if (x3dom1) xruntime= x3dom1.runtime;
//xruntime.resetView();
}
x3draw();
"
(the view-selector value)
)))))
(str (the viewport-js-text))))))
(t "")))))
......@@ -420,74 +423,61 @@ z-index: 1;
("Void. Writes an embedded X3D tag and included content for the <tt>view-object</tt> child of this object.
The <tt>view-object</tt> child should exist and be of type <tt>web-drawing</tt>."
embedded-x3dom-world
(&key (include-view-controls? nil))
embedded-x3dom-world
(&key (include-view-controls? nil))
(declare (ignore include-view-controls?))
(declare (ignore include-view-controls?))
;; (the (restore-slot-default! :js-to-eval))
;; (the (restore-slot-default! :js-to-eval))
(cl-who:with-html-output (*stream*)
(with-cl-who ()
(when (typep (the :view-object) 'null-part)
(error "A valid :view-object of type web-drawing is required in the sheet
(when (typep (the :view-object) 'null-part)
(error "A valid :view-object of type web-drawing is required in the sheet
to call the :write-embedded-x3d-world function."))
(cond ((the no-graphics?)
#+nil
(and (null (the :view-object :object-roots))
(null (the :view-object :objects)))
(html-stream *stream*
((:table :cellspacing 0 :cellpadding 0 :bgcolor :white)
(:tr
((:td :width (the :view-object :width) :height
(the :view-object :height) :align :center :valign :center)
(:big (:b "No Graphics Object Specified")))))))
(t
(let ((*display-controls* (the display-controls-hash)))
(with-cl-who ()
(:span
((:|X3D| :id "x3dom-1" :style "background: #d3d3d3"
:width (format nil "~apx" (the view-object page-width))
:height (format nil "~apx" (the view-object page-length))
)
(:|Scene|
(cond ((the no-graphics?)
(htm
((:div :id "empty-viewport" :class "empty-viewport")
(str (the empty-display-list-message)))))
(t
(let ((*display-controls* (the display-controls-hash)))
(htm
(:span
((:|X3D| :id "x3dom-1" :style "background: #d3d3d3"
:width (format nil "~apx" (the view-object page-width))
:height (format nil "~apx" (the view-object page-length))
)
(:|Scene|
((:|navigationinfo| :|id| "navi" :|transitionTime| "0.0"
))
((:|navigationinfo| :|id| "navi" :|transitionTime| "0.0"
))
(with-format (x3d *stream*)
(let ((*onclick-function* (the onclick-function)))
(write-the view-object cad-output))))))))))))
(with-format (x3d *stream*)
(let ((*onclick-function* (the onclick-function)))
(write-the view-object cad-output))))))))))))
(raster-graphics
()
(when (typep (the :view-object) 'null-part)
(error "A valid :view-object of type web-drawing is
()
(when (typep (the :view-object) 'null-part)
(error "A valid :view-object of type web-drawing is
required in the sheet to call the :write-geometry method."))
(with-cl-who ()
(cond ((and (null (the :view-object :object-roots)) (null (the :view-object :objects)))
(htm ((:table :border 1 :cellspacing 0 :cellpadding 0 :bgcolor :white)
(:tr
((:td :width (the :view-object :width) :height (the :view-object :length)
:align :center :valign :center)
(:big (:b "No Graphics Object Specified")))))))
(with-cl-who ()
(cond ((the no-graphics?)
(htm ((:div :id "empty-viewport" :class "empty-viewport")
(str (the empty-display-list-message)))))
((typep (the image-url) 'error)
(the (set-slot! :view-toggle nil))
(write-the geometry-error))
((typep (the image-url) 'error)
(the (set-slot! :view-toggle nil))
(write-the geometry-error))
(t
(let ((image-url (the image-url)))
(htm ((:table :border 0 :cellspacing 0 :cellpadding 0)
(:tr
((:td) ;;:bgcolor :yellow) --FLAG! -- SvdE @ 13-08-09 -- removed bgcolor to blend in with viewport
((:img :id "myimage"
:style "cursor: crosshair;"
:src image-url
:onclick (the (gdl-ajax-call :function-key :dig-point))
:border 0 :width (the :view-object :page-width)
:height (the :view-object :page-length))))))))))))))
(t
(let ((image-url (the image-url)))
(htm ((:img :id "myimage"
:style "cursor: crosshair;"
:src image-url
:onclick (the (gdl-ajax-call :function-key :dig-point))
:border 0 :width (the :view-object :page-width)
:height (the :view-object :page-length)))))))))))
......@@ -28,7 +28,7 @@
()
(let ((view-center (if (the user-center)
(scalar*vector (the user-scale) (the user-center))
(make-point 0 0 0))))
(make-point 0 0 0))))
(with-format-slots (view)
(let ((parent-scale (when view (the-object view view-scale-total))))
(mapc #'(lambda(child-view)
......@@ -36,21 +36,26 @@
(when parent-scale (the-object child-view (set-slot! :user-scale parent-scale)))
(let ((width (the-object child-view width))
(length (the-object child-view length)))
(with-html-output (*stream*)
((:div
:onmousedown (when (the parent vector-graphics-onclick?)
(the parent (gdl-ajax-call :function-key :dig-point :bashee (the parent)
:respondent (the parent :respondent)))))
((:svg :id "svg-1" :viewBox (format nil "0 0 ~a ~a" width length) :width width :height length)
(with-translated-state (:svg (make-point (- (get-x view-center))
(- (get-y view-center))))
(write-the-object child-view cad-output)))
((:script :type "text/javascript")
"
var panZoomSVG1 = svgPanZoom('#svg-1', {
(with-html-output (*stream*)
((:div
:width "100%" :height "100%"
:onmousedown (when (the parent vector-graphics-onclick?)
(the parent (gdl-ajax-call :function-key :dig-point :bashee (the parent)
:respondent (the parent :respondent)))))
((:svg :id "svg-1" :viewBox (format nil "0 0 ~a ~a" width length)
:width width
:height length
)
(with-translated-state (:svg (make-point (- (get-x view-center))
(- (get-y view-center))))
(write-the-object child-view cad-output)))
((:script :type "text/javascript")
"
panZoomSVG1 = svgPanZoom('#svg-1', {
zoomEnabled: true,
controlIconsEnabled: true,
preventMouseEventsDefault: false,
......@@ -58,8 +63,8 @@
minZoom: 0.01,
maxZoom: 100,
center: true});"))))
(when parent-scale (the-object child-view (set-slot! :user-scale old-scale)))))
(when parent-scale (the-object child-view (set-slot! :user-scale old-scale)))))
(the views))))))))
......
;;"(:bordeaux-threads :drakma :glisp #+zacl :aserve #-zacl :paserve :yason)"
(:bordeaux-threads :drakma :glisp #-allegro :zacl-aserve #+allegro :aserve :yason)
(:bordeaux-threads:glisp #-allegro :zacl-aserve #+allegro :aserve :yason)
......@@ -5,7 +5,7 @@
"Dave Cooper, Genworks International" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20170802" :depends-on
(:bordeaux-threads :drakma :glisp #-allegro :zacl-aserve #+allegro :aserve :yason)
(:bordeaux-threads :glisp #-allegro :zacl-aserve #+allegro :aserve :yason)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-unicode :defsystem-depends-on #+asdf-unicode ()
#+asdf-encodings :encoding #+asdf-encodings :utf-8
......
S 1
1H,,1H;,27H/Users/dcooper8/tmp/g257508,27H/Users/dcooper8/tmp/g257508, G 1
1H,,1H;,28H/Users/dcooper8/tmp/g2151696,28H/Users/dcooper8/tmp/g2151696,G 1
23HHarmonyWare Translators,23HHarmonyWare IGES v2.0.5,32,38,6,308,15,, G 2
1.,1,2HIN,1,1.,15H20180805.120734,1.D-6,21.3205116838006,,,11,0,15H20180G 3
805.120734; G 4
1.,1,2HIN,1,1.,15H20181010.133004,1.D-6,21.3205116838006,,,11,0,15H20181G 3
010.133004; G 4
502 1 0 0 0 0 0 000010000D 1
502 0 0 16 1 0D 2
124 17 0 0 0 0 0 000000000D 3
......
S 1
1H,,1H;,27H/Users/dcooper8/tmp/g257498,27H/Users/dcooper8/tmp/g257498, G 1
1H,,1H;,28H/Users/dcooper8/tmp/g2151686,28H/Users/dcooper8/tmp/g2151686,G 1
23HHarmonyWare Translators,23HHarmonyWare IGES v2.0.5,32,38,6,308,15,, G 2
1.,1,2HIN,1,1.,15H20180805.120730,1.D-6,20.7712135760006,,,11,0,15H20180G 3
805.120730; G 4
1.,1,2HIN,1,1.,15H20181010.133000,1.D-6,20.7712135760006,,,11,0,15H20181G 3
010.133000; G 4
502 1 0 0 0 0 0 000010000D 1
502 0 0 442 1 0D 2
110 443 0 0 0 0 0 000010000D 3
ISO-10303-21;
HEADER;
FILE_DESCRIPTION ((), '1');
FILE_NAME ('/Users/dcooper8/tmp/g257940', '2018-08-05T12:09:02', ('Unknown'), ('Unknown'), 'HarmonyWare STEP v2.0.5', 'HarmonyWare Translators', '');
FILE_NAME ('/Users/dcooper8/tmp/g2151873', '2018-10-10T13:30:20', ('Unknown'), ('Unknown'), 'HarmonyWare STEP v2.0.5', 'HarmonyWare Translators', '');
FILE_SCHEMA (('CONFIG_CONTROL_DESIGN'));
ENDSEC;
......@@ -26462,9 +26462,9 @@ DATA;
#264330 = PRODUCT_DEFINITION_FORMATION_WITH_SPECIFIED_SOURCE ('', '', #264260, .NOT_KNOWN.);
#264340 = APPROVAL_STATUS ('approved');
#264350 = APPROVAL (#264340, '');
#264360 = CALENDAR_DATE (2018, 5, 8);
#264360 = CALENDAR_DATE (2018, 10, 10);
#264370 = COORDINATED_UNIVERSAL_TIME_OFFSET (0, $, .AHEAD.);
#264380 = LOCAL_TIME (12, 9, 2., #264370);
#264380 = LOCAL_TIME (13, 30, 20., #264370);
#264390 = DATE_AND_TIME (#264360, #264380);
#264400 = APPROVAL_DATE_TIME (#264390, #264350);
#264410 = APPROVAL_ROLE ('');
......@@ -26487,9 +26487,9 @@ DATA;
#264580 = SECURITY_CLASSIFICATION ('', '', #264570);
#264590 = APPROVAL_STATUS ('approved');
#264600 = APPROVAL (#264590, '');
#264610 = CALENDAR_DATE (2018, 5, 8);
#264610 = CALENDAR_DATE (2018, 10, 10);
#264620 = COORDINATED_UNIVERSAL_TIME_OFFSET (0, $, .AHEAD.);
#264630 = LOCAL_TIME (12, 9, 2., #264620);
#264630 = LOCAL_TIME (13, 30, 20., #264620);
#264640 = DATE_AND_TIME (#264610, #264630);
#264650 = APPROVAL_DATE_TIME (#264640, #264600);
#264660 = APPROVAL_ROLE ('');
......@@ -26499,9 +26499,9 @@ DATA;
#264700 = APPROVAL_PERSON_ORGANIZATION (#264690, #264600, #264660);
#264710 = CC_DESIGN_APPROVAL (#264600, (#264580));
#264720 = DATE_TIME_ROLE ('classification_date');
#264730 = CALENDAR_DATE (2018, 5, 8);
#264730 = CALENDAR_DATE (2018, 10, 10);
#264740 = COORDINATED_UNIVERSAL_TIME_OFFSET (0, $, .AHEAD.);
#264750 = LOCAL_TIME (12, 9, 2., #264740);
#264750 = LOCAL_TIME (13, 30, 20., #264740);
#264760 = DATE_AND_TIME (#264730, #264750);
#264770 = CC_DESIGN_DATE_AND_TIME_ASSIGNMENT (#264760, #264720, (#264580));
#264780 = PERSON_AND_ORGANIZATION_ROLE ('classification_officer');
......@@ -26514,9 +26514,9 @@ DATA;
#264850 = PRODUCT_DEFINITION ('', '', #264330, #264840);
#264860 = APPROVAL_STATUS ('approved');
#264870 = APPROVAL (#264860, '');
#264880 = CALENDAR_DATE (2018, 5, 8);
#264880 = CALENDAR_DATE (2018, 10, 10);
#264890 = COORDINATED_UNIVERSAL_TIME_OFFSET (0, $, .AHEAD.);
#264900 = LOCAL_TIME (12, 9, 2., #264890);
#264900 = LOCAL_TIME (13, 30, 20., #264890);
#264910 = DATE_AND_TIME (#264880, #264900);
#264920 = APPROVAL_DATE_TIME (#264910, #264870);
#264930 = APPROVAL_ROLE ('');
......@@ -26526,9 +26526,9 @@ DATA;
#264970 = APPROVAL_PERSON_ORGANIZATION (#264960, #264870, #264930);
#264980 = CC_DESIGN_APPROVAL (#264870, (#264850));
#264990 = DATE_TIME_ROLE ('creation_date');
#265000 = CALENDAR_DATE (2018, 5, 8);
#265000 = CALENDAR_DATE (2018, 10, 10);
#265010 = COORDINATED_UNIVERSAL_TIME_OFFSET (0, $, .AHEAD.);
#265020 = LOCAL_TIME (12, 9, 2., #265010);
#265020 = LOCAL_TIME (13, 30, 20., #265010);
#265030 = DATE_AND_TIME (#265000, #265020);
#265040 = CC_DESIGN_DATE_AND_TIME_ASSIGNMENT (#265030, #264990, (#264850));
#265050 = PERSON_AND_ORGANIZATION_ROLE ('creator');
......@@ -57,4 +57,4 @@
)))
;;(register-test-definition 'separated-solid-test)
(register-test-definition 'separated-solid-test)
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