Commit 4e926932 authored by Dave Cooper's avatar Dave Cooper

added readable expression for pathnames, change wording for cached bashing...

added readable expression for pathnames, change wording for cached bashing warning, removed debug output from raphael lens.
parent d473edb3
......@@ -500,7 +500,7 @@ CL \"fround\" function.
(declare (ignore self))
(error "Objects of type ~a cannot currently be written out and read back into GDL reliably.
Please do not use objects of this type as the value for toplevel inputs or settable slots,
or contact Genworks with an enhancement request to include a readble output format for
or contact Genworks with an enhancement request to include a readable output format for
this object type." (type-of object)))
......@@ -524,6 +524,8 @@ CL \"fround\" function.
(defmethod readable-expression ((object symbol) &optional self) (declare (ignore self))
`',object)
(defmethod readable-expression ((object array) &optional self) (declare (ignore self)) object)
(defmethod readable-expression ((object pathname) &optional self)
(declare (ignore self)) object)
(defmethod lookup-color ((color string) &key (format :decimal) (ground :foreground))
(if (and (eql (aref color 0) #\#) (= (length color) 7))
......
......@@ -440,7 +440,10 @@ error will be generated.
(when (and warn-on-non-toplevel?
*notify-cons*)
(warn "It is not possible to call set-slot! from within dependency-tracking context, e.g. from the body of a computed-slot.
(warn "It is not recommended to call set-slot! from within dependency-tracking context, e.g. from the body of a computed-slot.
THIS CAN LEAD TO INCONSISTENT DEPENDENCY-TRACKING!!!
Set-slot was called on
~s
......
......@@ -21,7 +21,7 @@
(in-package :gdl)
(defparameter *gendl-version* "1584")
(defparameter *gendl-version* "1585")
(eval-when (compile load eval)
(when (not (boundp '*production-build?*)) (defvar *production-build?* nil)))
......
......@@ -31,7 +31,7 @@ with base-html-graphics-sheet, and adds html-format output-functions
for several of the new formats such as ajax-enabled png/jpeg and
Raphael vector graphics."
:examples "FLAG -- Fill in!!!")
:examples "FLAG -- Fill in!!!")
:input-slots
(("Number. Thickness of default border around graphics viewport.
......@@ -124,16 +124,15 @@ value of the image-format-selector, which itself defaults to :raphael."
(inner-html (with-cl-who-string () (write-the inner-html)))
)
(on-drag-function nil)
:functions
((set-js-vals! (js-vals) (declare (ignore js-vals))))
(on-drop-function nil)
:computed-slots
(
(on-touchmove-function nil))
(js-to-eval :parse :settable)
:computed-slots
((js-to-eval :parse :settable)
(js-always-to-eval nil)
......@@ -187,18 +186,29 @@ bottom of the graphics inside a table."
(with-cl-who-string ()
(:table (:tr ((:td :align :center)
(str (ecase (the image-format-selector value)
((:web3d :vrml) (the web3d-graphics))
((:png :jpeg :jpg) (the raster-graphics))
(:raphael (the vector-graphics))))))
(when (and (member (the image-format) (list :jpeg :jpg :png :raphael))
(the include-view-controls?))
(htm (:tr (:td (str (the view-controls))))))
(when (and (member (the image-format) (list :vrml :web3d))
(the include-view-controls?))
(htm (:tr (:td (str (the image-format-selector html-string))))))
((:web3d :vrml) (the web3d-graphics))
((:png :jpeg :jpg) (the raster-graphics))
(:raphael (the vector-graphics))))))
(when (and (member (the image-format) (list :jpeg :jpg :png :raphael))
(the include-view-controls?))
(htm (:tr (:td (str (the view-controls))))))
(when (and (member (the image-format) (list :vrml :web3d))
(the include-view-controls?))
(htm (:tr (:td (str (the image-format-selector html-string))))))
)))
("3D point. This is the upper-right corner of the bounding box of the dragged and/or dropped element."
dropped-x-y nil :settable)
("Plist with :width and :height. The dimensions of the bounding-box of the dragged and/or dropped element."
dropped-height-width nil :settable)
("List representing GDL root-path. This is the root path of the dragged and/or dropped object.
This is not tested to see if it is part of the same object tree as current self."
dropped-object nil :settable))
))))
:hidden-objects
......@@ -243,7 +253,6 @@ bottom of the graphics inside a table."
;;
;; FLAG -- standardize on length instead of height for Y coord.
;;
(model-x-y (local-x-y)
(when local-x-y
(destructuring-bind (&key x y) local-x-y
......@@ -271,7 +280,31 @@ The <tt>view-object</tt> child should exist and be of type <tt>web-drawing</tt>.
write-embedded-x3dom-world
(&key (include-view-controls? nil))
(write-the (embedded-x3dom-world :include-view-controls? include-view-controls?)))))
(write-the (embedded-x3dom-world :include-view-controls? include-view-controls?)))
(set-js-vals!
(js-vals)
(let ((dropped-x-y (the (model-x-y (destructuring-bind (&key x y &allow-other-keys) js-vals
(list :x x :y y)))))
(dropped-height-width (destructuring-bind (&key width height &allow-other-keys) js-vals
(list :width (/ width (the view-object view-scale))
:height (/ height (the view-object view-scale)))))
(dropped-object (with-error-handling () (base64-decode-list (getf js-vals :name)))))
(the (set-slots! (list :dropped-x-y dropped-x-y
:dropped-height-width dropped-height-width
:dropped-object dropped-object)))))
(on-drag () (when (the on-drag-function)
(funcall (the on-drag-function))))
(on-drop () (when (the on-drop-function)
(funcall (the on-drop-function))))
(on-touchmove () (when (the on-touchmove-function)
(funcall (the on-touchmove-function))))))
(define-lens (html-format base-ajax-graphics-sheet)()
......
......@@ -28,7 +28,56 @@
(define-lens (raphael base-drawing)()
:output-functions
((raphael-paper-def (&key width length)
((raphael-paper-def
(&key width length)
(format *stream* "if (typeof paper === 'undefined') {var paper = Raphael('~a', ~a, ~a)};~%
if (typeof start === 'undefined') {
var start = function () {
this.lastdx ? this.odx += this.lastdx : this.odx = 0;
this.lastdy ? this.ody += this.lastdy : this.ody = 0;
this.animate({opacity: .5}, 500, \">\");
},
move_cb = function (dx, dy) {
this.transform(\"T\"+(dx+this.odx)+\",\"+(dy+this.ody));
this.lastdx = dx;
this.lastdy = dy;
this.animate({opacity: .5}, 500, \">\");
~a
},
move = function (dx, dy) {
this.transform(\"T\"+(dx+this.odx)+\",\"+(dy+this.ody));
this.lastdx = dx;
this.lastdy = dy;
this.animate({opacity: .5}, 500, \">\");
},
up = function () {
this.animate({opacity: 1.0}, 500, \">\");
~a
},
touchcoords = function () {~a}};
"
(the raphael-canvas-id) width length
;;
;; FLAG -- pass in the containing
;; base-ajax-graphics-sheet and refer
;; to that, instead of referring to
;; the parent here.
;;
(the parent (gdl-sjax-call :null-event? t :js-vals? t :function-key :on-drag))
(the parent (gdl-sjax-call :null-event? t :js-vals? t :function-key :on-drop))
(the parent (gdl-sjax-call :null-event? t :js-vals? t :function-key :on-touchmove))))
#+nil
(raphael-paper-def (&key width length)
(format *stream* "if (typeof paper === 'undefined') {var paper = Raphael('~a', ~a, ~a)};~%"
(the raphael-canvas-id) width length))
......@@ -275,16 +324,10 @@
(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))))))
)
(print-variables (the center) view view-scale center )
(center (translate (the center) :front (half (half (* 0.7 (the length)))))))
(setq center (if view (the-object view (view-point center)) center))
(print-variables center)
(let ((font-size (* 0.9 (* (the character-size) view-scale)))
(rotation
(angle-between-vectors-d
......@@ -297,8 +340,6 @@
(make-point (get-x point)
(- (the-object view length) (get-y point)))))
(print-variables center)
(unless (zerop rotation) ;; FLAG -- rotate in raphael(pdf:rotate rotation)
)
(with-cl-who ()
......@@ -406,6 +447,23 @@
(define-lens (raphael t)()
:output-functions
((cad-output ())
(drag-controls
(&key name display-controls)
(let ((drag-controls (ensure-list (getf display-controls :drag-controls))))
(when drag-controls
(with-cl-who ()
(str (format nil "~a.attr({cursor: 'pointer'}).data('name','\\\"~a\\\"');~%"
name name))
(cond
((or (member :drag drag-controls)
(member :drag-and-drop drag-controls))
(str (format nil "~&paper.set(~a).drag(move_cb,start,up);" name)))
((or (member :drop drag-controls)
(member :drag-and-drop drag-controls))
(str (format nil "~&paper.set(~a).drag(move,start,up);" name)))
((member :touchmove drag-controls)
(str (format nil "~&paper.set(~a).touchmove(touchcoords);" name))))))))
#+nil
(drag-controls (&key name display-controls)
(declare (ignore name display-controls)))))
......
This diff is collapsed.
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