Commit 475bf3dd authored by David O'Toole's avatar David O'Toole

movable window container

parent 36f71eb0
(in-package :xelf)
(defmethod set-caption-string ((self node) caption)
(defmethod set-caption-string ((self node) caption)
(assert (stringp caption))
(setf (slot-value self 'caption) caption))
......@@ -160,6 +160,88 @@
(layout *menubar*)
(update *menubar*)))
(defvar *system* nil)
(defclass system (node)
((type :initform :system)
(running :initform nil)))
(defun show-dialog (dialog)
(add-node (current-buffer) dialog)
(center dialog))
(defmethod rename-buffer-dialog ((self system))
(show-dialog (make-instance 'rename-buffer*)))
(defmethod visit-buffer-dialog ((self system))
(show-dialog (make-instance 'visit-buffer)))
(defmethod resize-buffer-dialog ((self system))
(show-dialog (make-instance 'resize-buffer)))
(defmethod create-buffer-dialog ((self system))
(show-dialog (make-instance 'create-buffer)))
(defmethod paste-as-new-buffer-dialog ((self system))
(show-dialog (make-instance 'paste-as-new-buffer)))
(defmethod edit-cut ((self system))
(cut (current-buffer)))
(defmethod edit-copy ((self system))
(copy (current-buffer)))
(defmethod edit-paste ((self system))
(paste (current-buffer)))
(defmethod transport-play ((self system))
(play (current-buffer)))
(defmethod transport-pause ((self system))
(pause (current-buffer)))
(defmethod show-copyright-notice ((self system))
(let ((box (make-instance 'text :text *copyright-notice*)))
(add-node (current-buffer) box 80 80)
(resize-to-scroll box 300 300)
(setf (slot-value box 'max-displayed-lines) 20)
(center box)
(bring-to-front box)))
(defmethod show-help ((self system))
(show-help (current-buffer)))
(defmethod save-before-exit ((self system)))
(defmethod create-project ((self system)))
;; (defmethod open-existing-project ((self system) (project-name string :default " "))
(defmethod save-changes ((self system))
(save-project))
(defmethod save-everything ((self system))
(save-project :force))
(defmethod initialize ((self system))
(setf *system* self))
(defmethod create-trash ((self system))
(add-block (shell) (make-instance 'trash) 100 100))
(defmethod create-text ((self system))
(add-block (shell) (make-instance 'text) 100 100))
;; (defmethod create-listener ((self system))
;; (add-block (shell) (new listener) 100 100))
(defmethod ticks ((self system))
(get-ticks))
(defmethod exit-xelf* ((self system))
;; TODO destroy textures
(exit-xelf))
(define-command rename-buffer*
((new-name (slot-value (current-buffer) 'buffer-name)))
(rename (current-buffer) new-name))
......@@ -383,3 +465,65 @@
(defmethod accept ((self menubar) thing)
(declare (ignore thing))
nil)
(define-handle frame-close-button :close
:slots ((target-frame :initform nil :initarg :target-frame :accessor target-frame)))
(defmethod tap ((self frame-close-button) x y)
(with-slots (parent) self
(when parent (at-next-update (destroy (parent parent))))))
(defmethod layout ((self frame-close-button))
(resize self 20 20))
(define-node-macro titlebar
(:super phrase
:slots ((frozen :initform t)
(orientation :initform :horizontal)
(no-background :initform t)
(spacing :initform 2)
(dash :initform 1)
(category :initform :system))
:inputs (:close-button (make-instance 'frame-close-button)
:title (make-instance 'label :font "sans-bold-11" :read-only t))))
(defmethod set-title ((self titlebar) title)
(set-value (%%inputs self :title) title))
(define-node-macro frame
(:super phrase
:slots ((frozen :initform nil)
(orientation :initform :vertical)
(no-background :initform t)
(spacing :initform 2)
(dash :initform 1)
(style :initform :rounded)
(category :initform :system))
:inputs (:titlebar (make-instance 'titlebar)
:content (make-instance 'label :read-only t))))
(defmethod set-title ((self frame) title)
(set-title (%%inputs self :titlebar) title))
(defmethod set-content ((self frame) content)
(destroy (%%inputs self :content))
(with-slots (inputs) self
(setf (second inputs) content)))
(defun open-frame (title content)
(let ((frame (make-instance 'frame)))
(prog1 frame
(set-title frame title)
(set-content frame content)
(center frame)
(add-node (current-buffer) frame))))
(defmethod update :before ((self frame))
(layout self))
(defmethod draw :before ((self frame))
(multiple-value-bind (top left right bottom) (bounding-box frame)
(draw-patch self left top right bottom :color "gray80" :style :rounded)))
;; (defmethod as-drag ((self menu) x y)
;; (make-menu-frame self))
......@@ -437,7 +437,7 @@ See sidebar for more commands to try.
;;; The halo, which manages all the handles
(defparameter *halo-handles*
'(evaluate drop move rotate resize pick-up cut copy destroy))
'(evaluate drop move menu rotate resize pick-up cut copy destroy))
(defclass halo (node) ((target :initform nil)))
......@@ -2661,7 +2661,7 @@ See sidebar for more commands to try.
(dash 0 x width)
(- (dash 1 y height) (dash 1))))
;; nope, draw in the typical fashion.
(draw-expanded (slot-value self 'parent) label))
(when (parent self) (draw-expanded (slot-value self 'parent) label)))
;; draw status indicator on submenus
(when (and (not (slot-value self 'locked)) parent (menup parent))
(draw-indicator :down-triangle-open
......@@ -2716,83 +2716,3 @@ See sidebar for more commands to try.
(when (and (< left x right)
(< top y bottom))
(draw-highlight self)))))))
(defvar *system* nil)
(defclass system (node)
((type :initform :system)
(running :initform nil)))
(defun show-dialog (dialog)
(add-node (current-buffer) dialog)
(center dialog))
(defmethod rename-buffer-dialog ((self system))
(show-dialog (make-instance 'rename-buffer*)))
(defmethod visit-buffer-dialog ((self system))
(show-dialog (make-instance 'visit-buffer)))
(defmethod resize-buffer-dialog ((self system))
(show-dialog (make-instance 'resize-buffer)))
(defmethod create-buffer-dialog ((self system))
(show-dialog (make-instance 'create-buffer)))
(defmethod paste-as-new-buffer-dialog ((self system))
(show-dialog (make-instance 'paste-as-new-buffer)))
(defmethod edit-cut ((self system))
(cut (current-buffer)))
(defmethod edit-copy ((self system))
(copy (current-buffer)))
(defmethod edit-paste ((self system))
(paste (current-buffer)))
(defmethod transport-play ((self system))
(play (current-buffer)))
(defmethod transport-pause ((self system))
(pause (current-buffer)))
(defmethod show-copyright-notice ((self system))
(let ((box (make-instance 'text :text *copyright-notice*)))
(add-node (current-buffer) box 80 80)
(resize-to-scroll box 300 300)
(setf (slot-value box 'max-displayed-lines) 20)))
(defmethod show-help ((self system))
(show-help (current-buffer)))
(defmethod save-before-exit ((self system)))
(defmethod create-project ((self system)))
;; (defmethod open-existing-project ((self system) (project-name string :default " "))
(defmethod save-changes ((self system))
(save-project))
(defmethod save-everything ((self system))
(save-project :force))
(defmethod initialize ((self system))
(setf *system* self))
(defmethod create-trash ((self system))
(add-block (shell) (make-instance 'trash) 100 100))
(defmethod create-text ((self system))
(add-block (shell) (make-instance 'text) 100 100))
;; (defmethod create-listener ((self system))
;; (add-block (shell) (new listener) 100 100))
(defmethod ticks ((self system))
(get-ticks))
(defmethod exit-xelf* ((self system))
;; TODO destroy textures
(exit-xelf))
......@@ -504,7 +504,7 @@ above.
;;; The halo, which manages all the handles
(defparameter *halo-handles*
'(evaluate drop move rotate resize pick-up cut copy destroy))
'(evaluate drop move menu rotate resize pick-up cut copy destroy))
(defclass halo (node) ((target :initform nil)))
......@@ -2808,7 +2808,7 @@ hybrid GUI inspired by MIT Scratch and its derivatives.
(dash 0 x width)
(- (dash 1 y height) (dash 1))))
;; nope, draw in the typical fashion.
(draw-expanded (slot-value self 'parent) label))
(when (parent self) (draw-expanded (slot-value self 'parent) label)))
;; draw status indicator on submenus
(when (and (not (slot-value self 'locked)) parent (menup parent))
(draw-indicator :down-triangle-open
......@@ -3044,7 +3044,7 @@ hybrid GUI inspired by MIT Scratch and its derivatives.
(command-argument-string (thing)
(concatenate 'string (command-name-string thing) ": ")))
`(progn
(defun ,name (&key ,@arglist) ,@body)
;;(defun ,name (&key ,@arglist) ,@body)
(export ',name)
(define-node-macro ,name
(:super phrase
......@@ -3104,10 +3104,8 @@ hybrid GUI inspired by MIT Scratch and its derivatives.
** Shell commands
#+begin_src lisp :tangle commands.lisp
(in-package :xelf)
#+end_src
(in-package :xelf)
#+begin_src lisp :tangle commands.lisp
(defmethod set-caption-string ((self node) caption)
(assert (stringp caption))
(setf (slot-value self 'caption) caption))
......@@ -3279,7 +3277,7 @@ hybrid GUI inspired by MIT Scratch and its derivatives.
** System object
#+begin_src lisp
#+begin_src lisp :tangle commands.lisp
(defvar *system* nil)
(defclass system (node)
......@@ -3489,6 +3487,7 @@ hybrid GUI inspired by MIT Scratch and its derivatives.
** Menubar class
#+begin_src lisp :tangle commands.lisp
(defclass menubar (tree)
((category :initform :menu)
(temporary :initform t)))
......@@ -3600,3 +3599,68 @@ hybrid GUI inspired by MIT Scratch and its derivatives.
#+end_src
** Floating windows
#+begin_src lisp :tangle commands.lisp
(define-handle frame-close-button :close
:slots ((target-frame :initform nil :initarg :target-frame :accessor target-frame)))
(defmethod tap ((self frame-close-button) x y)
(with-slots (parent) self
(when parent (at-next-update (destroy (parent parent))))))
(defmethod layout ((self frame-close-button))
(resize self 20 20))
(define-node-macro titlebar
(:super phrase
:slots ((frozen :initform t)
(orientation :initform :horizontal)
(no-background :initform t)
(spacing :initform 2)
(dash :initform 1)
(category :initform :system))
:inputs (:close-button (make-instance 'frame-close-button)
:title (make-instance 'label :font "sans-bold-11" :read-only t))))
(defmethod set-title ((self titlebar) title)
(set-value (%%inputs self :title) title))
(define-node-macro frame
(:super phrase
:slots ((frozen :initform nil)
(orientation :initform :vertical)
(no-background :initform t)
(spacing :initform 2)
(dash :initform 1)
(style :initform :rounded)
(category :initform :system))
:inputs (:titlebar (make-instance 'titlebar)
:content (make-instance 'label :read-only t))))
(defmethod set-title ((self frame) title)
(set-title (%%inputs self :titlebar) title))
(defmethod set-content ((self frame) content)
(destroy (%%inputs self :content))
(with-slots (inputs) self
(setf (second inputs) content)))
(defun open-frame (title content)
(let ((frame (make-instance 'frame)))
(prog1 frame
(set-title frame title)
(set-content frame content)
(center frame)
(add-node (current-buffer) frame))))
(defmethod update :before ((self frame))
(layout self))
(defmethod draw :before ((self frame))
(multiple-value-bind (top left right bottom) (bounding-box self)
(draw-patch self left top right bottom :color "gray30" :style :rounded)))
;; (defmethod as-drag ((self menu) x y)
;; (make-menu-frame self))
#+end_src
......@@ -157,7 +157,7 @@
(command-argument-string (thing)
(concatenate 'string (command-name-string thing) ": ")))
`(progn
(defun ,name (&key ,@arglist) ,@body)
;;(defun ,name (&key ,@arglist) ,@body)
(export ',name)
(define-node-macro ,name
(:super phrase
......
* Task list
** TODO [#A] create buffer switch menu
** TODO [#A] fix command dialogs
** TODO [#A] fix can't drag item out of shell
** TODO [#A] save-buffer
** TODO [#A] load-buffer
** TODO [#A] load-project
** TODO [#A] scrolling the buffer window
** TODO [#A] snap-to-grid and offset
** TODO [#A] select-all
** TODO [#A] general properties browser
** TODO general window container class
** TODO right click pop up menus
** TODO pinnable pop up menus
** TODO allow tear-off menus
** TODO menu halo handle
** TODO hand me a tile
** TODO save-buffer
** TODO load-buffer
** TODO save-project
** TODO load-project
** TODO command undo/redo
** TODO object/tool palette
** TODO create buffer switch menu
** TODO fix command dialogs
** TODO fix can't drag item out of shell
** TODO scrolling the buffer window
** TODO snap-to-grid and offset
** TODO select-all
** TODO general properties browser
*** TODO shell create/pop out 1 property of 1 object
*** TODO shell create/pop out property/method browser
*** TODO controls in sidebar?
......
......@@ -16,12 +16,31 @@
(setf *screen-height* 450)
(setf *resizable* t)
(setf *scale-output-to-window* nil)
(setf *debug-on-error* t)
(setf *shell-enabled-p* t)
(with-session
(open-project :plong)
(index-pending-resources)
(let ((plong (make-instance 'plong-gui)))
;; start the buffer running
(switch-to-buffer plong)
(at-next-update
(add-node (current-buffer)
(xelf::open-frame
"Buffers"
(xelf::make-menu '(:label "ignored"
:expanded t
:inputs
((:label "Create a buffer" :action xelf::create-buffer-dialog)
(:label "Load a buffer from a file" :action xelf::load-buffer-from-file-dialog)
(:label "Switch to buffer" :action xelf::switch-to-buffer-dialog)
(:label "Rename buffer" :action xelf::rename-buffer-dialog)
(:label "Resize buffer" :action xelf::resize-buffer-dialog)
(:label "Save buffer in project" :action xelf::save-buffer-in-project-dialog)
(:label "Save buffer in new file" :action xelf::save-buffer-in-new-file-dialog)
(:label "Revert buffer" :action xelf::revert-buffer-dialog)
(:label "View clipboard" :action xelf::view-clipboard)
(:label "View buffer list" :action xelf::view-buffer-list)))))))
(start-game plong))))
(test-gui)
(test-gui)
......@@ -5077,7 +5077,8 @@ Returns a newly allocated list."
(let ((help (make-instance 'text :text *help-text*)))
(add-node self help (window-x) (window-y))
(layout help)
(center help)))
(center help)
(bring-to-front help)))
(defmethod handle-event ((self buffer) event)
;; (clear-deleted-program-objects self)
......@@ -5250,7 +5251,7 @@ Returns a newly allocated list."
(let ((z 0))
(loop for object being the hash-values in (slot-value (current-buffer) 'objects)
do (when (find-object object t)
(setf z (max z (slot-value (find-object object) 'z)))))
(setf z (max z (%z (find-object object))))))
z)))
(defun window-y () (slot-value (current-buffer) 'window-y))
......
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