Commit 64df9bb4 authored by Dave Cooper's avatar Dave Cooper

added geysr to local codebase.

parent e0a03df1
;;;; -*- 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 "20181012" :depends-on nil
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-unicode :defsystem-depends-on #+asdf-unicode ()
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:gdl "source/package") (: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")))
- 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-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-dragster (assembly)
:computed-slots ((root-object-type (read-from-string "wbl::dragster-assembly"))))
(define-object geysr-glider (assembly)
:computed-slots ((root-object-type (read-from-string "wbl::glider-assembly"))))
(define-object geysr-green-car (assembly)
:computed-slots ((root-object-type (read-from-string "wbl::green-car-assembly"))))
(define-object geysr-mousetrap-car (assembly)
:computed-slots ((root-object-type (read-from-string "wbl::mousetrap-car-assembly"))))
(define-object geysr-structures (assembly)
:computed-slots ((root-object-type (read-from-string "wbl::structures-assembly"))))
(define-object geysr-shelter (assembly)
:computed-slots ((root-object-type (read-from-string "wbl::shelter-assembly"))))
(define-object geysr-rover (assembly)
:computed-slots ((root-object-type (read-from-string "wbl::rover-assembly"))))
(define-object geysr-water-rocket (assembly)
:computed-slots ((root-object-type (read-from-string "wbl::water-rocket-assembly"))))
(define-object geysr-parm (assembly)
:computed-slots ((root-object-type (read-from-string "wbl::parm-assembly"))))
(define-object geysr-wind-turbine (assembly)
:computed-slots ((root-object-type (read-from-string "wbl::wind-turbine-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"))))
(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))))
(print-variables directory static)
(with-all-servers (server)
(mapc #'(lambda(prefix file)
(print-variables 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-missile" 'geysr-missile)
(publish-gwl-app "/geysr-robot" 'geysr-robot)
(publish-gwl-app "/geysr-dragster" 'geysr-dragster)
(publish-gwl-app "/geysr-glider" 'geysr-glider)
(publish-gwl-app "/geysr-green-car" 'geysr-green-car)
(publish-gwl-app "/geysr-mousetrap-car" 'geysr-mousetrap-car)
(publish-gwl-app "/geysr-parm" 'geysr-parm)
(publish-gwl-app "/geysr-rover" 'geysr-rover)
(publish-gwl-app "/geysr-shelter" 'geysr-structures)
(publish-gwl-app "/geysr-structures" 'geysr-structures)
(publish-gwl-app "/geysr-water-rocket" 'geysr-water-rocket)
(publish-gwl-app "/geysr-wind-turbine" 'geysr-wind-turbine)
(publish-gwl-app "/geysr-cpacs" 'geysr-cpacs)
(publish-gwl-app "/geysr-pp" 'geysr-primi-plane))))
;;(initialize!)
This diff is collapsed.
(in-package :geysr)
(define-object menu-node ()
:input-slots (label (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)))))))))
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
#:*suppress-%%-messages?* #:*suppress-$$-messages?*))
;;
;; 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 ()
((:ul :id "tree-root" :class "geysr-tree")
(str (the tree-node-view)))))
(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)))))
(in-package :geysr)
(define-object user-inputs (sheet-section)
:input-slots (root-object)
:computed-slots
((inner-html (defaulting (the root-object pui inner-html) nil))))
This diff is collapsed.
#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
{
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;