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

Merge branch 'release/1587p001' into devo

parents 8725b605 17c1c652
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
(asdf:defsystem #:gwl-graphics :description (asdf:defsystem #:gwl-graphics :description
"The Gendl™ GWL embedded graphics support" :author "John McCarthy" "The Gendl™ GWL embedded graphics support" :author "John McCarthy"
:license "Affero Gnu Public License (http://www.gnu.org/licenses/)" :license "Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial t :version "20140416" :depends-on (:geom-base :gwl) :serial t :version "20140424" :depends-on (:geom-base :gwl)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings) #-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8 #+asdf-encodings :encoding #+asdf-encodings :utf-8
:components :components
......
...@@ -283,20 +283,24 @@ ...@@ -283,20 +283,24 @@
(lookup-color (getf display-controls :fill-color) :format :hex)) (lookup-color (getf display-controls :fill-color) :format :hex))
(the-object object fill-color-hex)))) (the-object object fill-color-hex))))
(when fill (fmt "~a.attr({fill: '~a'});" name fill))) (when fill (fmt "~a.attr({fill: '~a'});" name fill)))
(let ((line-thickness (getf display-controls :line-thickness))) (let ((line-thickness (getf display-controls :line-thickness)))
(setq line-thickness (when line-thickness (number-round line-thickness 4)))
(when line-thickness (when line-thickness
(fmt "~&~a.attr('stroke-width','~a');" name (number-round line-thickness 4))) (fmt "~&~a.attr('stroke-width','~a');" name line-thickness))
(fmt " ~a.node.onmouseover = function (){~a.attr({'stroke-width': '~a'});};" (fmt " ~a.node.onmouseover = function (){~a.attr({'stroke-width': '~a'});};"
name name name name (* (or line-thickness 1.0) 3))
(floor (to-single-float (* (or line-thickness 1) 3))))
(fmt " ~a.node.onmouseout = function (){~a.attr({'stroke-width': '~a'});};" (fmt " ~a.node.onmouseout = function (){~a.attr({'stroke-width': '~a'});};"
name name (to-single-float (or line-thickness 1)))) name name (or line-thickness 1.0)))
;; ;;
;; FLAG -- do something better here than ignore-errors ;; FLAG -- do something better here than ignore-errors
;; ;;
(cond ((the object onclick-function) (cond ((the object onclick-function)
(fmt "~a.node.onclick = function (event) {~a};" name (fmt "~a.node.onclick = function (event) {~a};" name
(the parent parent parent (the parent parent parent
...@@ -349,7 +353,12 @@ ...@@ -349,7 +353,12 @@
(with-format-slots (view) (with-format-slots (view)
(let* ((view-scale (if view (the-object view view-scale-total) 1)) (let* ((view-scale (if view (the-object view view-scale-total) 1))
(center (translate (the center) :front (half (half (* 0.7 (the length))))))) (center (translate (the center) :front (half (half (* 0.7 (the length))))))
(name (base64-encode-safe
(format nil "~s"
(remove :root-object-object
(the root-path))))))
(setq center (if view (the-object view (view-point center)) center)) (setq center (if view (the-object view (view-point center)) center))
...@@ -368,7 +377,11 @@ ...@@ -368,7 +377,11 @@
(unless (zerop rotation) ;; FLAG -- rotate in raphael(pdf:rotate rotation) (unless (zerop rotation) ;; FLAG -- rotate in raphael(pdf:rotate rotation)
) )
(with-cl-who () (with-cl-who ()
(fmt "paper.text(~a, ~a, \"~a\").attr({\"font\": \"~2,3fpx Arial\", \"antialias\": \"false\", \"stroke\": \"~a\", \"fill\": \"~a\"});"
(fmt "var ~a;~%" name)
(fmt "~&~a = paper.text(~a, ~a, \"~a\").attr({\"font\": \"~2,3fpx Arial\", \"antialias\": \"false\", \"stroke\": \"~a\", \"fill\": \"~a\"});"
name
(get-x center) (get-x center)
(get-y center) (get-y center)
(the %text-to-draw%) (the %text-to-draw%)
...@@ -385,7 +398,18 @@ ...@@ -385,7 +398,18 @@
(or (or (when (getf display-controls :fill-color) (or (or (when (getf display-controls :fill-color)
(lookup-color (getf display-controls :fill-color) :format :hex)) (lookup-color (getf display-controls :fill-color) :format :hex))
(the-object object fill-color-hex)) "#000")))))))))) (the-object object fill-color-hex)) "#000"))
(cond ((and view (the onclick-function))
(fmt "~a.node.onclick = function (event) {~a};" name
(the-object view parent parent
(gdl-ajax-call :function-key :call-onclick-function!
:arguments (list self)))))
((ignore-errors (and (the viewport) (eql (the viewport digitation-mode) :select-object)))
(fmt "~a.node.onclick = function (event) {~a};" name
(the viewport (gdl-ajax-call :function-key :set-object-to-inspect!
:arguments (list self)))))
(t nil))))))))))
(define-lens (raphael point)() (define-lens (raphael point)()
......
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
(asdf:defsystem #:gwl :description (asdf:defsystem #:gwl :description
"The Gendl™ Generative Web Language (GWL)" :author "John McCarthy" "The Gendl™ Generative Web Language (GWL)" :author "John McCarthy"
:license "Affero Gnu Public License (http://www.gnu.org/licenses/)" :license "Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial t :version "20140416" :depends-on (:glisp :aserve) :serial t :version "20140424" :depends-on (:glisp :aserve)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings) #-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8 #+asdf-encodings :encoding #+asdf-encodings :utf-8
:components :components
......
(in-package :gwl) (in-package :gwl)
(#+allegro (eval-when (:compile-toplevel :load-toplevel :execute)
excl:without-redefinition-warnings (#+allegro
#-allegro progn excl:without-redefinition-warnings
#-allegro progn
(defmacro with-error-handling ((&key (error? nil) (defmacro with-error-handling ((&key (error? nil)
(timeout 2) (timeout 2)
(timeout-body (timeout-body
`(warn "Timed Out after ~a Seconds" ,timeout))) `(warn "Timed Out after ~a Seconds" ,timeout)))
&body body) &body body)
"[Macro]. Wraps the <b>body</b> of code with error-trapping and system timeout. "[Macro]. Wraps the <b>body</b> of code with error-trapping and system timeout.
A warning is given if an error condition occurs with <b>body</b>. A warning is given if an error condition occurs with <b>body</b>.
:&key ((timeout 2) \"Timeout in Seconds.\" :&key ((timeout 2) \"Timeout in Seconds.\"
...@@ -18,14 +19,14 @@ A warning is given if an error condition occurs with <b>body</b>. ...@@ -18,14 +19,14 @@ A warning is given if an error condition occurs with <b>body</b>.
:&rest (body \"Body of code to be wrapped\")" :&rest (body \"Body of code to be wrapped\")"
(if error? `(progn ,@body) (if error? `(progn ,@body)
(let ((values (gensym)) (error (gensym))) (let ((values (gensym)) (error (gensym)))
(let ((code `(let* ((,values (multiple-value-list (ignore-errors ,@body))) (let ((code `(let* ((,values (multiple-value-list (ignore-errors ,@body)))
(,error (second ,values))) (,error (second ,values)))
(if (and ,error (typep ,error 'error)) (if (and ,error (typep ,error 'error))
(progn (warn "~a" ,error) (progn (warn "~a" ,error)
(values nil ,error)) (values nil ,error))
(apply #'values ,values))))) (apply #'values ,values)))))
(if timeout (if timeout
`(,(glisp:with-timeout-sym) (,timeout ,timeout-body) ,code) `(,(glisp:with-timeout-sym) (,timeout ,timeout-body) ,code)
code)))))) code)))))))
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
(asdf:defsystem #:regression :description (asdf:defsystem #:regression :description
"The Gendl™ regression Subsystem" :author "John McCarthy" :license "The Gendl™ regression Subsystem" :author "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t "Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20140416" :depends-on (:lift :surf :tasty) :version "20140424" :depends-on (:lift :surf :tasty)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings) #-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8 #+asdf-encodings :encoding #+asdf-encodings :utf-8
:components :components
......
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
"The Gendl™ NURBS Surface and Solids Geometry Primitives" :author "The Gendl™ NURBS Surface and Solids Geometry Primitives" :author
"John McCarthy" :license "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t "Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20140416" :depends-on (:geom-base) :version "20140424" :depends-on (:geom-base)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings) #-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8 #+asdf-encodings :encoding #+asdf-encodings :utf-8
:components :components
......
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