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
ebc1c6cb
Commit
ebc1c6cb
authored
Jun 26, 2013
by
Dave Cooper
Browse files
got basic drag & drop working with raphael
parent
ae52a734
Changes
12
Hide whitespace changes
Inline
Side-by-side
.gitignore
View file @
ebc1c6cb
...
...
@@ -14,6 +14,9 @@ bin
*.idx
*.log
*.toc
*.ilg
*.ind
configure.el
systems.txt
...
...
base/rest/source/utilities.lisp
View file @
ebc1c6cb
...
...
@@ -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
)
...
...
base/rest/source/vanilla-mixin.lisp
View file @
ebc1c6cb
...
...
@@ -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
)))
...
...
gwl-graphics/gwl/source/base-ajax-graphics-sheet.lisp
View file @
ebc1c6cb
...
...
@@ -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;"
)
...
...
gwl-graphics/raphael/source/lenses.lisp
View file @
ebc1c6cb
...
...
@@ -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>
|#
gwl-graphics/raphael/source/tests.lisp
View file @
ebc1c6cb
...
...
@@ -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
...
...
gwl/ajax/source/ajax.lisp
View file @
ebc1c6cb
...
...
@@ -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*
)
...
...
gwl/ajax/source/base-ajax-sheet.lisp
View file @
ebc1c6cb
...
...
@@ -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
)
...
...
gwl/ajax/source/skeleton-ui-element.lisp
View file @
ebc1c6cb
...
...
@@ -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
...
...
gwl/gwl-session/source/cleanup.lisp
View file @
ebc1c6cb
...
...
@@ -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
)))
...
...
gwl/source/answer.lisp
View file @
ebc1c6cb
...
...
@@ -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
)
...
...
gwl/source/base-html-sheet.lisp
View file @
ebc1c6cb
...
...
@@ -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
...
...
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