Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
G
gendl
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
47
Issues
47
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
gendl
gendl
Commits
8120c87c
Commit
8120c87c
authored
Oct 01, 2018
by
Dave Cooper
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
added god-parent concept.
parent
fb33adba
Changes
11
Hide whitespace changes
Inline
Side-by-side
Showing
11 changed files
with
85 additions
and
82 deletions
+85
-82
base/macros/source/define-object.lisp
base/macros/source/define-object.lisp
+2
-1
base/rest/source/make-part.lisp
base/rest/source/make-part.lisp
+7
-3
base/rest/source/quantification.lisp
base/rest/source/quantification.lisp
+3
-1
base/rest/source/vanilla-mixin.lisp
base/rest/source/vanilla-mixin.lisp
+37
-36
demos/robot/source/assembly.lisp
demos/robot/source/assembly.lisp
+1
-1
geom-base/drawing/source/base-view.lisp
geom-base/drawing/source/base-view.lisp
+1
-1
geom-base/wire/source/utilities.lisp
geom-base/wire/source/utilities.lisp
+1
-0
gwl-graphics/gwl/source/base-ajax-graphics-sheet.lisp
gwl-graphics/gwl/source/base-ajax-graphics-sheet.lisp
+16
-25
gwl-graphics/gwl/source/web-drawing.lisp
gwl-graphics/gwl/source/web-drawing.lisp
+1
-1
gwl-graphics/svg/source/lenses.lisp
gwl-graphics/svg/source/lenses.lisp
+8
-7
gwl/ajax/source/ajax.lisp
gwl/ajax/source/ajax.lisp
+8
-6
No files found.
base/macros/source/define-object.lisp
View file @
8120c87c
...
...
@@ -750,7 +750,8 @@ overview of <tt>define-object</tt> syntax."
(
defun
make-standard-slots
()
`
((
gdl-acc::%version-tree%
:accessor
gdl-acc::%version-tree%
:initform
nil
)
(
gdl-acc::%toplevel-inputs%
:accessor
gdl-acc::%toplevel-inputs%
:initform
nil
:initarg
:%toplevel-inputs%
)
(
gdl-acc::%root%
:accessor
gdl-acc::%root%
:initform
nil
:initarg
:%root%
)))
(
gdl-acc::%root%
:accessor
gdl-acc::%root%
:initform
nil
:initarg
:%root%
)
(
gdl-acc::%god-parents%
:accessor
gdl-acc::%god-parents%
:initform
nil
:initarg
:%god-parents%
)))
(
defun
first-symbol
(
list
)
...
...
base/rest/source/make-part.lisp
View file @
8120c87c
...
...
@@ -74,16 +74,20 @@ The argument ~s, and its value ~s, have been ignored
:arguments (object-name \"Symbol. Should name a GDL object type.\"
arguments \"spliced-in plist. A plist of keyword symbols and values for initial <tt>input-slots</tt>.\")"
(
let
(
*notify-cons*
(
keys
(
plist-keys
args
))
(
vals
(
plist-values
args
)))
(
let
((
object
(
apply
#'
make-instance
object-type
:allow-other-keys
t
:allow-other-keys
t
;; FLAG -- tell me again why we should allow other keys?
(
append
(
list
:%name%
(
list
(
format
nil
"~a"
object-type
)
nil
t
)
:%parent%
(
list
nil
nil
t
))
:%parent%
(
list
nil
nil
t
)
:%god-parents%
(
getf
args
:god-parents
))
(
mapcan
#'
(
lambda
(
key
val
)
(
list
key
(
list
val
nil
t
)))
(
unless
(
eql
key
:god-parents
)
(
list
key
(
list
val
nil
t
))))
keys
vals
)))))
(
setf
(
gdl-acc::%root%
object
)
object
...
...
base/rest/source/quantification.lisp
View file @
8120c87c
...
...
@@ -28,7 +28,9 @@
extra parentheses around the message in the reference chain and using the index number. But the aggregate itself also supports certain
messages, documented here. One message, <tt>number-of-elements</tt>, is not listed in the normal messages section because it is
internal. It can be used, and returns an integer representing the cardinality of the aggregate."
)
:input-slots
((
remember-children?
nil
))
:computed-slots
((
index
nil
)
...
...
base/rest/source/vanilla-mixin.lisp
View file @
8120c87c
...
...
@@ -36,7 +36,7 @@ toplevel of the define-object form.")
:input-slots
(
(
remote-id
nil
:settable
)
(
quantify-box
(
or
(
the
parent
)
self
))
...
...
@@ -99,7 +99,7 @@ nil "~a~a~a" (the :name-for-display)
:computed-slots
(
(
(
remember-children?
nil
)
(
%corners%
nil
)
(
%vertex-array%
nil
)
...
...
@@ -388,41 +388,41 @@ or all mixins from the entire inheritance hierarchy.\")"
:arguments (slot \"Keyword Symbol\")
:key (force? \"Boolean. Specify as t if you want to force non-settable slots to recompute (e.g.
reading from databases or external files). Defaults to nil.\")"
restore-slot-default!
(
attribute
&key
(
force?
*force-restore-slot-default?*
))
(
when
(
or
force?
(
eql
(
the
(
slot-status
attribute
))
:set
))
(
let
(
*leaf-resets*
)
(
let
((
slot
(
glisp:intern
(
symbol-name
attribute
)
:gdl-acc
)))
(
unless
(
eq
(
first
(
ensure-list
(
slot-value
self
slot
)))
'gdl-rule::%unbound%
)
(
unbind-dependent-slots
self
slot
)
(
setf
(
slot-value
self
slot
)
(
if
*remember-previous-slot-values?*
(
list
'gdl-rule::%unbound%
nil
nil
(
first
(
slot-value
self
slot
)))
'gdl-rule::%unbound%
))))
(
let
((
root
(
let
((
maybe-root
(
the
:root
)))
(
if
(
the-object
maybe-root
root?
)
maybe-root
(
the-object
maybe-root
parent
))))
restore-slot-default!
(
attribute
&key
(
force?
*force-restore-slot-default?*
))
(
when
(
or
force?
(
eql
(
the
(
slot-status
attribute
))
:set
))
(
let
(
*leaf-resets*
)
(
let
((
slot
(
glisp:intern
(
symbol-name
attribute
)
:gdl-acc
)))
(
unless
(
eq
(
first
(
ensure-list
(
slot-value
self
slot
)))
'gdl-rule::%unbound%
)
(
unbind-dependent-slots
self
slot
)
(
setf
(
slot-value
self
slot
)
(
if
(
or
*remember-previous-slot-values?*
(
the
remember-children?
))
(
list
'gdl-rule::%unbound%
nil
nil
(
first
(
slot-value
self
slot
)))
'gdl-rule::%unbound%
))))
(
let
((
root
(
let
((
maybe-root
(
the
:root
)))
(
if
(
the-object
maybe-root
root?
)
maybe-root
(
the-object
maybe-root
parent
))))
;;(root-path (remove :root-object-object (the root-path)))
(
root-path
(
the
root-path
))
;;(root-path (remove :root-object-object (the root-path)))
(
root-path
(
the
root-path
))
)
;;
;; FLAG -- this pushnew should never be necessary...
;;
(
pushnew
(
list
root-path
)
(
gdl-acc::%version-tree%
root
)
:test
#'
equalp
:key
#'
(
lambda
(
item
)
(
list
(
first
item
))))
(
setf
(
rest
(
assoc
root-path
(
gdl-acc::%version-tree%
root
)
:test
#'
equalp
))
(
remove-plist-key
(
rest
(
assoc
root-path
(
gdl-acc::%version-tree%
root
)
:test
#'
equalp
))
attribute
))
(
setf
(
gdl-acc::%version-tree%
root
)
(
double-length-sort
(
gdl-acc::%version-tree%
root
))))
(
when
*eager-setting-enabled?*
(
dolist
(
reset
*leaf-resets*
)
(
the-object
(
first
reset
)
(
evaluate
(
second
reset
))))))))
)
;;
;; FLAG -- this pushnew should never be necessary...
;;
(
pushnew
(
list
root-path
)
(
gdl-acc::%version-tree%
root
)
:test
#'
equalp
:key
#'
(
lambda
(
item
)
(
list
(
first
item
))))
(
setf
(
rest
(
assoc
root-path
(
gdl-acc::%version-tree%
root
)
:test
#'
equalp
))
(
remove-plist-key
(
rest
(
assoc
root-path
(
gdl-acc::%version-tree%
root
)
:test
#'
equalp
))
attribute
))
(
setf
(
gdl-acc::%version-tree%
root
)
(
double-length-sort
(
gdl-acc::%version-tree%
root
))))
(
when
*eager-setting-enabled?*
(
dolist
(
reset
*leaf-resets*
)
(
the-object
(
first
reset
)
(
evaluate
(
second
reset
))))))))
;;
;; FLAG -- remove this defunct version.
...
...
@@ -1267,7 +1267,8 @@ a separate object hierarchy." object self)))
(
if
(
third
slot-value
)
(
setf
(
second
(
slot-value
object
slot
))
nil
)
(
setf
(
slot-value
object
slot
)
(
if
(
or
updating?
(
not
*remember-previous-slot-values?*
))
(
if
(
and
(
not
(
the-object
object
remember-children?
))
(
or
updating?
(
not
*remember-previous-slot-values?*
)))
'gdl-rule::%unbound%
(
list
'gdl-rule::%unbound%
nil
nil
(
first
(
slot-value
object
slot
))))))))
(
when
(
and
(
find-class
'gdl-remote
nil
)
(
typep
object
'gdl-remote
))
...
...
demos/robot/source/assembly.lisp
View file @
8120c87c
...
...
@@ -213,7 +213,7 @@ to the src/ directory distributed with GDL.
:objects
((
base
:type
'robot-base
:display-controls
(
merge-display-controls
(
list
:color
:
blue-sky
))
:display-controls
(
merge-display-controls
(
list
:color
:
orange
))
:height
(
*
(
the
height
)
0.4
)
:width
(
*
(
the
width
)
0.2
)
:length
(
*
(
the
length
)
0.2
)
...
...
geom-base/drawing/source/base-view.lisp
View file @
8120c87c
...
...
@@ -67,7 +67,7 @@ makes sense for viewing it."
:input-slots
(
(
empty-display-list-message
nil
)
;;(touched-geometry nil)
(
width
(
the
page-width
))
...
...
geom-base/wire/source/utilities.lisp
View file @
8120c87c
...
...
@@ -27,6 +27,7 @@
(
local-object-boxes
(
remove
nil
(
mapcar
#'
(
lambda
(
object
)
(
when
(
typep
object
'base-object
)
(
the-object
object
local-box
)))
local-objects
))))
(
let
(
xmin
ymin
zmin
xmax
ymax
zmax
)
(
mapcar
#'
(
lambda
(
box
)
(
let
((
min
(
first
box
))
(
max
(
second
box
)))
...
...
gwl-graphics/gwl/source/base-ajax-graphics-sheet.lisp
View file @
8120c87c
...
...
@@ -36,6 +36,8 @@ Raphael vector graphics."
:input-slots
((
respondent
(
the
bashee
)
:defaulting
)
(
empty-display-list-message
nil
)
(
"Number. Thickness of default border around graphics viewport.
Default is 1."
viewport-border-default
1
)
...
...
@@ -153,13 +155,16 @@ value of the image-format-selector, which itself defaults to :raphael."
(
write-the
view-object
cad-output
))))))
(
svg-string
(
unless
(
the
no-graphics?
)
(
with-error-handling
()
(
with-output-to-string
(
ss
)
(
with-format
(
svg
ss
:background-color
(
the
background-color
)
:foreground-color
(
the
foreground-color
))
(
write-the
view-object
cad-output
))))))
(
svg-string
(
if
(
the
no-graphics?
)
(
with-cl-who-string
()
((
:div
:id
"empty-viewport"
:class
"empty-viewport"
)
(
:p
(
:h2
(
str
(
the
empty-display-list-message
))))))
(
with-error-handling
()
(
with-output-to-string
(
ss
)
(
with-format
(
svg
ss
:background-color
(
the
background-color
)
:foreground-color
(
the
foreground-color
))
(
write-the
view-object
cad-output
))))))
(
"String of valid HTML. This can be used to
...
...
@@ -259,6 +264,7 @@ x3draw();
zoom-factor-renderer
)
:page-length
(
the
length
)
:page-width
(
the
width
)
:empty-display-list-message
(
the
empty-display-list-message
)
:objects
(
the
display-list-objects
)
:object-roots
(
the
display-list-object-roots
))
...
...
@@ -448,28 +454,13 @@ to call the :write-embedded-x3d-world function."))
)
(
:|Scene|
((
:|navigationinfo|
:|id|
"navi"
:|transitionTime|
"0.1"
))
((
:|navigationinfo|
:|id|
"navi"
:|transitionTime|
"0.0"
))
(
with-format
(
x3d
*stream*
)
(
let
((
*onclick-function*
(
the
onclick-function
)))
(
write-the
view-object
cad-output
))))))
((
:script
:type
"text/javascript"
)
;;"x3draw();"
#+
nil
(
fmt
"
x3dom.reload();
// document.getElementById('view-~(~a~)').setAttribute('set_bind', 'true');
// xruntime = document.getElementById('x3dom-1').runtime;
//xruntime.resetView();
"
(
the
view-selector
value
)
)
)))))))
(
write-the
view-object
cad-output
))))))))))))
(
raster-graphics
...
...
gwl-graphics/gwl/source/web-drawing.lisp
View file @
8120c87c
...
...
@@ -131,7 +131,7 @@ application-mixin, you can include one object of this type in the ui-display-lis
from the base-ajax-graphics-sheet and based on its root-path, but can be specified manually
if you are making a web-drawing on your own. Defaults (in the standalone case) to \"RaphaelCanvas\""
raphael-canvas-id
"RaphaelCanvas"
)
(
"3D vector. This is the normal vector of the view plane onto which to project the 3D objects. Defaults to (getf *standard-views* :top)."
projection-vector
(
getf
*standard-views*
:top
))
...
...
gwl-graphics/svg/source/lenses.lisp
View file @
8120c87c
...
...
@@ -36,18 +36,18 @@
(
when
parent-scale
(
the-object
child-view
(
set-slot!
:user-scale
parent-scale
)))
(
let
((
width
(
the-object
child-view
width
))
(
length
(
the-object
child-view
length
)))
(
with-html-output
(
*stream*
)
((
:div
:onmousedown
(
when
(
the
parent
vector-graphics-onclick?
)
(
the
parent
(
gdl-ajax-call
:function-key
:dig-point
:bashee
(
the
parent
)
:respondent
(
the
parent
:respondent
)))))
((
:svg
:id
"svg-1"
:viewBox
(
format
nil
"0 0 ~a ~a"
width
length
)
:width
width
:height
length
)
(
with-translated-state
(
:svg
(
make-point
(
-
(
get-x
view-center
))
(
-
(
get-y
view-center
))))
(
write-the-object
child-view
cad-output
)))
((
:svg
:id
"svg-1"
:viewBox
(
format
nil
"0 0 ~a ~a"
width
length
)
:width
width
:height
length
)
(
with-translated-state
(
:svg
(
make-point
(
-
(
get-x
view-center
))
(
-
(
get-y
view-center
))))
(
write-the-object
child-view
cad-output
)))
((
:script
:type
"text/javascript"
)
"
var panZoomSVG1 = svgPanZoom('#svg-1', {
...
...
@@ -58,6 +58,7 @@
minZoom: 0.01,
maxZoom: 100,
center: true});"
))))
(
when
parent-scale
(
the-object
child-view
(
set-slot!
:user-scale
old-scale
)))))
(
the
views
))))))))
...
...
gwl/ajax/source/ajax.lisp
View file @
8120c87c
...
...
@@ -155,10 +155,13 @@
(
when
(
and
respondent
(
the-object
respondent
root
)
(
typep
(
the-object
respondent
root
)
'session-control-mixin
))
(
the-object
respondent
root
(
set-expires-at
)))
(
when
(
and
respondent
(
the-object
respondent
root
)
(
the-object
respondent
root
(
set-time-last-touched!
))))
(
when
(
and
respondent
(
the-object
respondent
root
)
(
typep
(
the-object
respondent
root
)
'session-control-mixin
))
(
the-object
respondent
root
(
set-time-last-touched!
)))
#+
nil
;; FLAG -- add this back when cleaning up remote-objects.
(
when
(
and
respondent
(
the-object
respondent
root
)
(
the-object
respondent
root
(
set-remote-host!
req
))))
...
...
@@ -248,11 +251,9 @@
(
:document
(
mapc
#'
(
lambda
(
replace-pair
js-to-eval-status
)
(
declare
(
ignore
js-to-eval-status
))
;; this can play into the flag
(
print-variables
(
base64-decode-safe
(
getf
replace-pair
:dom-id
)))
(
when
*debug?*
(
print-variables
(
base64-decode-safe
(
getf
replace-pair
:dom-id
)
)))
(
destructuring-bind
(
&key
dom-id
inner-html
js-to-eval
)
replace-pair
(
let
((
js-to-eval?
(
and
js-to-eval
(
not
(
string-equal
js-to-eval
""
)))))
(
when
(
or
inner-html
js-to-eval?
)
...
...
@@ -305,6 +306,7 @@ You can reload to get previous state" *ajax-timeout*))
(
progn
(
when
*debug?*
(
print-variables
(
the
stale?
)
(
the
section
root-path
)))
;;(print-variables (the section root-path))
(
when
t
;; (the stale?) ;; already filtering for stale? before calling now.
(
list
:dom-id
(
the
dom-id
)
...
...
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