Commit 43dfe59f authored by Dave Cooper's avatar Dave Cooper
Browse files

proof-of-concept of realtime drag, changed from ajax to sjax.

parent ebc1c6cb
......@@ -52,6 +52,7 @@
this.transform(\"T\"+(dx+this.odx)+\",\"+(dy+this.ody));
this.lastdx = dx;
this.lastdy = dy;
~a
},
up = function () {
this.animate({opacity: 1.0}, 500, \">\");
......@@ -60,8 +61,8 @@
"
(the raphael-canvas-id) width length
(the parent (gdl-ajax-call :js-vals? t))
(the parent (gdl-sjax-call :js-vals? t))
(the parent (gdl-sjax-call :js-vals? t))
)
(with-translated-state (:raphael (make-point (- (get-x view-center))
......@@ -151,51 +152,53 @@
(curve-index-quadruples (the-object object %curve-vertex-indices%))
(display-controls (or (geom-base::find-in-hash object *display-controls*)
(the object display-controls)))
(name (base64-encode-safe
(format nil "~s" (remove :root-object-object
(the-object object root-path)))))
(*read-default-float-format* 'single-float))
(let (prev-end
(move? t))
(mapc
#'(lambda(line-index-pair)
;;(setq move? t)
(destructuring-bind (start-index end-index) line-index-pair
(let ((start (svref 2d-vertices start-index))
(end (svref 2d-vertices end-index))
(name (base64-encode-safe
(format nil "~s" (remove :root-object-object
(the-object object root-path))))))
(when nil
(setq move? nil))
(setq prev-end end)
(with-cl-who ()
(str
(format
nil
"var ~a_lines = paper.path('~aL ~a ~a').attr({stroke: '~a'});~%"
name
(if move? (format nil "M ~a ~a "
(to-single-float (get-x start))
(to-single-float (get-y start)))
"")
(to-single-float (get-x end))
(to-single-float (get-y end))
(or (when (getf display-controls :color)
(lookup-color (getf display-controls :color) :format :hex))
(the-object object color-hex))))
(let ((stroke-width-string
(let* ((line-thickness (getf display-controls :line-thickness))
(line-thickness (or line-thickness (the object line-thickness)))
(line-thickness (if (zerop line-thickness) 1 line-thickness)))
(if line-thickness
(format nil "~a_lines.attr('stroke-width','~a');"
name (to-single-float line-thickness)) ""))))
(htm (str stroke-width-string)))))))
line-index-pairs))
(when line-index-pairs
(let ((path-string
(format nil "~{~a~^ ~}"
(mapcar
#'(lambda(line-index-pair)
(destructuring-bind (start-index end-index) line-index-pair
(let ((start (svref 2d-vertices start-index))
(end (svref 2d-vertices end-index)))
(when (and prev-end (coincident-point? start prev-end))
(setq move? nil))
(setq prev-end end)
(format nil "~aL ~a ~a"
(if move?
(format nil "M ~a ~a "
(to-single-float (get-x start))
(to-single-float (get-y start)))
" ")
(to-single-float (get-x end))
(to-single-float (get-y end))))))
line-index-pairs))))
(with-cl-who ()
(fmt "var ~a_lines = paper.path('~a').attr({stroke: '~a', fill: '~a'});~%"
name
path-string
(or (when (getf display-controls :color)
(lookup-color (getf display-controls :color) :format :hex))
(the-object object color-hex))
(or (when (getf display-controls :color)
(lookup-color (getf display-controls :color) :format :hex))
(the-object object color-hex)))
(fmt "~a_lines.attr({cursor: 'pointer'}).data('name','\\\"~a\\\"');"
name name)
(fmt "~&paper.set(~a_lines).drag(move,start,up);" name)
))))
(let (result)
(mapc #'(lambda(curve-index-quadruple)
......
......@@ -28,7 +28,9 @@
(main-sheet-body (with-cl-who-string ()
(str (the development-links))
(str (the main-area main-div))))
(str (the main-area main-div))
(str (the drop-coord-section main-div))
))
(dropped-x-y (if (the main-area dropped-x-y)
......@@ -52,6 +54,10 @@
(make-point 3 0 0)
(make-point 3 1 0)
(make-point 2 0 0)))
(drop-coord-section :type 'sheet-section
:inner-html (with-cl-who-string ()
(str (the main-area dropped-x-y))))
(main-area :type 'base-ajax-graphics-sheet
:respondent self
......
......@@ -21,50 +21,53 @@
(in-package :gwl)
(defparameter *ajax-snap-restore?* nil)
(defun quick-save (self &key (snap-folder (glisp:snap-folder)))
(let ((snap-file
(merge-pathnames
(make-pathname :name (format nil "~a" (the instance-id))
:type "snap") snap-folder)))
(with-error-handling ()
(the (write-snapshot :filename snap-file)))))
(when *ajax-snap-restore?*
(let ((snap-file
(merge-pathnames
(make-pathname :name (format nil "~a" (the instance-id))
:type "snap") snap-folder)))
(with-error-handling ()
(the (write-snapshot :filename snap-file))))))
(defun restore-from-snap (iid)
(let ((new-self
(let ((snap-file
(merge-pathnames
(make-pathname :name (format nil "~a" iid)
:type "snap") (glisp:snap-folder))))
(when (probe-file snap-file)
(with-error-handling ()
(read-snapshot :filename snap-file
:keys-to-ignore (list :time-last-touched
:time-instantiated
:expires-at)))))))
(when *ajax-snap-restore?*
(let ((new-self
(let ((snap-file
(merge-pathnames
(make-pathname :name (format nil "~a" iid)
:type "snap") (glisp:snap-folder))))
(when (probe-file snap-file)
(with-error-handling ()
(read-snapshot :filename snap-file
:keys-to-ignore (list :time-last-touched
:time-instantiated
:expires-at)))))))
(when new-self
(setf (gethash (make-keyword (the-object new-self instance-id)) *instance-hash-table*)
(list new-self nil))
(when (typep new-self 'session-control-mixin) (the-object new-self set-expires-at))
(the-object new-self set-instantiation-time!)
(the-object new-self set-time-last-touched!)
(when new-self
(setf (gethash (make-keyword (the-object new-self instance-id)) *instance-hash-table*)
(list new-self nil))
(when (typep new-self 'session-control-mixin) (the-object new-self set-expires-at))
(the-object new-self set-instantiation-time!)
(the-object new-self set-time-last-touched!)
(format t "~%~%*************** Session ~a Restarted! ***************~%~%"
(the-object new-self instance-id))
(format t "~%~%*************** Session ~a Restarted! ***************~%~%"
(the-object new-self instance-id))
(the-object new-self custom-snap-restore!)
(the-object new-self custom-snap-restore!)
)
)
;;
;; FLAG for testing only.
;; return error object instead of just throwing an error here.
;;
(unless new-self (error "Restoring of session ~a was not possible.~%" iid))
;;
;; FLAG for testing only.
;; return error object instead of just throwing an error here.
;;
(unless new-self (error "Restoring of session ~a was not possible.~%" iid))
new-self))
new-self)))
(defun gdlAjax (req ent)
......
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