Commit cc3a7433 authored by Dave Cooper's avatar Dave Cooper
Browse files

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"))
......
;;
;; Copyright 2002, 2009 Genworks International and Genworks BV
;;
;; 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 :tasty)
(defmacro ignore-errors-with-warning (&rest body)
(let ((values (gensym))
(error (gensym)))
`(let* ((,values (multiple-value-list (ignore-errors ,@body)))
(,error (second ,values)))
(if (and ,error (typep ,error 'error))
(progn (warn "~a" ,error)
(format nil "! ERROR: ~a !" ,error))
(apply #'values ,values)))))
;;
;; FLAG -- promote to utilities.
;;
(defun one-line (string)
(glisp:replace-regexp (glisp:replace-regexp string (format nil "~%") " ") "'" "\\'" ))
(defparameter *suppress-%%-messages?* t)
;;
;; FLAG -- replace with abstract associative map
;;
(defparameter *internal-keywords*
(list :query-plist :aggregate :all-mixins :background-color
:base64-encoded-root-path :bashee :beziers :bounding-bbox
:check-sanity? :color-decimal :color-hex :color-palette :cookies-received
:cookies-to-send :dash-pattern :dom-id :fill-color-decimal
:fixed-url-prefix :header-plist :home-page :instance-id
:last-visited-root-path :left-handed? :local-bbox :local-box
:local-center :local-left-handed? :local-orientation :inner-html
:obliqueness :parent-tree :plain-url? :possible-nils
:quantify-box :query-toplevel :refresh-toggle :remote-id :respondent
:return-object :root-path-string :target :time-instantiated
:time-last-touched :transitory-slots :tree-root
:url-encoded-root-path :use-local-box? :viewable-slots
:viewpoints :visible-children :vrml-center))
(define-object inspector (base-html-sheet)
:input-slots
((node-root-path nil :settable)
root-object
tree-toplevel
tatu-root colors-default tree-type tree-node
display-controls-hash
perform-action-function click-mode
(relative-font-size "-1")
(node (when (the root-object) (the root-object (follow-root-path (the node-root-path)))))
(expand? (< (the depth) 1) :settable)
(depth 0)
)
:computed-slots
(
(show-settables? nil :settable)
(messages-local (set-difference (the node (message-list :message-type :local))
(append (the node (message-list :message-type :local
:category :methods))
(the node (message-list :message-type :local
:category :uncached-attributes)))))
(messages (safe-sort
(remove-if
#'(lambda (keyword)
(or (member keyword *internal-keywords*)
(and *suppress-%%-messages?*
(let ((string (string keyword)))
(and
(> (length string) 2)
(or (string-equal (subseq string 0 2) "$$")
(and (eql (aref string 0) #\%)
(or (eql (aref string 1) #\%)
(eql
(aref string (1- (length string)))
#\%)))))))))
(set-difference (the :node (:message-list))
(append (the
:node
(:message-list :category :methods))
(the :node (:message-list
:category
:uncached-attributes)))))
#'string<))
(check-links nil :settable))
:hidden-objects
((values :type 'value-inspector
:depth (1+ (the depth))
:sequence (:size (length (the messages)))
:respondent (the respondent)
:message (nth (the-child index) (the messages))
:parent-node (the node)
:pass-down (
tatu-root root-object
tree-toplevel colors-default
tree-type tree-node display-controls-hash
perform-action-function click-mode relative-font-size))
(settables-form :type 'settables-form
:pass-down (show-settables? node tatu-root)))
:functions
(
(visit-definition-in-emacs
(definition)
(declare (ignore definition))
(error "Sorry! This is supposed to do 'lisp-find-definition' in emacs, but not working yet... Please send email to support@genworks.com"))
#+nil
(visit-definition-in-emacs
(definition)
(let ((emacs-lisp-command (format nil "(fi:lisp-find-definition ~s)" definition)))
(print-variables emacs-lisp-command)
#+allegro (lep::eval-in-emacs emacs-lisp-command)))
(perform-action!
(object)
(the tatu-root (perform-action! object)))
(message-evaluate
(message)
;;
;; FLAG -- note we have to bash the view-toggle because no bashing
;; is actually happening when we evaluate the message, so the view
;; does not update by itself.
;;
(the toggle-view-toggle!)
(the (set-slot! :expand? t))
(ignore-errors-with-warning (the node (evaluate message)))
#+nil
(multiple-value-bind (value error) (ignore-errors (the node (evaluate message)))
(let* ((error? (and error (typep error 'error)))
(value (if error? (format nil "ERROR: ~a" error) value)))
(when error? (the node (set-slot! message value))))))
(set-object! (object) (the (set-slot! :node-root-path (the-object object root-path))))))
(define-lens (html-format inspector)()
:output-functions
((inner-html
()
(with-cl-who ()
(if (the node)
(write-the inspector-body)
(htm "No Object Instantiated"))))
(inspector-body
()
(with-cl-who ()
(:center
((:span :style "font-style: italic; font-weight: bold;")
(:p "Inspecting: "
(fmt "\"~a\"" (the node strings-for-display))
:br
"root-path: "
(esc (format nil "~s"
(cons 'the (reverse (butlast (the node-root-path))))))
(unless (butlast (the node-root-path))
(htm " [the root object]"))
:br
" type: " ((:span :style "color: blue; cursor: pointer;"
:onclick (the (gdl-ajax-call :function-key :visit-definition-in-emacs
:arguments (list (format nil "~s" (the node type))))))
(esc (format nil "~s" (the node type)))))))
((:table :class "inspector-table" :border 1)
(:tr (:td "Settables") (:td (str (the settables-form control-view))))
(when (the settables-form show-settables?)
(htm (:tr ((:td :colspan 2)
(str (the settables-form main-div))))))
(let ((count -1))
(dolist (value-inspector (list-elements (the values)))
(let ((message (the-object value-inspector message)))
(incf count)
(htm (:tr
(:td (str (the-object value-inspector message)))
(:td
;;
;; FLAG -- push everything to do with node into value-inspector
;;
(let ((slot-status (if (the expand?)
(the node (slot-status message)) :unbound)))
(case slot-status
(:unbound
(htm ((:span :style "color: blue; font-style: italic; cursor: pointer;"
:onclick (the (gdl-ajax-call
:function-key :message-evaluate
:arguments (list message))))
"Unbound")))
(otherwise (str (the-object value-inspector value-display))))))))))))))))
(define-object value-inspector (inspector)
:input-slots ((message nil)
parent-node
root-object
tatu-root
click-mode
(value (with-error-handling ()
(the parent-node (evaluate (the message))))))
:computed-slots
((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))
(gdl::quantification :gdl-sequence)
(gdl::gdl-basis :gdl-atom))))
(value-cardinality (case (the value-type)
(:list (length (the value)))
(:gdl-sequence (the value number-of-elements))
(otherwise 0)))
(truncated-sequence (unless (zerop (the value-cardinality))
(with-output-to-string (ss)
(let ((*print-length* 3))
(pprint (the value) ss)))))
(expanded? nil :settable)
(clickable? (and (not (the expanded?))
(or (member (the value-type)
(list :list :gdl-sequence :gdl-atom))
(and (eql (the value-type) :gdl-3d-point)
(member (the click-mode)
(list :add-leaves
:add-leaves*
:add-node
:draw-leaves
:draw-node
:delete-leaves))))))
(3d-vector? (and (typep (the value) 'vector)
(= (length (the value)) 3)
(every #'floatp (the value))))
(value-display
(ignore-errors-with-warning
(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")
(if (the clickable?) "cursor: pointer;" ""))
:onclick (case (the value-type)
(:gdl-atom
(the (gdl-ajax-call
:function-key :perform-action!
:arguments (list value))))
(:gdl-3d-point
(when (the clickable?)
(the (gdl-ajax-call
:function-key :perform-action!
;;: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?)
(the (gdl-ajax-call
;;:bashee self
:function-key :set-slot!
:arguments (list :expanded? t)))))))
(cond ((or (eql (the value-type) :list)
(eql (the value-type) :gdl-sequence))
(if (the expanded?)
(htm ((:table :border 1)
(:tr
(:td ((:span :style "color: blue; cursor: pointer;"
:onclick (the (gdl-ajax-call
:function-key :set-slot!
:arguments (list :expanded? nil))))
"X"))
(:td (str
(ecase (the value-type)
(:list "A List")
(:gdl-sequence "A GDL Sequence")))))
(let ((index -1))
(dolist (row (list-elements (the sequence-elements)))
(htm (:tr (:td (str (incf index)))
(: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 (
#+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)))
(sequence-elements :type 'value-inspector
:sequence (:size (the value-cardinality))
:pass-down (root-object tatu-root click-mode)
:value (the (get-value-element (the-child index)))))
:functions
((get-value-element
(index)
(case (the value-type)
(:list (nth index (the value)))
(:gdl-sequence (the value (get-member index)))))))
(define-object settables-form (base-html-sheet)
:input-slots
(show-settables? node tatu-root)
:computed-slots
((settables
(let (settables)
(maphash #'(lambda(key val)(declare (ignore val))
(push key settables))
(the node %settable-slots%))
(nconc settables (the node (message-list :category :required-input-slots)))
(sort (remove-if
#'(lambda (keyword)
(or (member keyword *internal-keywords*)