Commit b10a9a98 authored by Dave Cooper's avatar Dave Cooper

merging again for master?

parents 3c97e16c 7d83ae43
......@@ -3,9 +3,9 @@
(asdf:defsystem #:dom :description
"The Gendl® dom Subsystem" :author "Genworks International" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20170524" :depends-on (:cl-who :yadd)
:version "20181023" :depends-on (:cl-who :yadd)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-unicode :defsystem-depends-on #+asdf-unicode nil
#+asdf-unicode :defsystem-depends-on #+asdf-unicode ()
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "base/source/package") (:file "base/source/assembly")
......
":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)))))))))
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 ()
((: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)))))
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);
}