Commit 731f50e1 authored by Dave Cooper's avatar Dave Cooper
Browse files

cleaned up drag-drop bashee location and hook functions

parent 82d2cb8b
......@@ -121,17 +121,41 @@ value of the image-format-selector, which itself defaults to :raphael."
;; FLAG -- probably not needed, inherited from skeleton-ui-mixin via base-ajax-sheet, base-html-sheet, sheet-section.
(inner-html (with-cl-who-string () (write-the inner-html))))
(inner-html (with-cl-who-string () (write-the inner-html)))
(on-move-function nil)
(on-drop-function nil)
(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
(dropped-x-y nil :settable)
(dropped-height-width nil :settable)
(dropped-object nil :settable)
(js-to-eval (let ((image-format (the image-format)))
(cond ((eql image-format :raphael)
......@@ -247,14 +271,19 @@ bottom of the graphics inside a table."
:choice-list (plist-keys (the standard-views))
;;:default :top
:default (the view-direction-default)
(on-move ()
(when (the on-move-function)
(funcall (the on-move-function))))
(on-drop ()
(when (the on-drop-function)
(funcall (the on-drop-function))))
;; FLAG -- copied from base-html-graphics-sheet's logic for dig-point and report-point --
;; factor out the repeated code!
......@@ -262,10 +291,9 @@ bottom of the graphics inside a table."
;; 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))
(model-x-y (local-x-y)
(when local-x-y
(destructuring-bind (&key x y) local-x-y
(let ((x (- x (half (the view-object width))))
(y (let ((y (- (the view-object length) y)))
(- y (half (the view-object length))))))
......@@ -62,11 +62,14 @@
(the raphael-canvas-id) width length
(the parent (gdl-sjax-call :js-vals? t))
;;(the parent (gdl-sjax-call :function-key :on-move))
(the parent (gdl-sjax-call :js-vals? t :function-key :on-drop))
;; 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 :js-vals? t :function-key :on-move))
(the parent (gdl-sjax-call :js-vals? t :function-key :on-drop)))
(with-translated-state (:raphael (make-point (- (get-x view-center))
(- (get-y view-center))))
......@@ -21,7 +21,6 @@
(in-package :gwl-user)
(define-object dd (base-ajax-sheet base-object)
:computed-slots ((use-raphael? t)
......@@ -88,10 +87,35 @@
(drop-coord-section :type 'sheet-section
:inner-html (with-cl-who-string ()
(str (the main-area dropped-x-y))))
((:table :border 1)
(:tr (:td "dropped coord:")
(:td (str (the main-area dropped-x-y))))
(:tr (:td "dropped dimensions:")
(:td (str (the main-area dropped-height-width))))
(:tr (:td "dropped object:")
(:td (fmt "~s" (the main-area dropped-object)))))))
(main-area :type 'base-ajax-graphics-sheet
:respondent self
(format t "Just called the on-drop hook with ~s, ~s, and ~s.~%"
(the main-area dropped-x-y)
(the main-area dropped-height-width)
(the main-area dropped-object)))
(format t "Just called the on-move hook with ~s, ~s, and ~s.~%"
(the main-area dropped-x-y)
(the main-area dropped-height-width)
(the main-area dropped-object)))
:vector-graphics-onclick? nil
:length 500 :width 500
:projection-vector (getf *standard-views* :top)
......@@ -102,8 +102,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))))
(js-vals (let ((jsvals (getf query-plist :|jsvals|)))
(when jsvals (read-from-string jsvals))))
(arguments (getf plist :|arguments|)))
......@@ -130,10 +130,7 @@
(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 js-vals (the-object bashee (set-js-vals! js-vals)))
(when function
(with-error-handling (:timeout *ajax-timeout*)
......@@ -235,29 +235,14 @@ interface. Defaults to nil."
:computed-slots ((use-raphael? nil)
;; FLAG 090907-JB: indiscussion with Dave - removed
;;(use-raphael-graf? nil)
(use-x3dom? nil)
(with-cl-who-string () (write-the development-links)))
(with-cl-who-string () (write-the development-links))))
:functions ((on-move ())
(on-drop ())
:functions ((back-link
(&key (display-string "<-Back"))
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