Commit 9901e1bb authored by Dave Cooper's avatar Dave Cooper
Browse files

removed defunct geysr

parent 44c2d05b
;;
;; 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))))
(in-package :asdf)
(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) ())
(defclass asdf::table (asdf::cl-source-file) ((type :initform "table")))
(defmethod perform ((o compile-op) (c asdf::table))
(perform-peruse-file o c))
(defmethod perform ((o load-op) (c asdf::table))
(perform-peruse-file o c))
(defun perform-peruse-file (o c)
"Perform the perusal of icad-style catalog table."
(declare (ignore o))
(let ((input-file (slot-value c 'asdf/component:absolute-pathname)))
(gendl::peruse-file input-file
:load t))))
(in-package :cl-user)
(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")))
(in-package :gdl-user)
(defparameter *systems* (list :gendl-patches :geysr))
(defparameter *monolithic-systems* (list :cl-markdown))
(load-quicklisp)
(defun ql-add-local (dir)
(pushnew dir ql:*local-project-directories* :test #'equalp))
(defparameter *geysr-home* (make-pathname :name nil :type nil :defaults *load-pathname*))
(defun make-geysr-fasl (&key (output (translate-logical-pathname "~/tmp/geysr/")))
(load-quicklisp)
(mapc #'ql-add-local (list "~/genworks/gendl-patches/" *geysr-home*))
(when (probe-file output)
(uiop:delete-directory-tree output :validate #'(lambda(arg) (search "tmp" (namestring arg)))))
(ensure-directories-exist output)
(dolist (system *monolithic-systems*)
(asdf:operate 'asdf:monolithic-compile-bundle-op system)
(let ((path (asdf:output-file 'asdf:monolithic-compile-bundle-op system)))
(uiop:copy-file path
(make-pathname :defaults output
:name (pathname-name path)
:type (pathname-type path)))))
(dolist (system *systems*)
(asdf:operate 'asdf:compile-bundle-op system)
(let ((path (asdf:output-file 'asdf:compile-bundle-op system)))
(uiop:copy-file path
(make-pathname :defaults output
:name (pathname-name path)
:type (pathname-type path)))))
(glisp:copy-directory (merge-pathnames "static/" (glisp:system-home :geysr))
(merge-pathnames "geysr-static/" output))
(with-open-file (out (merge-pathnames "load.lisp" output)
:direction :output :if-exists :supersede :if-does-not-exist :create)
(let ((format-string
(format nil "(in-package :gdl-user)
(defparameter *geysr-home* (make-pathname :name nil :type nil :defaults *load-pathname*))
~~{(load (merge-pathnames \"~~(~~a~~)--all-systems.~a\" *geysr-home*))~~^~~%~~}
~~{(load (merge-pathnames \"~~(~~a~~)--system.~a\" *geysr-home*))~~^~~%~~}
(geysr:initialize)
"
glisp:*fasl-extension* glisp:*fasl-extension*
)))
(format out format-string *monolithic-systems* *systems*))))
;;
;; 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.
;;;; -*- 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/>.
;;
#|
ToDO:
x 1. Update welcome message to reflect empty object and refer to File->New.
2. Adjust spacing of tree for empty object to give enough room not to
obstruct File->New menu.
|#
(in-package :geysr)
(defvar *developing?* nil)
(defvar *user-mode?* nil)
#+nil ;; remove after successful fresh build.
(excl:without-package-locks
(excl:without-redefinition-warnings
(defun gdl::same-tree? (obj1 obj2)
(or (eql (gdl-acc::%root% obj1) (gdl-acc::%root% obj2))
(let ((root-1 (gdl-acc::%root% obj1)) (root-2 (gdl-acc::%root% obj2)))
(let ((god-parents-1 (gdl-acc::%god-parents% root-1))
(god-parents-2 (gdl-acc::%god-parents% root-2)))
(member root-1 god-parents-2) (member root-2 god-parents-1)))))
(defun add-godparent (target new)
(pushnew new (gdl-acc::%god-parents% target)))))
(define-object assembly (base-ajax-sheet)
:input-slots
((viewport-dimensions (list :width 800 :length 550) :settable)
(design-mode? nil :settable)
(user-mode?-default *user-mode?*)
(additional-css-links nil)
(empty-display-list-greeting
(with-cl-who-string ()
(:p (:h2 (fmt "Welcome to Geysr.")))
(:p (fmt
"Geysr is for inspecting Genworks GDL models
while you're developing them. You can see your
model structure in the tree at the upper left."))))
(menu-div-class nil)
(menu-div-style nil)
(menu-included-children :all))
:computed-slots
(
(user-mode? (the menu user-mode?))
(click-mode :add-leaves :settable)
(expand-mode :remember :settable)
(onclick-function
#'(lambda(object)
(the (gdl-ajax-call :function-key :perform-action!
:arguments (list :root-path (the-object object root-path))))))
(local-assets? (not (the design-mode?)) :settable)
(use-ajax? (not (the design-mode?)))
;;
;; FLAG -- try toggling this in a sheet-section depending on
;; viewport image-format. Seems impossible to evaluate
;; newly injected <script src=...> with Ajax, though.
;;
;;(use-raphael? (not (the design-mode?)))
(use-svgpanzoom? t) ;;(not (the design-mode?))
;;(use-x3dom? (not (the design-mode?)))
(use-x3dom? t)
(use-fontawesome? t)
;;(use-anyresize? (not (the design-mode?)))
(use-anyresize? t)
(root-object-type nil :settable)
(root-object-type-valid? (and (the root-object-type)
(typep (ignore-errors
(find-class
(ignore-errors
(read-safe-string (the root-object-type)))))
'gdl-class)))
(root-object (the root-object-object) :settable)
(root-object-object
(when (the root-object-type-valid?)
(make-object (the root-object-type)
:god-parents (list self)
:strings-for-display (format nil "~s" (the root-object-type)))))
(ui-object nil :settable)
(additional-header-content
(with-cl-who-string ()
(unless (the design-mode?)
(htm
((:meta :name "viewport" :content "width=device-width, initial-scale=1, shrink-to-fit=no"))
((:meta :name "description" :content "Geysr Object Browser"))
((:meta :name "author" :content "Genworks"))
((:meta :name "keywords" :content "KBE, CL"))
((:meta :name "mobile-web-app-capable" :content "yes"))
((:meta :name "viewport" :content "width=device-width, initial-scale=1.0"))
(unless *developing?*
(htm ((:script :type "text/javascript")
"window.onerror = function(){location.reload()};")))))
(str (the local-css-link))))
(body-onpageshow (when (the use-ajax?) "gdlResize();"))
(body-onresize (when (the use-ajax?) "gdlResize();"))
(body-onpageload "gdlResize();")
(menu-clear-func #'(lambda()
(the (restore-slot-default! :ui-object))
(the viewport clear!)))
(local-css-link
(with-cl-who-string ()
(string-append
(htm
((:link :href "/geysr-static/styles.css" :rel "stylesheet"))
((:link :href "/geysr-static/menu.css" :rel "stylesheet")))
(if (the additional-css-links)
(dolist (link (ensure-list (the additional-css-links)))
(htm ((:link :href link :rel "stylesheet")))) ""))))
(main-sheet-body
(with-cl-who-string (:indent t)
((:div :class "grid")
((:div :id "menu-cell" :class "cell menu menuToggle")
((:input :type "checkbox" :class "dp-none"))
((:span :class "dp-none"))((:span :class "dp-none"))((:span :class "dp-none"))
(str (the menu main-div)))
((:div :id "tree" :class "cell tree") (str (the tree main-div)))
((:div :id "inspector" :class "cell inspector")
(str (the inspector-or-inputs-section main-div)))
((:div :id "viewport" :class "cell viewport")
(str (the viewport main-div)))
#+nil
((:div :id "viewport" :class "cell viewport")
(str (the viewport-section main-div))
#+nil
(str (case (the click-mode)
(:user-interface (the ui main-div)) (otherwise (the viewport main-div)))))
#+nil
((:div :id "viewport" :class "cell viewport")
(str (the ui main-div)) (str (the viewport main-div))
#+nil
(str (case (the click-mode)
(:user-interface (the ui main-div)) (otherwise (the viewport main-div)))))
((:div :id "viewport-script") (str (the viewport-script main-div)))
((:div :id "menu-script") (str (the menu-script main-div))))
(unless (the design-mode?)
(htm
(:script "
tree = document.getElementById('tree');
tree.addEventListener('onresize', function(){gdlResize();});
"))))))
:hidden-objects
((inspector-or-inputs-section
:type 'sheet-section
:inner-html (with-cl-who-string ()
(str (if (the user-mode?) (the user-inputs main-div)
(the inspector main-div)))))
(menu :type 'menu
:div-class (the menu-div-class)
:div-style (the menu-div-style)
:included-children (the menu-included-children)
:pass-down (design-mode? local-assets? click-mode expand-mode)
:user-mode? (the user-mode?-default)
:set-click-mode-func #'(lambda(mode) (the (set-slot! :click-mode mode)))
:set-expand-mode-func #'(lambda(mode) (the (set-slot! :expand-mode mode)))
:reset-zoom-func #'(lambda() (the viewport reset-zoom!))
:set-image-format-func #'(lambda(format)
(the viewport image-format-selector (set-slot! :value format)))
:set-view-func #'(lambda(view) (the viewport view-selector (set-slot! :value view)))
:clear-func (the menu-clear-func)
;;:clear-func #'(lambda()
;;(the (restore-slot-default! :ui-object))
;;(the viewport clear!))
:update-root-func #'(lambda() (the update-root!))
:set-self-func #'(lambda() (set-self self))
:up-root-func #'(lambda() (let ((parent (the root-object parent)))
(when parent (the (set-slot! :root-object parent)))))
:reset-root-func #'(lambda() (the (set-slot! :root-object (the root-object-object))))
:image-format (the viewport image-format-selector value)
:view (the viewport view-selector value)
:geysr self
:viewport-js-text (the viewport viewport-js-text)
:image-format-plist (the viewport image-format-plist)
:image-format-plist (list :png "PNG image"
:jpeg "jpeg image"
:x3dom "Shaded"
;;:web3d "VRML/X3D"
:svg "Wireframe")
)
(tree :type 'tree
:pass-down (onclick-function click-mode expand-mode design-mode?)
:display-controls-hash (make-hash-table)
:target-object (the root-object))
(user-inputs :type 'user-inputs
:geysr self
:node (the inspector node)
:pass-down (root-object))
(inspector :type 'inspector
:pass-down (root-object onclick-function click-mode design-mode?)
:geysr self
:display-controls-hash (the tree display-controls-hash))
(viewport-section :type 'sheet-section
:div-class "gwl-iframe-section"
:inner-html (if (eql (the click-mode) :user-interface)
(the ui inner-html)
(the viewport inner-html)))
(ui :type 'sheet-section)
#+nil
(ui :type 'iframe
:url (when (the ui-object)
(progn (gwl::register-instance (the ui-object))
(the ui-object url))))
(viewport :type 'viewport
:geysr self
:div-class "viewport-wrapper"
:pass-down (root-object root-object-type)
:length (getf (the viewport-dimensions) :length)
:width (getf (the viewport-dimensions) :width)
:onclick-function nil
:background-color "#d3d3d3"
:empty-display-list-message
(with-cl-who-string ()
(str (the empty-display-list-greeting))
(:p "The Display List is currently empty. You may click a node (in the tree at the upper-left) to apply the "
(:i ((:a :class "menu-show" :href "#" :onclick (the (menu-control-js "the__mode")))
(fmt "~a" (the click-mode)))) " operation.")
(:p "The rendering mode is currently "
(:i ((:a :class "menu-show" :href "#"
:onclick (the (menu-control-js
(list "the__view" "the__view__graphics-format-menu"))))
(fmt "~a" (the menu image-format))))
(let ((graphics-format-show (the (menu-control-js
(list "the__view" "the__view__graphics-format-menu")))))
(ecase (the menu image-format)
(:svg
(htm ". You can try "
(:i ((:a :class "menu-show" :href "#"
:onclick graphics-format-show)
"x3dom"))
" for a shaded, navigable view, or one of the "
(:i ((:a :class "menu-show" :href "#"
:onclick graphics-format-show)
"raster formats")) " (png or jpeg)."))
(:x3dom
(htm ". You can try "
(:i ((:a :class "menu-show" :href "#"
:onclick graphics-format-show)
"svg"))
" for a wireframe, pannable and zoomable view, or one of the "
(:i ((:a :class "menu-show" :href "#"
:onclick graphics-format-show)
"raster formats")) " (png or jpeg)."))
((:png :jpeg)
(htm ". You can try "
(:i ((:a :class "menu-show" :href "#"
:onclick graphics-format-show)
"svg"))
" for a wireframe, pannable and zoomable view, or "
(:i ((:a :class "menu-show" :href "#"
:onclick graphics-format-show)
"x3dom")) " for a shaded, navigable view.")))))))