Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
gendl
gendl
Commits
731f50e1
Commit
731f50e1
authored
Jul 07, 2013
by
Dave Cooper
Browse files
cleaned up drag-drop bashee location and hook functions
parent
82d2cb8b
Changes
5
Hide whitespace changes
Inline
Side-by-side
gwl-graphics/gwl/source/base-ajax-graphics-sheet.lisp
View file @
731f50e1
...
...
@@ -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
)
)
:functions
((
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
)
)))))
:computed-slots
(
(
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
)
)
))
)
:functions
(
(
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
))))))
...
...
gwl-graphics/raphael/source/lenses.lisp
View file @
731f50e1
...
...
@@ -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
))))
...
...
gwl-graphics/raphael/source/tests.lisp
View file @
731f50e1
...
...
@@ -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
:on-drop-function
#'
(
lambda
()
(
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
)))
#+
nil
:on-move-function
#+
nil
#'
(
lambda
()
(
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
)
...
...
gwl/ajax/source/ajax.lisp
View file @
731f50e1
...
...
@@ -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*
)
...
...
gwl/ajax/source/base-ajax-sheet.lisp
View file @
731f50e1
...
...
@@ -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
)
(
development-links
(
with-cl-who-string
()
(
write-the
development-links
)))
)
(
with-cl-who-string
()
(
write-the
development-links
))))
:functions
((
on-move
())
(
on-drop
())
(
back-link
:functions
((
back-link
(
&key
(
display-string
"<-Back"
))
(
w-c-w-s
()
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment