Commit 2eed4923 authored by Dave Cooper's avatar Dave Cooper
Browse files

Merge branch 'release/1596'

parents 53225681 9901e1bb
*.wx64fsl
*.*x64fsl
*.fasl
*~
#*#
\ No newline at end of file
#*#
system-index.txt
\ No newline at end of file
......@@ -20,16 +20,22 @@
;; <http://www.gnu.org/licenses/>.
;;
;;
;; This file can be purged with latest build.
;;
;;
;; Below can be cleared with 1596
;;
(in-package :geom-base)
#+nil
(#+allegro
excl:without-package-locks
#-allegro progn
(in-package :geom-base)
(defun flush-center (ref-center datum p-plane u-plane &optional (u-datum u-plane))
(translate-along-vector ref-center u-datum
(distance-to-plane datum p-plane u-plane u-datum)))
......@@ -44,13 +50,14 @@
;; All below can be cleared as of 1596
;;
;;(in-package :gdl)
#+nil
(#+allegro
excl:without-package-locks
#-allegro progn
(in-package :gdl)
(defun %unbind-dependent-slots% (object slot &key updating?)
(let ((current (gethash (list object slot) *unbound-slots*)))
......@@ -88,14 +95,3 @@
(#+allegro
excl:without-package-locks
#-allegro progn
(in-package :gwl)
(define-object-amendment base-ajax-graphics-sheet ()
:input-slots
((viewport-js-text ""))))
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; 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/>.
;;
":gendl-asdf"
\ No newline at end of file
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; 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/>.
;;
(:gwl-graphics)
\ No newline at end of file
;;;; -*- coding: utf-8 -*-
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; 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 :cl-user)
(asdf:defsystem #:gendl-asdf
:description "asdf gendl artifacts loading"
:serial t
:version "20200720"
:depends-on nil
:components ((:file "gendl-asdf")))
;;;; -*- coding: utf-8 -*-
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; 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 :cl-user)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *asdf-found?* t)
(unless (find-package :asdf)
(setq *asdf-found?* nil)
(defpackage :asdf (:nicknames :asdf/interface asdf/lisp-action))))
(when (find-package :asdf)
(defclass asdf::gdl (asdf::cl-source-file) ((type :initform "gdl")))
(defclass asdf::gendl (asdf::cl-source-file) ((type :initform "gendl")))
(defclass asdf::lisp (asdf::cl-source-file) ()))
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless *asdf-found?* (delete-package :asdf)))
;;;; -*- coding: utf-8 -*-
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; 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/>.
;;
(asdf:defsystem #:geysr :description
"The Gendl® geysr Subsystem" :author "Genworks International"
:license "Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial t :version "20190912" :depends-on (:gwl-graphics)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings :gendl-asdf)
#+asdf-unicode :defsystem-depends-on #+asdf-unicode (:gendl-asdf)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:gdl "source/package") (:gdl "source/parameters")
(:gdl "source/assembly") (:gdl "source/initialize")
(:gdl "source/inspector") (:gdl "source/menu-node")
(:gdl "source/menu") (:gdl "source/tree")
(:gdl "source/user-inputs") (:gdl "source/viewport")
(:gdl "source/zzinit")))
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; 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/>.
;;
- Add ability to visit definition in source code for a node from geysr and from emacs.
- Add inspector inserted directly in tree under a node.
This diff is collapsed.
;;;; -*- coding: utf-8 -*-
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; 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/>.
;;
("package" "parameters")
;;;; -*- coding: utf-8 -*-
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; 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 :geysr)
(define-object iframe (sheet-section)
:input-slots (url)
:computed-slots ((div-class "gwl-iframe-section")
(inner-html
(with-cl-who-string ()
(if (the url)
(htm ((:iframe :id "EmbeddedUI" :title "Embedded UI"
:height "100%" :width "100%"
:seamless :seamless
:src (the url))))
(htm
(:p (:h2 (fmt "Welcome to Geysr.")))
(:p (fmt
"Geysr is for inspecting Genworks GDL models
and user interfaces while you're developing them."))
(:p (fmt "No object is currently selected and you're
in User Interface mode."))
(:p (fmt "Select a node from the tree atleft
to display its User Interface, if one exists."))))))))
;;;; -*- coding: utf-8 -*-
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; 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 :geysr)
(define-object geysr-try (assembly)
:computed-slots ((root-object-type (read-from-string "gdl-user::try"))))
(define-object geysr-bus (assembly)
:computed-slots ((root-object-type (read-from-string "bus::assembly"))))
(define-object geysr-house (assembly)
:computed-slots ((root-object-type (read-from-string "gdl-user::house"))))
(define-object geysr-missile (assembly)
:computed-slots ((root-object-type (read-from-string "missile::model"))))
(define-object geysr-robot (assembly)
:computed-slots ((root-object-type (read-from-string "robot:assembly"))))
(define-object geysr-cpacs (assembly)
:computed-slots ((root-object-type (read-from-string "xml-tree"))))
(define-object geysr-primi-plane (assembly)
:computed-slots ((root-object-type (read-from-string "primi-plane"))))
#+nil
(define-object geysr-tool-search (assembly)
:computed-slots ((root-object-type (read-from-string "gdl-user::tool-search"))))
(define-object geysr-spiral (assembly)
:computed-slots ((root-object-type (read-from-string "surf::spiral-curve-test"))))
(define-object geysr-bolt (assembly)
:computed-slots ((root-object-type (read-from-string "gdl-user::bolt-test"))))
(define-object geysr-glider (assembly)
:computed-slots ((root-object-type (read-from-string "wbl::glider"))))
(defun initialize ()
(let* ((directory (namestring
(or (probe-file (merge-pathnames "geysr/" (glisp:executable-homedir-pathname)))
(glisp:system-home :geysr)
(error "~&Geysr System Home not found, needed for its static/.~%"))))
(static (namestring (merge-pathnames "static/" directory))))
(with-all-servers (server)
(mapc #'(lambda(prefix file)
(publish-directory :prefix prefix :server server :destination file))
`("/geysr-static")
`(,static))
(publish-gwl-app "/glr" 'assembly)
(publish-gwl-app "/geysr" 'assembly)
(publish-gwl-app "/geysr-house" 'geysr-house)
(publish-gwl-app "/geysr-bus" 'geysr-bus)
(publish-gwl-app "/geysr-try" 'geysr-try)
(publish-gwl-app "/geysr-missile" 'geysr-missile)
(publish-gwl-app "/geysr-robot" 'geysr-robot)
(publish-gwl-app "/geysr-cpacs" 'geysr-cpacs)
(publish-gwl-app "/geysr-pp" 'geysr-primi-plane)
;;(publish-gwl-app "/geysr-ts" 'geysr-tool-search)
(publish-gwl-app "/geysr-spiral" 'geysr-spiral)
(publish-gwl-app "/geysr-bolt" 'geysr-bolt)
(publish-gwl-app "/geysr-glider" 'geysr-glider)
)))
;; (initialize)
;;;; -*- coding: utf-8 -*-
;;
;; Copyright 2020 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (Gendl).
;;
;; 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 :geysr)
(define-object inspector (sheet-section)
:input-slots
((node-root-path nil :settable)
onclick-function
(design-mode? nil)
root-object
tree-toplevel
geysr colors-default tree-type tree-node
display-controls-hash
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) (string-equal (subseq string 0 2) "$$"))))
(and *suppress-%%-messages?*
(let ((string (string keyword)))
(and
(> (length string) 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 (design-mode?
geysr root-object
tree-toplevel colors-default
tree-type tree-node display-controls-hash
onclick-function
click-mode relative-font-size))
(settables-form :type 'settables-form
:pass-down (show-settables? node geysr design-mode?)))
: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)))
#+nil
(perform-action!
(object)
(the geysr (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))
(with-error-handling () (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 (unless (the design-mode?)
(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 inner-html))))))
(let ((count -1))
(dolist (value-inspector (list-elements (the values)))
(let ((message (the-object value-inspector message)))
(incf count)
(htm (:tr
((:td :class "i-t-m") (str (the-object value-inspector message)))
((:td :class "i-t-v")
;;
;; 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 :class "i-t-v-click"
:onclick (unless (the design-mode?)
(the (gdl-ajax-call