Commit cc3a7433 authored by Dave Cooper's avatar Dave Cooper

Merge branch 'release/1587p008'

parents 968487e6 7d7ffae2
##Gendl®
Pre-built Distributions available here:
http://gendl.com
Gendl® is a Generative Programming and Knowledge Based Engineering
framework, implementing concepts which date back to the 1980s and
which cutting-edge companies have been quietly using to gain
......
......@@ -45,7 +45,7 @@
(plist (gwl::assoc-list-to-plist query))
(object (the root-object (follow-root-path
(read-safe-string
(base64-decode-safe (getf plist :rootPath)))))))
(base64-decode-safe (getf plist :|rootPath|)))))))
(the (perform-action! object))
......@@ -63,7 +63,7 @@
(self (first (gethash (make-keyword iid) gwl:*instance-hash-table*)))
(self (reset-self self))
(plist (gwl::assoc-list-to-plist query)))
(let ((root-path (getf plist :rootPath)))
(let ((root-path (getf plist :|rootPath|)))
(setq root-path (base64-decode-safe root-path))
(when *debug?* (print-variables self root-path))
......@@ -85,8 +85,8 @@
(self (first (gethash (make-keyword iid) gwl:*instance-hash-table*)))
(self (reset-self self))
(plist (gwl::assoc-list-to-plist query))
(message (make-keyword (base64-decode-safe (getf plist :message)))))
(print-variables plist message)
(message (make-keyword (base64-decode-safe (getf plist :|message|)))))
(with-http-response (req ent :content-type "text/xml")
(with-http-body (req ent)
(with-html-output(*html-stream* nil )
......@@ -106,9 +106,10 @@
(self (first (gethash (make-keyword iid) gwl:*instance-hash-table*)))
(self (reset-self self))
(plist (gwl::assoc-list-to-plist query))
(slot (make-keyword (getf plist :control)))
(value (getf plist :value)))
(slot (make-keyword (getf plist :|control|)))
(value (getf plist :|value|)))
(if (eql (read-safe-string value) 'gdl::restore-default)
(the click-mode (restore-slot-default! slot))
(the click-mode (set-slot-if-needed! slot value)))
......@@ -126,13 +127,13 @@
(self (first (gethash (make-keyword iid) gwl:*instance-hash-table*)))
(self (reset-self self))
(plist (gwl::assoc-list-to-plist query))
(root-path (base64-decode-list (getf plist :rootPath)))
(root-path (base64-decode-list (getf plist :|rootPath|)))
(object (the root-object (follow-root-path root-path)))
(plist (remove-plist-key (remove-plist-key plist :iid) :rootPath)))
(plist (remove-plist-key (remove-plist-key plist :|iid|) :|rootPath|)))
(let ((keys (read-safe-string (getf plist :keys)))
(values (base64-decode-list (getf plist :values))))
(let ((keys (read-safe-string (getf plist :|keys|)))
(values (base64-decode-list (getf plist :|values|))))
(mapc #'(lambda(key value)
(the-object object (set-slot-if-needed! key value :infer-types? nil))) keys values))
......@@ -156,10 +157,10 @@
(self (first (gethash (make-keyword iid) gwl:*instance-hash-table*)))
(self (reset-self self))
(plist (gwl::assoc-list-to-plist query))
(root-path (read-safe-string (getf plist :rootPath)))
(root-path (read-safe-string (getf plist :|rootPath|)))
(object (the (follow-root-path root-path)))
(slot (read-safe-string (getf plist :control)))
(value (getf plist :value)))
(slot (read-safe-string (getf plist :|control|)))
(value (getf plist :|value|)))
(if (eql (read-safe-string value) 'gdl::restore-default)
......@@ -185,7 +186,7 @@
(self (first (gethash (make-keyword iid) gwl:*instance-hash-table*)))
(self (reset-self self))
(plist (gwl::assoc-list-to-plist query))
(mode (make-keyword (getf plist :mode))))
(mode (make-keyword (getf plist :|mode|))))
(the tree (set-slot! :expand-mode mode))
......@@ -203,7 +204,7 @@
(self (first (gethash (make-keyword iid) gwl:*instance-hash-table*)))
(self (reset-self self))
(plist (gwl::assoc-list-to-plist query))
(mode (getf plist :mode)))
(mode (getf plist :|mode|)))
(setq self (the click-mode))
......@@ -275,14 +276,15 @@
(self (first (gethash (make-keyword iid) gwl:*instance-hash-table*)))
(self (reset-self self))
(plist (gwl::assoc-list-to-plist query))
(self (the (follow-root-path (read-safe-string (getf plist :rootPath))))))
(self (the (follow-root-path (read-safe-string (getf plist :|rootPath|))))))
;;
;; FLAG -- this is internal stuff, should be handled by a simple function on the self object.
;;
(let ((local-point (make-point (- (parse-integer (getf plist :x)) (half (the view-object width)))
(let ((y (- (the view-object length) (parse-integer (getf plist :y)))))
(let ((local-point (make-point (- (parse-integer (getf plist :|x|))
(half (the view-object width)))
(let ((y (- (the view-object length) (parse-integer (getf plist :|y|)))))
(- y (half (the view-object length)))))))
(let ((digitized-point
(add-vectors (the view-object user-center)
......
......@@ -177,17 +177,17 @@
((:img :border nil :src (format nil "/images/gwl/~a" image-file))))))))
(:td
((:table :border 0 :cellpadding 0 :cellspacing 0)
(mapc #'(lambda(selector image)
(html
(:tr
(:td
((:span :style "cursor: pointer;"
:title "Set Line Thickness"
:onclick (format nil "return ta2setcontrol('~a', '~s', '~a');"
(the instance-id) :line-thickness (the-object selector line-thickness)))
((:img :border 0 :src (format nil "/images/gwl/~a" image))))))))
(:tr
(mapc #'(lambda(selector image)
(html
(:td
((:span :style "cursor: pointer;"
:title "Set Line Thickness"
:onclick (format nil "return ta2setcontrol('~a', '~s', '~a');"
(the instance-id) :line-thickness (the-object selector line-thickness)))
((:img :border 0 :src (format nil "/images/gwl/~a" image)))))))
(list-elements (the line-thickness-selectors))
(list "line-1.gif" "line-1.gif" "line-2.gif" "line-3.gif" "line-4.gif"))))
(list "line-1.gif" "line-1.gif" "line-2.gif" "line-3.gif" "line-4.gif")))))
(:td
......
......@@ -23,7 +23,6 @@
(gwl:define-package :ta2
(:documentation #.(glisp:system-description :ta2))
(:export #:assembly))
#+nil
......
......@@ -4,7 +4,7 @@
"The Gendl\" (legacy) Testing and Tracking Utility, version 2 (using Ajax but pre-gdlAjax, and no JQuery or CSS)"
:author "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20140615" :depends-on (:gwl-graphics)
:version "20140916" :depends-on (:gwl-graphics)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
1. Why do some slots and the tree get unevaluated when doing a refresh and/or update?
2. Make inspector values which are GDL objects be selectable.
3. Make slot values which are sequences be selectable, and replace
with scrolling area with elements from sequence.
4. Make each area easily resizeable.
5. Make the areas reconfigurable/rearrangeable.
6. In general: add professional design look to ta2.
7. Trap errors in geometry display-list.
8. Wrap names in inspector column (shrink its width somehow).
9. Handle updates after an object is removed from the tree.
to replicate:
1. add a new child to the tree
2. update and draw the leaves
3. remove the object in the code
4. update the ta2/tatu browser
10. More robust error message for non-expanding nodes in tree, which
work in IE.
11. Add the measure-distance capability in a friendly way.
......@@ -75,6 +75,8 @@ o allow input of required input-slots.
:computed-slots
(
(use-cookie? nil)
(fixed-url-prefix nil)
(ui-specific-layout-js (when (the use-jquery?) "/static/gwl/js/tasty-initlayout-3.js"))
......
This diff is collapsed.
......@@ -4,7 +4,7 @@
"The Gendl\" Web-based Development Environment (tasty)" :author
"John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20140615" :depends-on (:tree :gwl-graphics)
:version "20140916" :depends-on (:tree :gwl-graphics)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -4,7 +4,7 @@
"The Gendl\" Translators to/from XML and potentially other high-level KBE and Knowledge formats"
:author "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20140615" :depends-on (:gwl)
:version "20140916" :depends-on (:gwl)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -76,8 +76,13 @@
(or (ignore-errors (the target-object line-thickness)) 1)))
#+nil
(local-display-controls (gethash (the target-object) (the display-controls-hash)))
(local-display-controls
(or (gethash (the target-object) (the display-controls-hash))
(when (typep (the parent) 'newertree) (the parent local-display-controls))))
(kids-error (when (typep (the safe-children) 'error) (the safe-children)))
(safe-children (append (if *trap-errors?*
......
......@@ -4,7 +4,7 @@
"The Gendl\" Tree component used by Tasty and potentially as a UI component on its own"
:author "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20140615" :depends-on (:gwl-graphics)
:version "20140916" :depends-on (:gwl-graphics)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -797,7 +797,9 @@ If you specify :part-symbol-supplied, do not specify :instance-supplied."))
(pretty-definition
()
(let ((*package* (find-package (the part-package))))
(let ((*package* (find-package (the part-package)))
;;(*print-case* :downcase)
)
(html-stream *stream*
(:pre
((:div :class "gdl-object-def")
......@@ -841,7 +843,8 @@ If you specify :part-symbol-supplied, do not specify :instance-supplied."))
(:princ (if (and (the first?) (the parent first?))
"" " "))
(:princ (if (member (the section category) (list :required-input-slots)) "" "("))
((:span :class "gdl-message-name") (:princ (the message-name))))
((:span :class "gdl-message-name")
(:princ (the message-name))))
(if (the objects?)
......
......@@ -4,7 +4,7 @@
"The Gendl\" Yet Another Definition Documenter (yadd)" :author
"John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20140615" :depends-on
:version "20140916" :depends-on
(:gwl-graphics #-allegro :cl-html-parse)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
......
......@@ -3,7 +3,7 @@
(asdf:defsystem #:base :description
"The Gendl\" Base Core Kernel Engine" :author "John McCarthy"
:license "Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial t :version "20140615" :depends-on nil
:serial t :version "20140916" :depends-on nil
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
;;
;; Copyright 2002-2011 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :gdl)
(defun instantiate-part-on-demand (self self-type attr-sym)
(let ((current-object (previous-value self attr-sym)))
(if current-object
(prog1 (change-class current-object self-type)
(unless (eql attr-sym 'gdl-acc::root-object-object)
(the-object current-object (update! :replace-bashed-values? nil))))
(make-object-internal self-type
:%name% (list attr-sym nil t)
:%parent% (list self nil t)
:%root% (gdl-acc::%root% self)))))
(defun chase-up-trickle-down (slot-symbol self args)
(let ((parent (the-object self parent)))
(if (null parent) (not-handled self (make-keyword slot-symbol))
(let ((result
(let (*error-on-not-handled?*)
(funcall (symbol-function (glisp:intern slot-symbol :gdl-inputs)) parent (the %name%) self))))
(if (eql result 'gdl-rule:%not-handled%)
(let ((result
(let (*error-on-not-handled?*)
(cond ((member (make-keyword slot-symbol) (the-object parent %trickle-down-slots%))
(apply (symbol-function slot-symbol) parent args))
(t (apply (symbol-function (glisp:intern slot-symbol :gdl-trickle-downs)) parent args))))))
(if (eql result 'gdl-rule:%not-handled%) (not-handled self (make-keyword slot-symbol)) result))
result)))))
(defun trickle-down-basis (self slot args)
(let (*error-on-not-handled?* (parent (the parent)))
(cond ((null parent) (not-handled self (make-keyword slot)))
((member (make-keyword slot) (the-object parent %trickle-down-slots%))
(apply (symbol-function (glisp:intern slot :gdl-slots)) parent args))
(t (apply (symbol-function (glisp:intern slot :gdl-trickle-downs)) parent args)))))
;;
;; Copyright 2002-2011 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :gdl)
(defun instantiate-part-on-demand (self self-type attr-sym)
(let ((current-object (previous-value self attr-sym)))
(if current-object
(prog1 (change-class current-object self-type)
(unless (eql attr-sym 'gdl-acc::root-object-object)
(the-object current-object (update! :replace-bashed-values? nil))))
(make-object-internal self-type
:%name% (list attr-sym nil t)
:%parent% (list self nil t)
:%root% (gdl-acc::%root% self)))))
(defun chase-up-trickle-down (slot-symbol self args)
(let ((keyword (make-keyword slot-symbol)))
(let ((parent (the-object self parent)))
(if (null parent) (not-handled self keyword)
(let ((result
(let (*error-on-not-handled?*)
(funcall (symbol-function (glisp:intern slot-symbol :gdl-inputs)) parent (the %name%) self))))
(if (eql result 'gdl-rule:%not-handled%)
(let ((result
(let (*error-on-not-handled?*)
(cond (;;(member keyword (the-object parent %trickle-down-slots%))
(gethash keyword (the-object parent %trickle-down-slots%))
(apply (symbol-function slot-symbol) parent args))
(t (apply (symbol-function (glisp:intern slot-symbol :gdl-trickle-downs)) parent args))))))
(if (eql result 'gdl-rule:%not-handled%) (not-handled self keyword) result))
result))))))
(defun trickle-down-basis (self slot args)
(let ((keyword (make-keyword slot)))
(let (*error-on-not-handled?* (parent (the parent)))
(cond ((null parent) (not-handled self keyword))
(;;(member keyword (the-object parent %trickle-down-slots%))
(gethash keyword (the-object parent %trickle-down-slots%))
(apply (symbol-function (glisp:intern slot :gdl-slots)) parent args))
(t (apply (symbol-function (glisp:intern slot :gdl-trickle-downs)) parent args))))))
;;
;; Copyright 2002-2011 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :gdl)
(defun make-part (&rest args)
(apply #'make-object args))
(defun make-object (object-type &rest args)
"GDL Object. Instantiates an object with specified initial values for input-slots.
: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
(append (list :%name% (list (format nil "~a" object-type) nil t)
:%parent% (list nil nil t))
(mapcan #'(lambda(key val)
(list key (list val nil t)))
keys vals)))))
(setf (gdl-acc::%root% object) object
(gdl-acc::%toplevel-inputs% object) args) object)))
(defun make-object-internal (object-type &rest args)
(let ((object (apply #'make-instance object-type :allow-other-keys t args)))
object))
(defun make-canonical-part (&rest args)
(apply #'make-object args))
(defun make-self (object-type &rest args)
(setf (symbol-value 'self) (apply #'make-object object-type args)))
;;
;; Copyright 2002-2011 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :gdl)
(defparameter *warn-on-invalid-toplevel-inputs?* t)
(defun make-part (&rest args)
(apply #'make-object args))
;;
;; FLAG -- cache the computation of input-slots based on type, and
;; look up input-slots on subsequent calls. Then reactivate this
;; make-object.
;;
#+nil
(defun make-object (object-type &rest args)
"GDL Object. Instantiates an object with specified initial values for input-slots.
: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
(list :%name% (list (format nil "~a" object-type) nil t)
:%parent% (list nil nil t)))))
(let ((input-slots
(append (the-object object (message-list :category :required-input-slots))
(the-object object (message-list :category :optional-input-slots))
(the-object object (message-list :category :settable-optional-input-slots))
(the-object object (message-list :category :defaulted-input-slots))
(the-object object (message-list :category :settable-defaulted-input-slots)))))
(mapc #'(lambda(key val)
(if (member key input-slots)
(setf (slot-value object (glisp:intern key :gdl-acc))
(list val nil t))
(when *warn-on-invalid-toplevel-inputs?*
(warn "~&~%~s is not a defined input-slot for ~s.
The argument ~s, and its value ~s, have been ignored
[you may (setq *warn-on-invalid-toplevel-inputs?* nil) to suppress this warning).~%~%"
key object-type key val)))) keys vals))
(setf (gdl-acc::%root% object) object
(gdl-acc::%toplevel-inputs% object) args) object)))
(defun make-object (object-type &rest args)
"GDL Object. Instantiates an object with specified initial values for input-slots.
: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
(append (list :%name% (list (format nil "~a" object-type) nil t)
:%parent% (list nil nil t))
(mapcan #'(lambda(key val)
(list key (list val nil t)))
keys vals)))))
(setf (gdl-acc::%root% object) object
(gdl-acc::%toplevel-inputs% object) args) object)))
(defun make-object-internal (object-type &rest args)
(apply #'make-instance object-type :allow-other-keys t args))
(defun make-canonical-part (&rest args)
(apply #'make-object args))
(defun make-self (object-type &rest args)
(setf (symbol-value 'self) (apply #'make-object object-type args)))
......@@ -510,62 +510,62 @@ from
value
(cons 'the (append (reverse (the-object (first *notify-cons*) root-path))
(list (make-keyword (second *notify-cons*)))))))
(unless (eql attribute :%primary?%)
(when (not *run-with-dependency-tracking?*)
(error "Dependency Tracking must be enabled in order to forcibly
(progn ;; bt:with-lock-held (*binding-lock*) FLAG - bring in later in bootstrapping.
(unless (eql attribute :%primary?%)
(when (not *run-with-dependency-tracking?*)
(error "Dependency Tracking must be enabled in order to forcibly
set slot values.
Please setq the variable `*run-with-dependency-tracking?*' to T,
make a fresh root-level object, and start again."))
(let (*leaf-resets*)
(let ((slot (glisp:intern (symbol-name attribute) :gdl-acc)))
(unbind-dependent-slots self slot)
(setf (slot-value self slot)
(list value nil t)))
(when remember?
(let ((root (let ((maybe-root (the :root)))
(if (the-object maybe-root root?)
maybe-root
(the-object maybe-root parent))))
(root-path (the root-path)
;;(remove :root-object-object (the root-path))
;;(the root-path)
))
(pushnew (list root-path)
(gdl-acc::%version-tree% root)
:test #'equalp
:key #'(lambda(item) (list (first item))))
(let (*leaf-resets*)
(let ((slot (glisp:intern (symbol-name attribute) :gdl-acc)))
(unbind-dependent-slots self slot)
(setf (slot-value self slot)
(list value nil t)))
(when remember?
(let ((root (let ((maybe-root (the :root)))
(if (the-object maybe-root root?)
maybe-root
(the-object maybe-root parent))))
(root-path (the root-path)
;;(remove :root-object-object (the root-path))
;;(the root-path)
))
(pushnew (list root-path)
(gdl-acc::%version-tree% root)
:test #'equalp
:key #'(lambda(item) (list (first item))))