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

added partial text-line support for x3d, added anchor support for x3d and x3dom.

parent cfbf6c9e
......@@ -64,6 +64,7 @@ temporary directory, returned by <tt>(glisp:temporary-folder)</tt>."
(asdf:map-systems #'asdf:clear-system)
(asdf:clear-output-translations)
(asdf:disable-output-translations)
))
......
......@@ -192,7 +192,9 @@ to the src/ directory distributed with GDL.
arm-angle-right
arm-angle-left
pincer-distance-right
pincer-distance-left)
pincer-distance-left
shininess transparency
)
:computed-slots
((display-controls (list :color :orange :line-thickness 2
......@@ -217,7 +219,18 @@ to the src/ directory distributed with GDL.
(the (:face-normal-vector :top))))
:pass-down (head-angle torso-type
arm-angle-right arm-angle-left
pincer-distance-left pincer-distance-right))))
pincer-distance-left pincer-distance-right))
(center-sphere :type 'sphere :radius 0.1)
(rob-text :type 'general-note
:orientation (alignment :top (the (face-normal-vector :rear)))
:strings "Bob"
:center (the center))
))
(define-object robot-body (base-object)
......@@ -282,6 +295,9 @@ to the src/ directory distributed with GDL.
(the (:face-normal-vector :right))
(the :head-angle)
(the (:face-normal-vector :top)))))
))
......
......@@ -162,7 +162,9 @@ o filter inspector slots to local slots
:onclick-function #'(lambda(object)
(the (gdl-ajax-call
:function-key :perform-action!
:arguments (list object))))
:arguments (list object)
:one-arg? (member (the-child image-format) (list :x3d :x3dom))
)))
:tatu-root self)
(inspector :type 'inspector
......
......@@ -234,7 +234,9 @@
#:write-the
#:write-the-object
#:xml-reader
#:^2))
#:^2
#:*onclick-function*))
(defpackage :gdl-toplevel (:use))
(defpackage :gdl-rule (:size 25) (:use)
......
......@@ -131,6 +131,8 @@ And really this should be done in the post-load-form of your build."))
:directory (butlast (pathname-directory glisp:*gdl-program-home*))
:defaults glisp:*gdl-program-home*))
(glisp:set-default-float-format)
(glisp:set-defpackage-behavior)
;;
;; FLAG -- don't do this here. Don't want to mess up people's
......@@ -145,7 +147,7 @@ And really this should be done in the post-load-form of your build."))
;;
;;(setq ql:*quicklisp-home* (merge-pathnames "quicklisp/" glisp:*gdl-home*))
;;
(asdf:initialize-output-translations)
(glisp:set-default-package)
......
......@@ -283,3 +283,6 @@ Defaults to :error.")
"Boolean. Determines whether the system keeps track of previous slot values
(accessible with previous-value function) after bashings are done. Leave this
set to nil to improve memory performance.")
(defparameter *onclick-function* nil)
......@@ -24,10 +24,13 @@
(define-format x3d (vrml))
(defparameter *onclick* nil)
(define-lens (x3d base-drawing)()
:output-functions
((cad-output
()
(let (
;;(req (when (find-package :gwl) (symbol-value (read-from-string "gwl:*req*"))))
)
......@@ -148,7 +151,8 @@
(:|Transform| :translation (when (not (every #'zerop (list x y z)))
(format nil "~3,7f ~3,7f ~3,7f" x y z))
:rotation (when rotation
(format nil "~3,7f ~3,7f ~3,7f ~3,7f" (get-x rotation) (get-y rotation) (get-z rotation) (get-w rotation)))
(format nil "~3,7f ~3,7f ~3,7f ~3,7f" (get-x rotation) (get-y rotation)
(get-z rotation) (get-w rotation)))
(:|Group| (write-the shape))))))
(scene
......@@ -186,14 +190,10 @@
(format nil "~3,7f ~3,7f ~3,7f ~3,7f"
(get-x rotation) (get-y rotation) (get-z rotation) (get-w rotation))))
(if (and (find-package :gwl) (symbol-value (read-safe-string "gwl::*onclick-function*")))
(cl-who:htm
((:|Anchor| :url (format nil "javascript:event=null;~a"
(funcall (symbol-value (read-safe-string "gwl::*onclick-function*")) self)))
(write-the shape)))
(write-the shape)))
;;
;; FLAG -- revert to proper conditional
;;
(write-the shape))
(when (and (typep self 'outline-specialization-mixin)
(not (ignore-errors (typep self (read-from-string "surf:surface"))))
......@@ -228,19 +228,29 @@
;;(rotation (matrix-to-rotation orientation))
(x (get-x center)) (y (get-y center)) (z (get-z center)))
;;
;; FLAG -- factor out the redundant calls and call directly to
;; cad-output, which will itself call to the shape.
;;
(cl-who:with-html-output (*stream* nil :indent nil)
((:|Transform| :|translation| (unless (every #'zerop (list x y z))
(format nil "~3,7f ~3,7f ~3,7f" x y z)))
((:|Transform| :|rotation| (when rotation
(format nil "~3,7f ~3,7f ~3,7f ~3,7f"
(get-x rotation) (get-y rotation) (get-z rotation) (get-w rotation))))
(format nil "~3,7f ~3,7f ~3,7f ~3,7f"
(get-x rotation) (get-y rotation) (get-z rotation) (get-w rotation)))
)
(if (null (the children))
(if (and (find-package :gwl) (symbol-value (read-safe-string "gwl::*onclick-function*")))
(if (and (find-package :gwl) *onclick-function*)
(cl-who:htm
((:|Anchor| :url (format nil "javascript:event=null;~a"
(funcall (symbol-value (read-safe-string "gwl::*onclick-function*")) self)))
((:|Anchor| :url (format nil "javascript:~a;"
(funcall *onclick-function* self)))
(write-the shape)))
(write-the shape))
......@@ -403,10 +413,11 @@
(with-corrected-orientation
(:|Shape|
(:|Appearance| (write-the material-properties))
(:|Box| :|size| (format nil "~a ~a ~a"
(to-double-float (the width))
(to-double-float (the length))
(to-double-float (the height)))))))))
((:|Box|
:|size| (format nil "~a ~a ~a"
(to-double-float (the width))
(to-double-float (the length))
(to-double-float (the height))))))))))
......@@ -465,3 +476,45 @@
(the ifs-array)))))))))))
(define-lens (x3d text-line)()
:output-functions
((shape
()
(let ((font-size (the character-size)))
(declare (ignore font-size))
(cl-who:with-html-output (*stream* nil :indent t)
(:|Shape|
(:|Appearance| (write-the material-properties))
(format *stream* "<Text string='\"~a\"' solid='false'>
<FontStyle size='1' justify='MIDDLE'></FontStyle>
</Text>" (the %text-to-draw%))))
#+nil
(cl-who:with-html-output (*stream* nil :indent t)
(let ((center (the center)))
(setq center (the (global-to-local center)))
(cl-who:htm ((:|Transform| #+nil :|translation|
#+nil
(format nil "~3,7f, ~3,7f, ~3,7f"
(- (get-x center))
(- (get-y center))
(- (get-z center)))
(:|Shape|
(:|Appearance| (write-the material-properties))
(format *stream* "<Text string='~a' solid='false'>
</Text>" (the %text-to-draw%))
#+nil
((:|Text| :|string| (the %text-to-draw%))
)))))))))))
......@@ -179,3 +179,5 @@ the value of this parameter at your own risk.")
(push #'initialize-geom-base *gdl-init-functions*)
(setq cl-who:*attribute-quote-char* #\")
\ No newline at end of file
......@@ -343,24 +343,26 @@ to call the :write-embedded-x3d-world function."))
(t
(print-variables (the onclick-function))
(with-cl-who ()
(:p
((:|X3D| :id "the_element"
:swfpath "/static/3rdpty/x3dom/x3dom.swf"
;;:width "100%"
;;:height "100%"
:width (the view-object page-width)
:height (the view-object page-length)
)
(:|Scene|
(with-format (x3d *stream*)
(let ((*onclick-function* (the onclick-function)))
(write-the view-object cad-output))))))
((:span :style "cursor: pointer;")
((:|X3D| :id "the_element"
:swfpath "/static/3rdpty/x3dom/x3dom.swf"
;;:width "100%"
;;:height "100%"
:width (the view-object page-width)
:height (the view-object page-length)
)
(:|Scene|
(with-format (x3d *stream*)
(let ((*onclick-function* (the onclick-function)))
(write-the view-object cad-output)))))))
((:script :type "text/javascript"
:src "/static/3rdpty/x3dom/x3dom.js" :id "xdom_script"))
(when (the x3dom-view-controls?)
(htm (:tr (:td ((:span :style "color: blue; cursor: pointer;"
:onclick "document.getElementById('the_element').runtime.showAll();")
......
......@@ -22,9 +22,6 @@
(in-package :gwl)
(defparameter *onclick-function* nil)
(define-object geometry-view-mixin ()
:input-slots
......@@ -105,9 +102,10 @@
(let ((*onclick-function* (the onclick-function)))
(let ((*stream* reply-stream))
(with-cl-who ()
(:|scene|
(with-format (x3d reply-stream :use-bsplines? (the use-bsplines?))
(write-the view-object cad-output))))))))))))
(:|X3D|
(:|Scene|
(with-format (x3d reply-stream :use-bsplines? (the use-bsplines?))
(write-the view-object cad-output)))))))))))))
(push url (gethash (make-keyword (the instance-id)) *url-hash-table*)) url) :uncached)
......
......@@ -434,7 +434,11 @@ UI specific jQuery Layout JavaScript."
((:script :type "text/javascript"
:src "/static/3rdpty/jquery/js/jquery-ui-current.min.js"))
;;
;; FLAG -- put this back after re-arranging tasty color schemes to avoid the invisible menus.
;;
#+nil
((:link :rel "stylesheet" :href "http://code.jquery.com/ui/1.8.21/themes/base/jquery-ui.css" :media "all"))
((:script :type "text/javascript"
......
......@@ -318,12 +318,84 @@ running the Javascript interpreter to evaluate (the js-to-eval), if any.
function-key
arguments
form-controls
(asynch? t))
(asynch? t)
(one-arg? nil)
)
(let ((string-1 (the (encode-ajax-args :bashee bashee
:respondent respondent
:function-key function-key
:arguments arguments)))
(string-2 (let ((string
(if form-controls
(string-append
"&fields=' + "
(format
nil "encode64('(' + ~{~a~^ + ' ' + ~} + ')').replace(/=/g,'')"
(mapcar
#'(lambda(form-control)
(when *debug?* (print-variables form-control))
(string-append
(if (not (or (typep form-control 'radio-form-control)
(typep form-control 'menu-form-control)))
(format nil "'~s ' + "
(the-object form-control field-name)) "")
(or
(typecase form-control
(radio-form-control
(format nil "~{~a~^ + ~}"
(mapcar
#'(lambda(n)
(format nil "' :|radio-~a-~a| (' + doublequote + document.getElementById('~a-~a').value + doublequote + ' ' + doublequote + document.getElementById('~a-~a').checked + doublequote + ')' "
(the-object form-control field-name) n
(the-object form-control id) n
(the-object form-control id) n))
(list-of-numbers
0
(1- (length
(plist-keys
(the-object form-control
effective-choice-plist))))))))
(checkbox-form-control
(format nil "doublequote + encode64(document.getElementById('~a').value).replace(/=/g,'') + doublequote + ' ~s-checkedp ' + doublequote + document.getElementById('~a').checked + doublequote"
(the-object form-control id)
(the-object form-control field-name)
(the-object form-control id)))
(menu-form-control
(format nil "collectMenuSelections(document.getElementById('~a'))"
(the-object form-control id))))
#+nil
(format nil "doublequote + document.getElementById('~a').value + doublequote"
(the-object form-control id))
(format nil "doublequote + encode64(document.getElementById('~a').value).replace(/=/g,'') + doublequote"
(the-object form-control id)))))
(ensure-list form-controls))))
"'"
)))
string))
(string-3 (if asynch? "true" "false")))
(if one-arg?
(format nil "gdlAjax1('args=~a~a);" string-1 string-2)
(format nil "gdlAjax(event,'args=~a~a,~a);" string-1 string-2 string-3)))
#+nil
(format
nil "gdlAjax(event, 'args=~a~a, ~a);"
nil "gdlAjax(event,'args=~a~a,~a);"
(the (encode-ajax-args :bashee bashee
:respondent respondent
:function-key function-key
......
......@@ -78,7 +78,10 @@ return y;
}
function gdlAjax1 (params)
{
gdlAjax(null, params, true);
}
function gdlAjax (evt, params, asynch)
{
......
(in-package :gdl-lift-tests)
(define-object general-note-test (base-object)
:objects
(
(center-sphere :type 'sphere
:radius .1)
(box :type 'box :length 10 :width 10 :height 10
:display-controls (list :transparency 0.7 :color :orange))
(note :type 'general-note
:display-controls (list :color (list .32 .54 .26)
:specular-color (list 0.46 0.46 0.46)
:ambient-intensity 0.0933)
:strings "Hey Now")
(kid :type 'general-note-kid
:center (translate (the center) :rear 10))
))
(define-object general-note-kid (base-object)
:objects
((center-sphere :type 'sphere
:radius .1)
(box :type 'box :length 10 :width 10 :height 10
:display-controls (list :transparency 0.7 :color :orange))
(note :type 'general-note
:display-controls (list :color (list .32 .54 .26)
:specular-color (list 0.46 0.46 0.46)
:ambient-intensity 0.0933)
:strings "Hey Now")
))
\ No newline at end of file
......@@ -745,3 +745,20 @@
(define-smlib-wrapper make-extend-curve (curve &key distance distance-type extending-from continuity))
(define-smlib-wrapper approximated-compatible-curves (curve-list &key length tolerance))
(define-smlib-wrapper make-tx-assembly-instance (&key name))
(define-smlib-wrapper tx-assembly-add-subassembly (parent-assembly-instance-pointer
child-assembly-instance-pointer))
(define-smlib-wrapper tx-assembly-add-brep (assembly-instance-pointer
native-brep
&key name red green blue))
(define-smlib-wrapper tx-assembly-add-curve (assembly-instance-pointer
native-curve
&key name red green blue))
(define-smlib-wrapper tx-assembly-add-point (assembly-instance-pointer
point
&key name red green blue))
\ No newline at end of file
......@@ -24,21 +24,6 @@
(eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload :uffi))
;;
;; FLAG -- make higher-level generic constructor for a translator assembly object
;;
(defun make-assembly-instance (&key name)
(let ((ai (smlib::tag-pointer (smlib::new-hwstdautoptr-hwassemblyinstance) 'smlib::hwstdautoptr-hwassemblyinstance)))
(smlib::hwassemblyinstance-init ai
(uffi:with-cstring (cstring name)
cstring)
(uffi:with-cstring (cstring name)
cstring))
(smlib::finalize ai #'(lambda(obj)
(smlib::delete-hwstdautoptr-hwassemblyinstance obj)))
ai))
(define-lens (nurbs vanilla-mixin)()
:output-functions
......@@ -49,7 +34,9 @@
(write-the cad-output-assembly-tree))))
(cad-output-assembly-tree (&optional (assembly-instance (let ((assembly (make-assembly-instance :name (the strings-for-display))))
(cad-output-assembly-tree (&optional (assembly-instance (let ((assembly (make-tx-assembly-instance
*geometry-kernel*
:name (the strings-for-display))))
(set-format-slot assembly assembly)
assembly)))
......@@ -61,19 +48,14 @@
;;
;; FLAG -- add object also in case there is actual geometry here.
;;
(let ((child-assembly-instance (make-assembly-instance :name (the-object child strings-for-display))))
(let ((child-assembly-instance (make-tx-assembly-instance
*geometry-kernel*
:name (the-object child strings-for-display))))
(write-the-object child (cad-output-assembly-tree child-assembly-instance))
(smlib::hwassembly-addsubassembly (smlib::hwstdautoptr-hwassemblyinstance-getassembly
assembly-instance)
child-assembly-instance)
#+nil
(let ((new-one (smlib::tag-pointer (smlib::new-hwstdautoptr-hwassemblyinstance) 'smlib::hwstdautoptr-hwassemblyinstance)))
(smlib::hwassemblyinstance-collapseunneededlevels assembly-instance new-one)
(setq assembly-instance new-one))
(tx-assembly-add-subassembly *geometry-kernel*
assembly-instance child-assembly-instance))
)
;;
;; Add objects
......@@ -100,28 +82,24 @@
:output-functions
((cad-output-assembly (assembly-instance)
(let ((color (lookup-color (getf (the display-controls) :color))))
(smlib::hwassembly-addbrep (smlib::hwstdautoptr-hwassemblyinstance-getassembly assembly-instance)
(the %native-brep%)
(uffi:with-cstring (cstring (the strings-for-display))
cstring)
(to-double-float (get-x color))
(to-double-float (get-y color))
(to-double-float (get-z color)))))))
(tx-assembly-add-brep *geometry-kernel*
assembly-instance
(the %native-brep%)
:name (the strings-for-display)
:red (get-x color)
:green (get-y color)
:blue (get-z color))))))
(define-lens (nurbs curve) ()
:output-functions
((cad-output-assembly (assembly-instance)
(let ((color (lookup-color (getf (the display-controls) :color))))
(smlib::hwassembly-addcurve
(smlib::hwstdautoptr-hwassemblyinstance-getassembly assembly-instance)
(the native-curve-iw)
(uffi:with-cstring (cstring (the strings-for-display))
cstring)
(to-double-float (get-x color))
(to-double-float (get-y color))
(to-double-float (get-z color)))))))
(tx-assembly-add-curve *geometry-kernel* assembly-instance
(the native-curve-iw)
:name (the strings-for-display)
:red (get-x color)
:green (get-y color)
:blue (get-z color))))))
......@@ -129,16 +107,12 @@
:output-functions
((cad-output-assembly (assembly-instance)
(let ((color (lookup-color (getf (the display-controls) :color))))
(smlib::hwassembly-addpoint
(smlib::hwstdautoptr-hwassemblyinstance-getassembly assembly-instance)
(smlib::iw-make-point3d (get-x (the center))
(get-y (the center))
(get-z (the center)))
(uffi:with-cstring (cstring (the strings-for-display))
cstring)
(to-double-float (get-x color))
(to-double-float (get-y color))
(to-double-float (get-z color)))))))
(tx-assembly-add-point *geometry-kernel* assembly-instance
(the center)
:name (the strings-for-display)
:red (get-x color)
:green (get-y color)