Commit 01d32a0e authored by Dave Cooper's avatar Dave Cooper
Browse files

tentative implementation of detached-tasty

parent 95fd97be
...@@ -61,7 +61,15 @@ o allow input of required input-slots. ...@@ -61,7 +61,15 @@ o allow input of required input-slots.
(uri-style-sheet (when (the use-jquery?) (string-append (the uri-static-gwl-styles) "tasty-layout.css"))) (uri-style-sheet (when (the use-jquery?) (string-append (the uri-static-gwl-styles) "tasty-layout.css")))
#+nil
(tatu-update-function
#'(lambda()
(format t "~%~%At 1~%~%")
(the root-object update!)
(mapsend (list (the tree) (the inspector) (the viewport)) :update!)))
#+nil
(tatu-update-function (tatu-update-function
#'(lambda() #'(lambda()
(the (set-slot! :root-object (the root-object))) (the (set-slot! :root-object (the root-object)))
...@@ -167,9 +175,13 @@ o allow input of required input-slots. ...@@ -167,9 +175,13 @@ o allow input of required input-slots.
;;:show-onmouseover-buttons? nil ;;:show-onmouseover-buttons? nil
:onclick-function :onclick-function
#'(lambda(object) #'(lambda(object)
(the (gdl-ajax-call (the (gdl-ajax-call
;;:bashee (list :%rp% '(:root-object))
:function-key :perform-action! :function-key :perform-action!
:arguments (list object))))) :arguments (list nil
:tasty-root self
:root-object-rootpath (the-object object root-path))))))
(viewport :type 'viewport (viewport :type 'viewport
...@@ -180,12 +192,14 @@ o allow input of required input-slots. ...@@ -180,12 +192,14 @@ o allow input of required input-slots.
:length (getf (the viewport-dimensions) :length (getf (the viewport-dimensions)
:length (getf (the viewport-dimensions) :height)) :length (getf (the viewport-dimensions) :height))
:width (getf (the viewport-dimensions) :width) :width (getf (the viewport-dimensions) :width)
:onclick-function #'(lambda(object) :onclick-function
(the (gdl-ajax-call #'(lambda(object)
:function-key :perform-action! (the (gdl-ajax-call
:arguments (list object) :function-key :perform-action!
:null-event? (member (the-child image-format) (list :x3d :x3dom)) :arguments (list nil
))) :tasty-root self
:root-object-rootpath (the-object object root-path))
:null-event? (member (the-child image-format) (list :x3d :x3dom)))))
:tatu-root self) :tatu-root self)
(inspector :type 'inspector (inspector :type 'inspector
...@@ -270,15 +284,32 @@ o allow input of required input-slots. ...@@ -270,15 +284,32 @@ o allow input of required input-slots.
(update-root-object! (update-root-object!
() ()
(the root-object update!) (the root-object update!)
(the tree update!) (the refresh-tasty-panes!)
;;(the root-object update!)
;;(the tree update!)
) )
(refresh-tasty-panes!
()
(mapsend (list (the tree) (the inspector) (the viewport)) :update!))
#+nil
(make-root-instance (make-root-instance
(type) (type)
(the (set-slot! :root-object-type (the (set-slot! :root-object-type
(let ((*package* (find-package (the package-default)))) (let ((*package* (find-package (the package-default))))
(read-safe-string type))))) (read-safe-string type)))))
(make-root-instance
(type)
(let* ((type (let ((*package* (find-package (the package-default))))
(read-safe-string type)))
(object (make-object type :strings-for-display (format nil "~s" type))))
(the (set-root! object))))
(set-root! (set-root!
(object) (object)
(when (typep object 'base-html-sheet) (when (typep object 'base-html-sheet)
...@@ -314,35 +345,51 @@ o allow input of required input-slots. ...@@ -314,35 +345,51 @@ o allow input of required input-slots.
(the (set-slot! :root-object (the root-object-object))))) (the (set-slot! :root-object (the root-object-object)))))
(perform-action! (perform-action!
(object &key kids-error (click-mode (the click-mode value))) (&optional object &key tasty-root root-object-rootpath
kids-error (click-mode (the click-mode value)))
(when *debug?* (print-variables (the-object object root-path) click-mode)) (when *debug?* (print-variables (the-object object root-path) click-mode))
(ecase click-mode
(:inspect (the inspector (set-object! object))) (let ((object (or object
(:reset-root (the (reset-root! object))) (the-object tasty-root root-object
(:set-root (the (set-root! object))) (follow-root-path root-object-rootpath)))))
(:update-node (the (update-node! object)))
(:draw-leaves (the viewport (draw-leaves! object))) (print-variables object click-mode)
(:draw-node (the viewport (draw-node! object)))
(:add-leaves (the viewport (add-leaves! object))) (print-variables (the inspector node-root-path)
(:add-leaves* (the viewport (add-leaves*! object))) (the inspector node))
(:delete-leaves (the viewport (delete-leaves! object)))
(:add-node (the viewport (add-node! object))) (ecase click-mode
(:inspect (the inspector (set-object! object)))
(:reset-root (the (reset-root! object)))
(:set-root (the (set-root! object)))
(:update-node (the (update-node! object)))
(:draw-leaves (the viewport (draw-leaves! object)))
(:draw-node (the viewport (draw-node! object)))
(:add-leaves (the viewport (add-leaves! object)))
(:add-leaves* (the viewport (add-leaves*! object)))
(:delete-leaves (the viewport (delete-leaves! object)))
(:add-node (the viewport (add-node! object)))
(:break (:break
(set-self object) (set-self object)
(let ((*package* (symbol-package (the-object object root type)))) (let ((*package* (symbol-package (the-object object root type))))
(format t "~& (format t "~&
~aSelf is now set to to ~s, you may use command-line interaction....~%~%" ~aSelf is now set to to ~s, you may use command-line interaction....~%~%"
(if kids-error (if kids-error
(format nil "~& (format nil "~&
NOTE: Children cannot expand -- evaluate (the children) to reproduce the error. NOTE: Children cannot expand -- evaluate (the children) to reproduce the error.
The error was: ~a The error was: ~a
" "
kids-error) "") object))) kids-error) "") object)))
;;(:uh (the viewport (set-sheet-object! object))) ;;(:uh (the viewport (set-sheet-object! object)))
)
(print-variables (the inspector node-root-path)
(the inspector node))
)))) ))))
......
...@@ -142,6 +142,7 @@ ...@@ -142,6 +142,7 @@
(definition) (definition)
(declare (ignore 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")) (error "Sorry! This is supposed to do 'lisp-find-definition' in emacs, but not working yet... Please send email to support@genworks.com"))
#+nil #+nil
(visit-definition-in-emacs (visit-definition-in-emacs
...@@ -150,7 +151,8 @@ ...@@ -150,7 +151,8 @@
(print-variables emacs-lisp-command) (print-variables emacs-lisp-command)
#+allegro (lep::eval-in-emacs emacs-lisp-command))) #+allegro (lep::eval-in-emacs emacs-lisp-command)))
#+nil
(perform-action! (perform-action!
(object) (object)
(the tatu-root (perform-action! object))) (the tatu-root (perform-action! object)))
...@@ -262,7 +264,7 @@ ...@@ -262,7 +264,7 @@
(typecase (the value) (typecase (the value)
(list (when (consp (the value)) :list)) (list (when (consp (the value)) :list))
(gdl::quantification :gdl-sequence) (gdl::quantification :gdl-sequence)
(gdl::gdl-basis :gdl-atom)))) (gdl::gdl-basis (when (eql (the value root) (the node root)) :gdl-atom)))))
(value-cardinality (case (the value-type) (value-cardinality (case (the value-type)
...@@ -305,9 +307,13 @@ ...@@ -305,9 +307,13 @@
(if (the clickable?) "cursor: pointer;" "")) (if (the clickable?) "cursor: pointer;" ""))
:onclick (case (the value-type) :onclick (case (the value-type)
(:gdl-atom (:gdl-atom
(the (gdl-ajax-call (the (gdl-ajax-call
:bashee (the tatu-root)
:function-key :perform-action! :function-key :perform-action!
:arguments (list value)))) :arguments
(list nil
:tasty-root (the tatu-root)
:root-object-rootpath (the value root-path)))))
(:gdl-3d-point (:gdl-3d-point
(when (the clickable?) (when (the clickable?)
...@@ -451,6 +457,9 @@ ...@@ -451,6 +457,9 @@
(progn (progn
(the node (set-slot-if-needed! (the node (set-slot-if-needed!
(the-child keyword) value :infer-types? nil)) (the-child keyword) value :infer-types? nil))
(the tatu-root refresh-tasty-panes!)
t)) t))
;; ;;
......
...@@ -212,8 +212,7 @@ Converting to a string to avoid error." ...@@ -212,8 +212,7 @@ Converting to a string to avoid error."
(the child-nodes))))))))) (the child-nodes)))))))))
:functions :functions
( ((toggle-state! ()
(toggle-state! ()
(the (set-slot! :closed? (not (the closed?)))) (the (set-slot! :closed? (not (the closed?))))
(the propogate-toggle!)) (the propogate-toggle!))
......
...@@ -48,7 +48,7 @@ to the src/ directory distributed with GDL. ...@@ -48,7 +48,7 @@ to the src/ directory distributed with GDL.
(torso-type 'box :settable) (torso-type 'box :settable)
(height 10 :settable) (height 10 :settable)
(head-angle 0 :settable) (head-angle 0 :settable)
(body-angle 0 :settable) (body-angle 20 :settable)
(arm-angle-right 0 :settable) (arm-angle-right 0 :settable)
(arm-angle-left 0 :settable) (arm-angle-left 0 :settable)
(pincer-distance-right (number-round (* .15 3/5 (the width)) 3) :settable) (pincer-distance-right (number-round (* .15 3/5 (the width)) 3) :settable)
......
...@@ -23,6 +23,8 @@ ...@@ -23,6 +23,8 @@
(defparameter *ajax-snap-restore?* nil) (defparameter *ajax-snap-restore?* nil)
(defparameter *self* nil)
(defun quick-save (self &key (snap-folder (glisp:snap-folder))) (defun quick-save (self &key (snap-folder (glisp:snap-folder)))
(when *ajax-snap-restore?* (when *ajax-snap-restore?*
(let ((snap-file (let ((snap-file
...@@ -100,6 +102,7 @@ ...@@ -100,6 +102,7 @@
(self (or self (restore-from-snap iid))) (self (or self (restore-from-snap iid)))
(plist-raw plist)
(plist (decode-from-ajax plist self)) (plist (decode-from-ajax plist self))
(bashee (getf plist :|bashee|)) (bashee (getf plist :|bashee|))
(respondent (progn (when *debug?* (print-variables plist)) (respondent (progn (when *debug?* (print-variables plist))
...@@ -110,11 +113,14 @@ ...@@ -110,11 +113,14 @@
(arguments (getf plist :|arguments|))) (arguments (getf plist :|arguments|)))
(setq *self* self)
(when *debug?* (when *debug?*
(let ((bashee-root (the-object bashee root-path)) (let ((bashee-root (the-object bashee root-path))
(respondent-root (the-object respondent root-path))) (respondent-root (the-object respondent root-path)))
(print-variables raw-fields bashee-root respondent-root fields function))) (print-variables plist-raw plist raw-fields bashee-root respondent-root fields function)
))
(let ((*clicked-x* (let ((string (getf query-plist :|x|))) (let ((*clicked-x* (let ((string (getf query-plist :|x|)))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment