Commit ebc1c6cb authored by Dave Cooper's avatar Dave Cooper

got basic drag & drop working with raphael

parent ae52a734
......@@ -14,6 +14,9 @@ bin
*.idx
*.log
*.toc
*.ilg
*.ind
configure.el
systems.txt
......
......@@ -514,9 +514,10 @@ CL \"fround\" function.
,(readable-expression (nreverse vals) self)) ht)))
(defmethod readable-expression ((object cons) &optional self)
(with-error-handling (:timeout nil) `(list ,@(mapcar #'(lambda(expr)
(readable-expression expr self))
object))))
(with-error-handling (:timeout nil) `(list ,@(mapcar #'(lambda(expr)
(readable-expression expr self))
object))))
(defmethod readable-expression ((object number) &optional self) (declare (ignore self)) object)
(defmethod readable-expression ((object string) &optional self) (declare (ignore self)) object)
......
......@@ -689,10 +689,10 @@ by the update."
(the (message-list :category :required-input-slots))
(the (message-list :category :defaulted-input-slots)))) result)
(mapc #'(lambda (slot)
(let ((contents (funcall (read-from-string (format nil "gdl-acc::~a" slot)) self)))
(when (and (not (member slot '(:%name% :%parent% :%aggregate% :%index% :$$tatu-object)))
(consp contents) (third contents))
(push slot result) (push (readable-expression (first contents) self) result)))) inputs)
(unless (member slot '(:%name% :%parent% :%aggregate% :%index% :$$tatu-object))
(let ((contents (funcall (read-from-string (format nil "gdl-acc::~a" slot)) self)))
(when (and (consp contents) (third contents))
(push slot result) (push (readable-expression (first contents) self) result))))) inputs)
(nreverse result)))
......
......@@ -127,11 +127,16 @@ value of the image-format-selector, which itself defaults to :raphael."
:computed-slots
(
(dropped-x-y nil :settable)
(js-to-eval (let ((image-format (the image-format)))
(print-variables image-format)
(cond ((eql (the image-format) :raphael)
(cond ((eql image-format :raphael)
(the raphael-string))
((eql (the image-format) :x3dom)
((eql image-format :x3dom)
nil
;;"console.log(\"loading x3dom js\"); xdom_script.src=\"http://www.x3dom.org/x3dom/release/x3dom.js\""
)))
......@@ -249,7 +254,34 @@ bottom of the graphics inside a table."
)
:functions
((reset-zoom!
(
;;
;; FLAG -- copied from base-html-graphics-sheet's logic for dig-point and report-point --
;; factor out the repeated code!
;;
;; FLAG -- standardize on length instead of height for Y coord.
;;
(model-x-y (bbox)
(when bbox
(destructuring-bind (&key x y width height name) bbox
(declare (ignore width height name))
(let ((x (- x (half (the view-object width))))
(y (let ((y (- (the view-object length) y)))
(- y (half (the view-object length))))))
(let ((adjusted
(scalar*vector
(the view-object user-scale)
(add-vectors (make-point (get-x (the view-object user-center) )
(get-y (the view-object user-center)) 0)
(scalar*vector (/ (the view-object user-scale))
(make-point x y 0))))))
(let ((model-point (the view-object main-view (model-point adjusted))))
model-point))))))
(reset-zoom!
()
(the view-object (restore-slot-defaults! (list :user-center :user-scale))))
......@@ -342,8 +374,6 @@ to call the :write-embedded-x3d-world function."))
(t
(print-variables (the onclick-function))
(with-cl-who ()
(:p
((:span :style "cursor: pointer;")
......
......@@ -41,8 +41,28 @@
(let ((width (the-object child-view width))
(length (the-object child-view length)))
(format *stream* "~&~%var paper = Raphael('~a', ~a, ~a);~%"
(the raphael-canvas-id) width length)
(format *stream* "~&~%var paper = Raphael('~a', ~a, ~a);~%
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 = function (dx, dy) {
this.transform(\"T\"+(dx+this.odx)+\",\"+(dy+this.ody));
this.lastdx = dx;
this.lastdy = dy;
},
up = function () {
this.animate({opacity: 1.0}, 500, \">\");
~a
};
"
(the raphael-canvas-id) width length
(the parent (gdl-ajax-call :js-vals? t))
)
(with-translated-state (:raphael (make-point (- (get-x view-center))
(- (get-y view-center))))
......@@ -383,7 +403,7 @@
(str
(format
nil
"var ~a_polyline = paper.path('M ~a ~a ~{~a~^ ~}').attr({stroke: '~a'});~%"
"var ~a = paper.path('M ~a ~a ~{~a~^ ~}').attr({stroke: '~a', cursor: 'pointer'}).data('name','\\\"~a\\\"'); ~a~%;"
;; FLAG -- add fill-color
name
(to-single-float (get-x start))
......@@ -398,47 +418,19 @@
(to-single-float (get-y end))))))
line-index-pairs)
(the color-hex))))))))))
(the color-hex)
name
(when (getf (the display-controls) :fill-color)
(let ((fill-color (lookup-color (getf (the display-controls) :fill-color) :format :hex)))
(format nil "~a.attr({fill: '~a'});" name fill-color)))
;;
;; FLAG -- this is not working - sort it out.
;;
#+nil
(define-lens (raphael global-polyline)()
:output-functions
(
(cad-output
()
(with-format-slots (view)
(let (;;(line-index-pairs (the %%line-vertex-indices%%))
(2d-vertices (map 'vector
(if view
#'(lambda(point)
(add-vectors (subseq (the-object view (view-point point)) 0 2)
geom-base:*raphael-translation*))
#'identity) (the %%vertex-array%%)))
(name (base64-encode-safe
(format nil "~s" (remove :root-object-object
(the root-path))))))
(with-cl-who ()
(let ((*read-default-float-format* 'single-float))
(str
(format
nil
"var ~a_polyline = paper.path('M ~a ~a ~{~a~^ ~}').attr({stroke: '~a'});~%"
;; FLAG -- add fill-color
name
(to-single-float (get-x (aref 2d-vertices 0)))
(to-single-float (get-y (aref 2d-vertices 0)))
(mapcar #'(lambda(point) (format nil "L ~a ~a"
(to-single-float (get-x point))
(to-single-float (get-y point))))
(rest (coerce (subseq 2d-vertices 1) 'list)))
(the color-hex))))))))))
))
(str (format nil "~&paper.set(~a).drag(move,start,up);" name))
)))))))
(define-lens (raphael point)()
......@@ -529,3 +521,45 @@
:output-functions
((cad-output ())))
#|
var start = function () {
this.lastdx ? this.odx += this.lastdx : this.odx = 0;
this.lastdy ? this.ody += this.lastdy : this.ody = 0;
this.animate({"fill-opacity": 0.2}, 500);
},
move = function (dx, dy) {
this.transform("T"+(dx+this.odx)+","+(dy+this.ody));
this.lastdx = dx;
this.lastdy = dy;
},
up = function () {
this.animate({"fill-opacity": 1}, 500);
};
tri.drag(move, start, up);
<script>
window.onload = function () {
var R = Raphael(0, 0, "100%", "100%"),
r = R.circle(100, 100, 50).attr({fill: "hsb(0, 1, 1)", stroke: "none", opacity: .5}),
g = R.circle(210, 100, 50).attr({fill: "hsb(.3, 1, 1)", stroke: "none", opacity: .5}),
b = R.circle(320, 100, 50).attr({fill: "hsb(.6, 1, 1)", stroke: "none", opacity: .5}),
p = R.circle(430, 100, 50).attr({fill: "hsb(.8, 1, 1)", stroke: "none", opacity: .5});
var start = function () {
this.ox = this.attr("cx");
this.oy = this.attr("cy");
this.animate({r: 70, opacity: .25}, 500, ">");
},
move = function (dx, dy) {
this.attr({cx: this.ox + dx, cy: this.oy + dy});
},
up = function () {
this.animate({r: 50, opacity: .5}, 500, ">");
};
R.set(r, g, b, p).drag(move, start, up);
};
</script>
|#
......@@ -19,7 +19,52 @@
;; <http://www.gnu.org/licenses/>.
;;
(in-package :raphael)
(in-package :gwl-user)
(define-object dd (base-ajax-sheet base-object)
:computed-slots ((use-raphael? t)
(main-sheet-body (with-cl-who-string ()
(str (the development-links))
(str (the main-area main-div))))
(dropped-x-y (if (the main-area dropped-x-y)
(make-point (get-x (the main-area dropped-x-y))
(- (get-y (the main-area dropped-x-y))
1)
0)
(make-point 0 0 0))))
:objects ((poly-1 :type 'global-polyline
:display-controls (list :color :red :fill-color :blue)
:vertex-list (list (the dropped-x-y)
(translate (the dropped-x-y) :right 1)
(translate (the dropped-x-y) :right 1 :rear 1)
(the dropped-x-y)))
(poly-2 :type 'global-polyline
:display-controls (list :color :black :fill-color :green)
:vertex-list (list (make-point 2 0 0)
(make-point 3 0 0)
(make-point 3 1 0)
(make-point 2 0 0)))
(main-area :type 'base-ajax-graphics-sheet
:respondent self
:vector-graphics-onclick? nil
:length 500 :width 500
:projection-vector (getf *standard-views* :top)
:display-list-objects (list (the poly-1) (the poly-2)))))
#+nil
(define-object test-sheet (base-ajax-sheet)
......@@ -40,33 +85,8 @@
(with-html-output (*stream*)
(write-the viewport main-div)))))
#+nil
(define-object test-vp (base-ajax-graphics-sheet)
:computed-slots ((js-to-eval (the raphael-string)))
:objects ((surf :type 'surf::test-b-spline-surface)
(view-object :type 'web-drawing
:page-width 500
:page-length 500
:projection-vector (getf *standard-views* (the projection-direction value))
:objects (list (the surf)))
(projection-direction :type 'menu-form-control
:size 1
:default :trimetric
:choice-list (plist-keys *standard-views*)
:onclick (the (gdl-ajax-call :form-controls (list (the-child)))))
(restore-button :type 'button-form-control
:label "Restore"
:onclick (the (gdl-ajax-call :function-key :restore-zoom!))))
:functions ((restore-zoom!
()
(the view-object (restore-slot-defaults! (list :user-scale :user-center))))))
#+nil
......
......@@ -99,6 +99,8 @@
(respondent (progn (when *debug?* (print-variables plist))
(or (getf plist :|respondent|) bashee)))
(function (getf plist :|function|))
(bbox-x-y (let ((jsvals (getf query-plist :|jsvals|)))
(when jsvals (read-from-string jsvals))))
(arguments (getf plist :|arguments|)))
......@@ -120,7 +122,11 @@
(the-object f-e-p validate-and-set!)
(when *debug?* (setq *f-e-p* f-e-p)))
(when (defaulting (the-object bashee main-area))
(the-object bashee main-area
(set-slot! :dropped-x-y
(the-object bashee main-area (model-x-y bbox-x-y)))))
(when function
(with-error-handling (:timeout *ajax-timeout*)
......
......@@ -259,7 +259,6 @@ interface. Defaults to nil."
((:a :href (the return-object url)) (str display-string))))
(update-root! ()
(format t "Updateing root...~%~%")
(unpublish-instance-urls (the instance-id) (the url))
(the root update!)
(the url)
......
......@@ -317,6 +317,7 @@ running the Javascript interpreter to evaluate (the js-to-eval), if any.
(respondent (the respondent))
function-key
arguments
js-vals?
form-controls
(asynch? t)
(one-arg? nil)
......@@ -378,18 +379,29 @@ running the Javascript interpreter to evaluate (the js-to-eval), if any.
"'"
)))
string))
(js-vals (when js-vals?
"+ '&jsvals=' + '(:x ' + this.getBBox().x +
' :y ' + this.getBBox().y +
' :width ' + this.getBBox().width +
' :height ' + this.getBBox().height +
' :name ' + this.data('name') +
')'"))
(string-3 (if asynch? "true" "false")))
(when *debug?* (print-variables string-1 string-2 string-3))
(setq string-1 (glisp:replace-regexp string-1 "\\" "\\\\\\\\")
string-2 (glisp:replace-regexp string-2 "\\" "\\\\\\\\"))
string-2 (glisp:replace-regexp string-2 "\\" "\\\\\\\\")
js-vals (glisp:replace-regexp js-vals "\\" "\\\\\\\\"))
(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))))
(format nil "gdlAjax1('args=~a~a~a);" string-1 string-2 (or js-vals ""))
(format nil "gdlAjax(event,'args=~a~a~a,~a);" string-1 string-2 (or js-vals "") string-3))))
(encode-ajax-args
......
......@@ -68,7 +68,6 @@ the object hierarchies rooted at the instances, as well as all associated publis
</pre>"
(maphash #'(lambda(key val)
(declare (ignore val))
(print-variables key)
(unless (member key *keys-to-preserve*)
(clear-instance key))) *instance-hash-table*))
......@@ -98,9 +97,7 @@ the object hierarchy rooted at the instance, as well as all associated published
(setq base-url (when base-url (subseq base-url 0 (- (length base-url) (length "index.html")))))
;;(when *debug?* (print-variables id base-url))
;; FLAG DEBUG
(when t (print-variables id base-url))
(when *debug?* (print-variables id base-url))
(let ((urls (gethash id *url-hash-table*)) remaining-urls)
(mapc #'(lambda(url)
......@@ -117,7 +114,7 @@ the object hierarchy rooted at the instance, as well as all associated published
;;
;;FLAG DEBUG
;;
(let ((url-to-unpub url)) (print-variables url-to-unpub))
(when *debug?* (let ((url-to-unpub url)) (print-variables url-to-unpub)))
(net.aserve::unpublish-entity (first (wserver-locators *wserver*))
url nil nil)))
......
......@@ -357,7 +357,8 @@ package-qualified object name\")
(root-part-and-version
(if (or (not share?) (not current))
(list (apply #'make-object (read-safe-string part)
:instance-id instance-id :query-toplevel query make-object-args)
:instance-id instance-id ;;:query-toplevel query
make-object-args)
*dummy-version*)
current)))
(setf (gethash (first root-part-and-version) *weak-objects*) t)
......
......@@ -149,7 +149,7 @@ the browser in development mode). Defaults to NIL (the empty list)."
(host nil :defaulting)
(query-toplevel nil :settable)
;; (query-toplevel nil :settable)
)
......@@ -201,7 +201,8 @@ the submitted form fields automatically."
:trickle-down-slots
(tree-root instance-id plain-url? host home-page query-toplevel fixed-url-prefix)
(tree-root instance-id plain-url? host home-page ;;query-toplevel
fixed-url-prefix)
:hidden-objects
(($$update :type 'update
......
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