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 @@
(asdf:defsystem #:gwl-graphics :description
"The Gendl™ GWL embedded graphics support" :author "John McCarthy"
: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-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -283,20 +283,24 @@
(lookup-color (getf display-controls :fill-color) :format :hex))
(the-object object fill-color-hex))))
(when fill (fmt "~a.attr({fill: '~a'});" name fill)))
(let ((line-thickness (getf display-controls :line-thickness)))
(setq line-thickness (when line-thickness (number-round line-thickness 4)))
(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'});};"
name name
(floor (to-single-float (* (or line-thickness 1) 3))))
name name (* (or line-thickness 1.0) 3))
(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
;;
(cond ((the object onclick-function)
(fmt "~a.node.onclick = function (event) {~a};" name
(the parent parent parent
......@@ -349,7 +353,12 @@
(with-format-slots (view)
(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))
......@@ -368,7 +377,11 @@
(unless (zerop rotation) ;; FLAG -- rotate in raphael(pdf:rotate rotation)
)
(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-y center)
(the %text-to-draw%)
......@@ -385,7 +398,18 @@
(or (or (when (getf display-controls :fill-color)
(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)()
......
......@@ -3,7 +3,7 @@
(asdf:defsystem #:gwl :description
"The Gendl™ Generative Web Language (GWL)" :author "John McCarthy"
: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-encodings :encoding #+asdf-encodings :utf-8
:components
......
(in-package :gwl)
(#+allegro
excl:without-redefinition-warnings
#-allegro progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(#+allegro
excl:without-redefinition-warnings
#-allegro progn
(defmacro with-error-handling ((&key (error? nil)
(timeout 2)
(timeout-body
`(warn "Timed Out after ~a Seconds" ,timeout)))
&body body)
"[Macro]. Wraps the <b>body</b> of code with error-trapping and system timeout.
(defmacro with-error-handling ((&key (error? nil)
(timeout 2)
(timeout-body
`(warn "Timed Out after ~a Seconds" ,timeout)))
&body body)
"[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>.
:&key ((timeout 2) \"Timeout in Seconds.\"
......@@ -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\")"
(if error? `(progn ,@body)
(let ((values (gensym)) (error (gensym)))
(let ((code `(let* ((,values (multiple-value-list (ignore-errors ,@body)))
(,error (second ,values)))
(if (and ,error (typep ,error 'error))
(progn (warn "~a" ,error)
(values nil ,error))
(apply #'values ,values)))))
(if timeout
`(,(glisp:with-timeout-sym) (,timeout ,timeout-body) ,code)
code))))))
(if error? `(progn ,@body)
(let ((values (gensym)) (error (gensym)))
(let ((code `(let* ((,values (multiple-value-list (ignore-errors ,@body)))
(,error (second ,values)))
(if (and ,error (typep ,error 'error))
(progn (warn "~a" ,error)
(values nil ,error))
(apply #'values ,values)))))
(if timeout
`(,(glisp:with-timeout-sym) (,timeout ,timeout-body) ,code)
code)))))))
......@@ -3,7 +3,7 @@
(asdf:defsystem #:regression :description
"The Gendl™ regression Subsystem" :author "John McCarthy" :license
"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-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -4,7 +4,7 @@
"The Gendl™ NURBS Surface and Solids Geometry Primitives" :author
"John McCarthy" :license
"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-encodings :encoding #+asdf-encodings :utf-8
: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