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
43dfe59f
Commit
43dfe59f
authored
Jun 28, 2013
by
Dave Cooper
Browse files
proof-of-concept of realtime drag, changed from ajax to sjax.
parent
ebc1c6cb
Changes
3
Hide whitespace changes
Inline
Side-by-side
gwl-graphics/raphael/source/lenses.lisp
View file @
43dfe59f
...
...
@@ -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-
a
jax-call
:js-vals?
t
))
(
the
parent
(
gdl-sjax-call
:js-vals?
t
))
(
the
parent
(
gdl-
s
jax-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
)
...
...
gwl-graphics/raphael/source/tests.lisp
View file @
43dfe59f
...
...
@@ -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
...
...
gwl/ajax/source/ajax.lisp
View file @
43dfe59f
...
...
@@ -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
)
...
...
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