Commit 2fa35ccc authored by Dave Cooper's avatar Dave Cooper

Moved geysr out to demos repo

because it's not released with GDL and it's in active development in lockstep with some demos.
parent 13c06c98
":gendl-asdf"
\ No newline at end of file
(:gwl-graphics)
\ No newline at end of file
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:geysr :description
"The Gendl® geysr Subsystem" :author "Genworks International"
:license "Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial t :version "20181204" :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/viewport")
(:gdl "source/zzinit")))
- Add ability to visit definition in source code for a node from geysr and from emacs.
- Add inspector inserted dirctly in tree under a node.
This diff is collapsed.
;;
;; Copyright (c) 2003, 2010 Genworks International, Bloomfield Hills,
;; MI, USA and Genworks BV, Delft, The Netherlands. The software, data
;; and information contained herein are proprietary to, and comprise
;; valuable trade secrets of, Genworks International and Genworks BV.
;; They are given in confidence pursuant to a written
;; nondisclosure/noncompete license agreement, and may be stored and
;; used only in accordance with the terms of such license.
;;
;;
(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)
)))
This diff is collapsed.
(in-package :geysr)
(define-object menu-node ()
:input-slots ((label "TBD")
(title (unless (the child-nodes) "This operation is not implemented yet..."))
(id (glisp:replace-regexp
(glisp:replace-regexp
(glisp:replace-regexp
(glisp:replace-regexp
(format nil "~s" (cons 'the (reverse (butlast (butlast (the root-path))))))
" " "__") "\\:" "") "\\(" "") "\\)" ""))
(onfocus nil)
(depth (if (or (not (the parent)) (not (typep (the parent) 'menu-node)))
0
(1+ (the parent depth)))))
:computed-slots ((child-nodes
(remove-if-not
#'(lambda(child)
(typep child 'menu-node)) (the children)))
(html (with-cl-who-string (:indent t)
(cond ((and (the child-nodes) (zerop (the depth)))
(htm ((:nav :id (the id))
(str (the ul)))))
((the child-nodes)
(htm (str (the ul))))
(t (htm ((:li :onmouseover "hideMenus(event);")
((:a :href "#"
:class "inactive"
:title (the title)) (str (the label)))))))))
(ul (with-cl-who-string (:indent t)
((:ul
:id (the id)
:onmouseover
(unless (zerop (the depth))
(format nil "addVisible(event, ~a);" (the depth))))
(dolist (child (the child-nodes))
(if (the-object child child-nodes)
(htm ((:li :id (the-object child id)
:tabindex "0"
:onmouseover "hideMenus(event);"
:onclick (when (zerop (the depth))
"makeMenuBarHoverable(event);"))
((:a :href "#" :id (format nil "a ~a" (the-object child id))
:title (the-object child title))
(str (the-object child label))
(when (>= (the-object child depth) 2)
(htm ((:span :class "menu-right-icon")
((:i :class "fas fa-caret-right"))))))
(str (the-object child html))))
(str (the-object child html))))))))
:functions
((set-new-geysr-object!
(object-type)
(the menu-object geysr (set-new-geysr-object! object-type)))))
This diff is collapsed.
;;
;; Copyright (c) 2003, 2010 Genworks International, Bloomfield Hills,
;; MI, USA and Genworks BV, Delft, The Netherlands. The software, data
;; and information contained herein are proprietary to, and comprise
;; valuable trade secrets of, Genworks International and Genworks BV.
;; They are given in confidence pursuant to a written
;; nondisclosure/noncompete license agreement, and may be stored and
;; used only in accordance with the terms of such license.
;;
;;
(in-package :gdl-user)
(gwl:define-package :geysr
(:export #:assembly #:viewport #:inspector #:status-object #:menu-section
#:*internal-keywords* #:*suppress-%%-messages?* #:*suppress-$$-messages?*
#:initialize))
;;
;; 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 :geysr)
(defparameter *these-features* (list :geysr))
(defparameter *settings* nil)
(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))
(defparameter *suppress-%%-messages?* t "Boolean. Set to nil if you want to see messages starting and ending with %% in tasty inspector. Defaults to t.")
(defparameter *suppress-$$-messages?* t "Boolean. Set to nil if you want to see messages starting with $$ in tasty inspector. Defaults to t.")
;;
;; 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 :geysr)
(defparameter *trap-errors?* t)
(define-object tree (sheet-section)
:documentation (:description "Implements an interactive graphical tree from a nested list using HTML list element and CSS.")
:input-slots
(("Function of one argument. This function takes a node in the tree as an argument, and should return
a plist with keys :function and :arguments, which is a function in the bashee which will be called
with the given arguments when the given node in the tree is clicked."
onclick-function nil)
(design-mode? nil)
click-mode
(respondent (the parent))
(tree-dom-id (the dom-id))
(target-object self)
(display-controls-hash nil)
(%tree-root% self)
(expand-mode :remember :settable)
(show-onmouseover-buttons? t)
)
:computed-slots
(
;;
;; This overrides the one from skeleton-ui-element because we don't want to filter
;; the root-object-object in the case of the tree.
;;
;;(base64-encoded-root-path (base64-encode-safe (format nil "~s" (the root-path))))
(tatu-color (or (when (getf (the local-display-controls) :color)
(string-append "#" (getf (the local-display-controls) :color)))
(multiple-value-bind (color error)
(with-error-handling () (the target-object color-hex))
(if (typep error 'error) (lookup-color :red :format :hex) color))))
(tatu-line-thickness (or (getf (the local-display-controls) :line-thickness)
(or (with-error-handling () (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) 'tree) (the parent local-display-controls))))
(kids-error (when (typep (the safe-children) 'error) (the safe-children)))
(safe-children (append (if *trap-errors?*
(the target-object safe-children)
(the target-object children))
(the target-object visible-children)))
(safe-strings-for-display
(let ((string (multiple-value-bind (strings error)
(with-error-handling () (the target-object
strings-for-display))
(cond ((typep error 'error)
(format nil "! ~a ! from strings-for-display" error))
((the color-error?)
(format nil "~a ! ~a ! from color-hex" strings
(the color-or-error)))
(t strings)))))
(if (stringp string) string
(progn
(warn "safe-strings-for-display returned non-string: ~s.
Converting to a string to avoid error."
string)
(format nil "~s" string)))))
(color-or-error (multiple-value-bind (color error)
(with-error-handling () (the target-object color-hex))
(if (typep error 'error) error color)))
(color-error? (typep (the color-or-error) 'error))
(color-hex (if (the color-error?) (lookup-color :red :format :hex) (the color-or-error)))
(safe-child-first (length (the target-object safe-children)))
(closed? (not (eql self (the %tree-root%))) :settable)
(open? (not (the closed?)))
(child-nodes (list-elements (the nodes)))
(inner-html
(with-cl-who-string ()
(if (the target-object)
(htm ((:ul :id "tree-root" :class "geysr-tree")
(str (the tree-node-view))))
(htm ((:span :class "geysr-tree")
"No Object Instantiated")))))
(tree-node-view
(with-cl-who-string ()
(:li
(when (the child-nodes)
(if (the closed?)
(htm ((:span
:class "directory far fa-plus-square"
:title "Expand"
:style "cursor: default;"
:onclick (unless (the design-mode?) (the (gdl-ajax-call :function-key :toggle-state!))))))
(htm ((:span
:class "expanded far fa-minus-square"
:title "Collapse"
:style "cursor: default;"
:onclick (unless (the design-mode?)(the (gdl-ajax-call :function-key :toggle-state!))))))))
(unless (the child-nodes)
(htm ((:span :class "leaf fab fa-envira"))))
((:span :class "tree-node"
:title (glisp:replace-regexp (string-capitalize (the click-mode)) "-" " ")
:onclick (when (and (not (the design-mode?)) (the onclick-function))
(funcall (the onclick-function) (the target-object))))
(esc (the safe-strings-for-display)))
;; if there are siblings, make them here (inside the li)
(when (and (typep self 'tree)
(the open?)
(the child-nodes))
(htm
(:ul
(mapc #'(lambda (tree-node)
(str (the-object tree-node tree-node-view)))
(the child-nodes)))))))))
:functions
((toggle-state! ()
(the (set-slot! :closed? (not (the closed?))))
(the propogate-toggle!)
)
(propogate-toggle!
()
(ecase (the expand-mode)
(:auto-close (the %tree-root% (close-all! :except self))
(the expand-parents!))
(:children (mapc #'(lambda(node) (when (null (the-object node closed?))
(the-object node (set-slot! :closed? t))))
(the child-nodes)))
(:leaves (mapc #'(lambda(node) (the-object node open-all!))
(the child-nodes)))
(:remember ;; do nothing
))
)
(open-all!
()
(the (set-slot! :closed? nil))
(mapc #'(lambda(node) (the-object node open-all!))
(the child-nodes)))
(close-all!
(&key except)
(unless (eql self except) (the (set-slot! :closed? t)))
(mapc #'(lambda(node) (the-object node (close-all! :except except)))
(the child-nodes)))
(expand-parents!
()
(when (and (the parent)
(typep (the parent) 'tree))
(the parent (set-slot! :closed? nil))
(the parent expand-parents!)))
(set-and-call-click-mode!
(mode)
(ecase mode
(:inspect (the inspector (set-object! (the target-object))))
(:add-leaves (the viewport (add-leaves! (the target-object))))
(:highlight (if (the viewport (leaves-displayed? (the target-object)))
(the viewport (delete-leaves! (the target-object)))
(the viewport (add-leaves*! (the target-object))))))))
:hidden-objects ((nodes :type 'tree
:sequence (:size (length (the safe-children)))
:remember-children? t
:pseudo-inputs (remember-children?) ;; FLAG -- need internal Gendl update to remove need for this.
:pass-down (%tree-root% respondent onclick-function expand-mode display-controls-hash
show-onmouseover-buttons? click-mode)
:target-object (let ((node (nth (the-child index) (the safe-children))))
(if (listp node)
(make-object 'tasty-child-error
:error (getf node :error)
:object-key (getf node :object-key))
node)))))
(define-object tasty-child-error ()
:input-slots (error object-key)
:computed-slots ((strings-for-display (format nil "~a threw error: ~a" (the object-key) (the error)))))
This diff is collapsed.
;;
;; Copyright 2002-2011, 2012 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; 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)
(glisp:set-features *these-features*)
#menu
{
z-index: 9;
font-family: "Lucida Grande", Helvetica, Arial, sans-serif;
}
#menu > ul
{
padding: 0px 10px;
margin: 0;
}
#menu ul
{
list-style: none;
}
#menu > ul > li
{
float: left;
position: relative;
padding-left: 3px;
padding-right: 3px;
width: auto;
color: rgb(68, 68, 68);
margin-left: 0px;
}
#menu ul ul li
{
padding-left: 15px;
padding-right: 15px;
white-space: nowrap;
}
#menu ul ul li a
{
display: flex;
flex-direction: row;
align-items: center;
}
#menu ul li
{
outline: none;
}
#menu a
{
display: block;
text-decoration: none;
padding: 5px 5px;
color: rgb(68, 68, 68);
}
#menu > ul ul
{
position: absolute;
background: rgb(240, 240, 240);
left: 0;
top: 100%;
visibility: hidden;
opacity: 0.95;
font-size: 15px;
box-shadow: 0 3px 5px rgba(0,0,0,0.12), 0 3px 5px rgba(0,0,0,0.24);
border-bottom-left-radius: 5px;
border-bottom-right-radius: 5px;
margin-left: 0px;
}
#menu > ul ul ul
{
left: 100%;
top: -3px;
border-top-left-radius: 5px;
border-top-right-radius: 5px;
}
#menu > ul ul > li:last-child
{
margin-bottom: 3px;
}
#menu > ul ul > li:first-child
{
margin-top: 3px;
}
#menu ul ul hr
{
border: 1px solid rgb(201, 201, 201);
margin: 0px -15px;
/* width: 165px; */
}
#menu li > ul
{
margin-left: 0px;
padding-left: 0px;
}
#menu > ul ul li
{
position: relative;
}
#menu ul li ul li > a,
#menu ul li ul li
{
background: rgb(240, 240, 240);
color: rgb(68, 68, 68);
}
#menu ul li.visible > a,
#menu ul li.visible,
#menu.hoverable ul li:hover > a,
#menu.hoverable ul li:hover
{
color: rgb(240, 240, 240) !important;
background: rgb(0, 144, 248) !important;
}
#menu ul li ul .li-selected
{
color: #407af2;
}
#menu ul li.visible > ul,
#menu.hoverable ul li:hover > ul
{
visibility: visible;
}
.li-heading, #menu.hoverable .li-heading:hover
{
background: rgb(240, 240, 240);
color: rgb(68, 68, 68);
padding: 5px 5px;
padding-right: 10px;
font-weight: bold;
}
.fa-check
{
padding-right: 5px;
}
.menu-right-icon
{
margin-left: auto;
padding-left: 12px;
transform: scale(1.8,1.0);
}
#menu
{
z-index: 9;
font-family: "Lucida Grande", Helvetica, Arial, sans-serif;
}
#menu > ul
{
padding: 0px 10px;
margin: 0;
}
#menu ul
{
list-style: none;
}
#menu > ul > li
{
float: left;
position: relative;
padding-left: 3px;
padding-right: 3px;
width: auto;
color: rgb(68, 68, 68);
margin-left: 0px;
}
#menu ul ul li
{
padding-left: 15px;
padding-right: 15px;
white-space: nowrap;
}
#menu ul ul li a