Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
gendl
gendl
Commits
7bb2a191
Commit
7bb2a191
authored
Feb 26, 2013
by
Dave Cooper
Browse files
Partial fix for Issue
#84
parent
96bb61fe
Changes
11
Hide whitespace changes
Inline
Side-by-side
gdl/apps/tasty/source/assembly.lisp
View file @
7bb2a191
...
...
@@ -450,3 +450,5 @@ The error was: ~a
)
))))
gdl/apps/tasty/source/inspector.lisp
View file @
7bb2a191
...
...
@@ -241,6 +241,7 @@
(
define-object
value-inspector
(
inspector
)
:input-slots
((
message
nil
)
...
...
@@ -252,7 +253,10 @@
(
the
parent-node
(
evaluate
(
the
message
))))))
:computed-slots
((
value-type
(
if
(
the
3d-vector?
)
((
value-root-path
(
cons
(
the
message
)
(
the
parent-node
root-path
)))
(
value-type
(
if
(
the
3d-vector?
)
:gdl-3d-point
(
typecase
(
the
value
)
(
list
(
when
(
consp
(
the
value
))
:list
))
...
...
@@ -293,6 +297,7 @@
(
let*
((
value
(
the
value
))
(
gdl-object?
(
eql
(
class-of
(
class-of
value
))
(
find-class
'gdl-class
))))
(
with-cl-who-string
()
((
:span
:style
(
format
nil
"color: ~a; ~a"
(
if
(
the
clickable?
)
"blue"
"black"
)
...
...
@@ -307,7 +312,10 @@
(
when
(
the
clickable?
)
(
the
(
gdl-ajax-call
:function-key
:perform-action!
:arguments
(
list
(
the
point
))))))
;;:arguments (list (the point))
:arguments
(
let
((
object
(
make-object
'gdl::root-path-container
:root-path
(
the
value-root-path
))))
(
list
object
))))))
((
:list
:gdl-sequence
)
(
unless
(
the
expanded?
)
...
...
@@ -336,12 +344,20 @@
(
:td
(
str
(
the-object
row
value-display
)))))))))
(
htm
(
:pre
(
esc
(
the
truncated-sequence
))))))
(
gdl-object?
(
htm
(
esc
(
format
nil
"~s"
value
))))
#+
nil
((
eql
(
the
value-type
)
:gdl-3d-point
)
(
htm
(
esc
(
the
point
strings-for-display
))))
((
eql
(
the
value-type
)
:gdl-3d-point
)
(
htm
(
esc
(
format
nil
"~s"
value
))))
(
t
(
htm
(
fmt
"~s"
value
))))))))))
:objects
((
point
:type
(
if
(
the
3d-vector?
)
'point
'null-object
)
:objects
(
#+
nil
(
point
:type
(
if
(
the
3d-vector?
)
'point
'null-object
)
:center
(
when
(
the
3d-vector?
)
(
the
value
))
:strings-for-display
(
format
nil
"~s"
(
the
value
)))
...
...
gdl/apps/tasty/source/viewport.lisp
View file @
7bb2a191
...
...
@@ -44,7 +44,9 @@
;;(the recompute?)
(
maphash
#'
(
lambda
(
root-path
value
)
(
declare
(
ignore
value
))
(
push
(
the
root-object
(
follow-root-path
root-path
))
result
))
(
push
(
if
(
listp
root-path
)
(
the
root-object
(
follow-root-path
root-path
))
root-path
)
result
))
(
the
view-object-roots-root-paths-hash
))
(
nreverse
result
)))
...
...
@@ -126,17 +128,18 @@
;;
(
add-leaves!
(
object
)
(
the
(
add-display-controls!
object
))
(
let
((
hash
(
the
view-object-roots-root-paths-hash
))
(
root-path
(
the-object
object
root-path
)))
(
root-path
(
the-object
object
root-path
)))
(
the
(
set-slot!
:view-object-roots-root-paths-hash
(
progn
(
unless
(
second
(
multiple-value-list
(
gethash
root-path
hash
)))
(
setf
(
gethash
root-path
hash
)
t
))
hash
))))
(
progn
(
unless
(
second
(
multiple-value-list
(
gethash
root-path
hash
)))
(
setf
(
gethash
root-path
hash
)
t
))
hash
))))
(
the
(
set-slot!
:operations-list
(
append
(
the
operations-list
)
(
list
(
list
:operation
:add-leaves
:object
object
))))))
(
append
(
the
operations-list
)
(
list
(
list
:operation
:add-leaves
:object
object
))))))
(
enter-debugger!
...
...
gdl/base/rest/source/vanilla-mixin.lisp
View file @
7bb2a191
...
...
@@ -958,8 +958,8 @@ a separate object hierarchy." object self)))
(
define-object
root-path-container
()
:input-slots
(
root-path
))
...
...
gdl/geom-base/drawing/source/base-view.lisp
View file @
7bb2a191
...
...
@@ -297,7 +297,10 @@ the box should be facing. Defaults to <tt>*nominal-y-vector*</tt>."
;;(typep obj 'outline-specialization-mixin)
))
(
let
((
leaves
(
apply
#'
append
(
mapcar
#'
(
lambda
(
object
)
(
the-object
object
leaves
))
(
apply
#'
append
(
mapcar
#'
(
lambda
(
object
)
(
if
(
typep
object
'gdl::gdl-basis
)
(
the-object
object
leaves
)
(
list
object
)))
(
the
object-roots
)))))
(
append
leaves
(
apply
#'
append
...
...
@@ -324,18 +327,17 @@ the box should be facing. Defaults to <tt>*nominal-y-vector*</tt>."
(
object-array
(
remove-duplicates
(
coerce
(
append
(
the
objects
)
(
remove-if
#'
(
lambda
(
obj
)
(
or
(
typep
obj
'null-part
)
(
typep
obj
'outline-specialization-mixin
)
))
(
apply
#'
append
(
append
(
the
objects
)
(
remove-if
#'
(
lambda
(
obj
)
(
or
(
typep
obj
'null-part
)
(
typep
obj
'outline-specialization-mixin
)
))
(
apply
#'
append
(
mapcar
#'
(
lambda
(
object
)
(
when
(
typep
object
'outline-specialization-mixin
)
(
the-object
object
outline-leaves
)))
(
the
objects
))))
(
the
leaf-objects-from-roots
))
'vector
))))
(
mapcar
#'
(
lambda
(
object
)
(
when
(
typep
object
'outline-specialization-mixin
)
(
the-object
object
outline-leaves
)))
(
the
objects
))))
(
the
leaf-objects-from-roots
))
'vector
))))
:hidden-objects
((
border-box
:type
'box
)
...
...
@@ -441,33 +443,35 @@ the box should be facing. Defaults to <tt>*nominal-y-vector*</tt>."
(
vertex-array-2d
(
let
((
raw-points
(
or
(
the
object
%corners%
)
(
the
object
%vertex-array%
))))
(
when
(
typep
(
the
object
)
'gdl::gdl-basis
)
(
let
((
raw-points
(
or
(
the
object
%corners%
)
(
the
object
%vertex-array%
))))
;;(the touched-geometry)
;;(the touched-geometry)
;;(print-messages object)
;;(print-variables raw-points)
;;(print-messages object)
;;(print-variables raw-points)
(
map
'vector
#'
(
lambda
(
point
)
;;
;; FLAG this case basically repeats code from (defun keyed-transform*vector ...)
;;
(
if
(
and
(
keywordp
(
the
view-transform
))
(
the
snap-to-y?
))
(
case
(
the
view-transform
)
(
:top
(
subseq
point
0
2
))
;;(make-vector (get-x point) (get-y point)))
(
:bottom
(
make-vector
(
get-x
point
)
(
-
(
get-y
point
))))
(
:rear
(
make-vector
(
-
(
get-x
point
))
(
get-z
point
)))
(
:front
(
make-vector
(
get-x
point
)
(
get-z
point
)))
(
:right
(
make-vector
(
get-y
point
)
(
get-z
point
)))
(
:left
(
make-vector
(
-
(
get-y
point
))
(
get-z
point
)))))
(
project-to-plane
point
1
(
the
projection-vector
)
(
the
view-transform
)
:snap-to
(
the
snap-to
)))
raw-points
)))
(
map
'vector
#'
(
lambda
(
point
)
;;
;; FLAG this case basically repeats code from (defun keyed-transform*vector ...)
;;
(
if
(
and
(
keywordp
(
the
view-transform
))
(
the
snap-to-y?
))
(
case
(
the
view-transform
)
(
:top
(
subseq
point
0
2
))
;;(make-vector (get-x point) (get-y point)))
(
:bottom
(
make-vector
(
get-x
point
)
(
-
(
get-y
point
))))
(
:rear
(
make-vector
(
-
(
get-x
point
))
(
get-z
point
)))
(
:front
(
make-vector
(
get-x
point
)
(
get-z
point
)))
(
:right
(
make-vector
(
get-y
point
)
(
get-z
point
)))
(
:left
(
make-vector
(
-
(
get-y
point
))
(
get-z
point
)))))
(
project-to-plane
point
1
(
the
projection-vector
)
(
the
view-transform
)
:snap-to
(
the
snap-to
)))
raw-points
)))
)
(
2d-bounding-box
(
unless
(
the
immune?
)
(
unless
(
or
(
not
(
typep
(
the
object
)
'gdl::gdl-basis
))
(
the
immune?
))
(
let*
((
vertex-array-2d
(
the
vertex-array-2d
))
(
xs
(
map
'list
#'
get-x
vertex-array-2d
))
(
ys
(
map
'list
#'
get-y
vertex-array-2d
)))
...
...
gdl/geom-base/drawing/source/lenses.lisp
View file @
7bb2a191
...
...
@@ -148,55 +148,56 @@
:output-functions
((
lines-and-curves
()
(
let
((
object
(
the
object
))
(
2d-vertices
(
the
vertex-array-2d-scaled
)))
;;
;; FLAG -- update this to handle global-filleted-polyline and any other odd types.
;;
(
unless
(
typep
object
'global-filleted-polyline
)
(
when
(
typep
(
the
object
)
'gdl::gdl-basis
)
(
let
((
object
(
the
object
))
(
2d-vertices
(
the
vertex-array-2d-scaled
)))
;;
;; FLAG -- update this to handle global-filleted-polyline and any other odd types.
;;
(
unless
(
typep
object
'global-filleted-polyline
)
(
let
((
line-index-pairs
(
the-object
object
%line-vertex-indices%
))
(
curve-index-quadruples
(
the-object
object
%curve-vertex-indices%
)))
(
let
((
line-index-pairs
(
the-object
object
%line-vertex-indices%
))
(
curve-index-quadruples
(
the-object
object
%curve-vertex-indices%
)))
(
pdf:with-saved-state
(
write-the-object
object
line-thickness-setting
)
(
pdf:with-saved-state
(
write-the-object
object
line-thickness-setting
)
(
write-the-object
object
dash-pattern-setting
)
(
write-the-object
object
dash-pattern-setting
)
(
write-the-object
object
rgb-stroke-setting
)
(
write-the-object
object
rgb-stroke-setting
)
(
mapc
#'
(
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
)))
(
pdf:move-to
(
%get-x%
start
)
(
%get-y%
start
))
(
pdf:line-to
(
%get-x%
end
)(
%get-y%
end
)))))
line-index-pairs
)
(
mapc
#'
(
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
)))
(
pdf:move-to
(
%get-x%
start
)
(
%get-y%
start
))
(
pdf:line-to
(
%get-x%
end
)(
%get-y%
end
)))))
line-index-pairs
)
(
let
(
start
end
prev-end
)
(
let
(
start
end
prev-end
)
(
mapc
#'
(
lambda
(
curve-index-quadruple
)
(
destructuring-bind
(
start-index
c1-index
c2-index
end-index
)
curve-index-quadruple
(
declare
(
ignorable
start-index
))
(
mapc
#'
(
lambda
(
curve-index-quadruple
)
(
destructuring-bind
(
start-index
c1-index
c2-index
end-index
)
curve-index-quadruple
(
declare
(
ignorable
start-index
))
(
setq
prev-end
end
)
(
setq
start
(
svref
2d-vertices
start-index
)
end
(
svref
2d-vertices
end-index
))
(
setq
prev-end
end
)
(
setq
start
(
svref
2d-vertices
start-index
)
end
(
svref
2d-vertices
end-index
))
(
let
((
c1
(
svref
2d-vertices
c1-index
))
(
c2
(
svref
2d-vertices
c2-index
)))
(
let
((
c1
(
svref
2d-vertices
c1-index
))
(
c2
(
svref
2d-vertices
c2-index
)))
(
unless
(
and
start
prev-end
(
coincident-point?
start
prev-end
))
(
pdf:move-to
(
%get-x%
start
)
(
%get-y%
start
)))
(
unless
(
and
start
prev-end
(
coincident-point?
start
prev-end
))
(
pdf:move-to
(
%get-x%
start
)
(
%get-y%
start
)))
(
pdf:bezier-to
(
%get-x%
c1
)
(
%get-y%
c1
)
(
%get-x%
c2
)
(
%get-y%
c2
)
(
%get-x%
end
)
(
%get-y%
end
)))))
curve-index-quadruples
))
(
pdf:bezier-to
(
%get-x%
c1
)
(
%get-y%
c1
)
(
%get-x%
c2
)
(
%get-y%
c2
)
(
%get-x%
end
)
(
%get-y%
end
)))))
curve-index-quadruples
))
(
if
(
the-object
object
fill-color-decimal
)
(
pdf:fill-and-stroke
)
(
pdf:stroke
)))))))))
(
if
(
the-object
object
fill-color-decimal
)
(
pdf:fill-and-stroke
)
(
pdf:stroke
)))))))))
)
(
define-lens
(
dxf
view-object-cache
)()
...
...
gdl/geom-base/lenses/source/x3d.lisp
View file @
7bb2a191
...
...
@@ -93,6 +93,24 @@
)))))
;;
;; FLAG -- add output functions for point and simple-vector.
;;
(
define-lens
(
x3d
t
)
()
:output-functions
((
cad-output
(
&key
(
header?
nil
))
(
declare
(
ignore
header?
)))
(
cad-output-tree
(
&key
(
header?
nil
))
(
declare
(
ignore
header?
)))))
(
define-lens
(
x3d
base-object
)()
:output-functions
(
...
...
gdl/geom-base/wire/source/point.lisp
View file @
7bb2a191
...
...
@@ -86,6 +86,9 @@ meaning the crosshairs will remain the same size regardless of zoom state."
(
make-point
(
+
x
1
)
(
+
y
1
)
(
+
z
1
))))))))
(
define-lens
(
pdf
point
)()
:output-functions
((
cad-output
...
...
@@ -111,3 +114,24 @@ meaning the crosshairs will remain the same size regardless of zoom state."
(
define-lens
(
pdf
simple-vector
)()
:output-functions
((
cad-output
()
(
with-format-slots
(
view
)
(
let
((
center
(
if
view
(
the-object
view
(
view-point
self
))
self
))
(
crosshair-length
3
)
;; FLAG -- figure out better way to specify this
;;(view-scale (if view (the-object view view-scale) 1))
(
view-scale
1
)
)
(
let
((
start-x
(
-
(
get-x
center
)
(
*
crosshair-length
view-scale
)))
(
start-y
(
-
(
get-y
center
)
(
*
crosshair-length
view-scale
))))
(
pdf:with-saved-state
(
pdf:move-to
(
to-single-float
start-x
)
(
to-single-float
(
get-y
center
)))
(
pdf:line-to
(
to-single-float
(
+
start-x
(
*
(
twice
crosshair-length
)
view-scale
)))
(
to-single-float
(
get-y
center
)))
(
pdf:move-to
(
to-single-float
(
get-x
center
))
(
to-single-float
start-y
))
(
pdf:line-to
(
to-single-float
(
get-x
center
))
(
to-single-float
(
+
start-y
(
*
(
twice
crosshair-length
)
view-scale
))))
(
pdf:stroke
))))))))
\ No newline at end of file
gdl/gwl-graphics/gwl/source/web-drawing.lisp
View file @
7bb2a191
...
...
@@ -154,7 +154,7 @@ if you are making a web-drawing on your own. Defaults (in the standalone case) t
(
center
(
make-point
0
0
0
))
(
image-file
(
dolist
(
object
(
the
objects
))
(
when
(
the-object
object
image-file
)
(
when
(
and
(
typep
object
'gdl::gdl-basis
)
(
the-object
object
image-file
)
)
(
return
(
the-object
object
image-file
))))))
...
...
gdl/gwl-graphics/raphael/source/lenses.lisp
View file @
7bb2a191
...
...
@@ -483,5 +483,49 @@
(
the
color-hex
)))))))))))
(
define-lens
(
raphael
simple-vector
)()
:output-functions
((
cad-output
()
(
with-format-slots
(
view
)
(
let
((
center
(
if
view
(
the-object
view
(
view-point
self
))
self
))
(
crosshair-length
3
)
(
view-scale
1
))
(
setq
center
(
let
((
point
(
add-vectors
geom-base:*raphael-translation*
(
subseq
center
0
2
))))
(
make-point
(
get-x
point
)
(
-
(
the-object
view
length
)
(
get-y
point
)))))
(
let
((
start-x
(
to-single-float
(
-
(
get-x
center
)
(
*
crosshair-length
view-scale
))))
(
start-y
(
to-single-float
(
-
(
get-y
center
)
(
*
crosshair-length
view-scale
))))
(
end-x
(
to-single-float
(
+
(
get-x
center
)
(
*
crosshair-length
view-scale
))))
(
end-y
(
to-single-float
(
+
(
get-y
center
)
(
*
crosshair-length
view-scale
))))
(
center-x
(
to-single-float
(
get-x
center
)))
(
center-y
(
to-single-float
(
get-y
center
)))
(
name
"pt"
))
(
with-cl-who
()
(
let
((
*read-default-float-format*
'single-float
))
(
str
(
format
nil
"var ~a_lines = paper.path('M ~a ~a L ~a ~a M ~a ~a L ~a ~a').attr({stroke: '#000'});~%"
name
start-x
center-y
end-x
center-y
center-x
start-y
center-x
end-y
))))))))))
(
define-lens
(
raphael
t
)()
:output-functions
((
cad-output
())))
gdl/gwl/source/base-html-sheet.lisp
View file @
7bb2a191
...
...
@@ -31,6 +31,9 @@
(
cons
(
encode-for-ajax
(
first
item
))
(
encode-for-ajax
(
rest
item
)))))
(
defmethod
encode-for-ajax
((
self
gdl::root-path-container
))
(
list
:%container-rp%
(
the
root-path
)))
(
defmethod
encode-for-ajax
((
self
gdl::gdl-basis
))
(
list
:%rp%
(
the
root-path
)))
...
...
@@ -42,6 +45,8 @@
(
when
item
(
cond
((
eql
(
first
item
)
:%rp%
)
(
the
(
follow-root-path
(
getf
item
:%rp%
))))
((
eql
(
first
item
)
:%container-rp%
)
(
make-object
'gdl::root-path-container
:root-path
(
getf
item
:%container-rp%
)))
(
t
(
cons
(
decode-from-ajax
(
first
item
)
self
)
(
decode-from-ajax
(
rest
item
)
self
))))))
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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