Commit e6620195 authored by David O'Toole's avatar David O'Toole

partial gl:scissor support

parent 692d5387
......@@ -885,8 +885,8 @@
(with-slots (inputs) self
(setf (second inputs) content)))
(defun make-frame (title content &key destroy-after-evaluate-p)
(let ((frame (make-instance 'frame :destroy-after-evaluate-p destroy-after-evaluate-p)))
(defun make-frame (title content &key destroy-after-evaluate-p (class 'frame))
(let ((frame (make-instance class :destroy-after-evaluate-p destroy-after-evaluate-p)))
(prog1 frame
(set-title frame title)
(set-content frame content)
......@@ -1734,3 +1734,27 @@ replace the original grid with this one."
(defmethod resize :after ((desktop desktop) width height)
(auto-arrange desktop))
;; Desktop:2 ends here
;; [[file:~/xelf/gui.org::*Desktop][Desktop:3]]
(defclass buffer-frame (frame)
((buffer :initarg :buffer :accessor buffer)))
(defmethod initialize-instance :after ((frame buffer-frame) &key buffer)
(assert (not (null buffer)))
(set-title frame (buffer-name buffer))
(set-content frame buffer)
(resize frame 320 200))
(defmethod layout ((frame buffer-frame)) nil)
(defmethod resize :after ((frame buffer-frame) width height)
(with-slots (x y buffer) frame
(clip buffer x y width height)))
(defun show-cell-sheet ()
(let ((frame (make-instance 'buffer-frame :buffer (make-instance 'cell-sheet))))
(add-node (current-buffer) frame)
(center frame)
(align-to-pixels frame)
(bring-to-front frame)))
;; Desktop:3 ends here
......@@ -1806,7 +1806,7 @@ See also [[file:dictionary/BIND-EVENT.html][BIND-EVENT]] and [[file:dictionary/M
(defmethod initialize-instance :after ((arena arena) &key)
(setf *arena* arena)
(resize arena *width* *height*)
(bind-event arena '(:space) 'spacebar)
;; (bind-event arena '(:space) 'spacebar)
(bind-event arena '(:return) 'spacebar)
(bind-event arena '(:pageup) 'select-variation)
(bind-event arena '(:escape) 'setup)
......
......@@ -502,8 +502,8 @@
;; [[file:~/xelf/gui.org::*Smoothly%20scrolling%20the%20buffer's%20window][Smoothly scrolling the buffer's window:1]]
(defun window-origin-y () (slot-value (current-buffer) 'window-y))
(defun window-origin-x () (slot-value (current-buffer) 'window-x))
(defun window-origin-y () (if (current-buffer) (slot-value (current-buffer) 'window-y) 0))
(defun window-origin-x () (if (current-buffer) (slot-value (current-buffer) 'window-x) 0))
(defmethod window-bounding-box ((self buffer))
(values (cfloat (slot-value self 'window-y))
......@@ -738,13 +738,14 @@
(progn (enable-clipping)
(apply #'set-clip-rectangle (clip-rectangle self))
(gl:matrix-mode :projection)
(gl:push-matrix)
(destructuring-bind (x y w h) (clip-rectangle self)
(gl:translate x y 0)))))
(defmethod draw :after ((self buffer))
(when (clipped-p self)
(gl:pop-matrix)
(gl:matrix-mode :projection)
(destructuring-bind (x y w h) (clip-rectangle self)
(gl:translate (- 0 x) (- 0 y) 0))
(disable-clipping)))
(defmethod visit :after ((self buffer))
......
......@@ -765,13 +765,14 @@ This section is obsolete and will be removed in the future.
(progn (enable-clipping)
(apply #'set-clip-rectangle (clip-rectangle self))
(gl:matrix-mode :projection)
(gl:push-matrix)
(destructuring-bind (x y w h) (clip-rectangle self)
(gl:translate x y 0)))))
(defmethod draw :after ((self buffer))
(when (clipped-p self)
(gl:pop-matrix)
(gl:matrix-mode :projection)
(destructuring-bind (x y w h) (clip-rectangle self)
(gl:translate (- 0 x) (- 0 y) 0))
(disable-clipping)))
(defmethod visit :after ((self buffer))
......@@ -5567,8 +5568,8 @@ supported compiler.
(with-slots (inputs) self
(setf (second inputs) content)))
(defun make-frame (title content &key destroy-after-evaluate-p)
(let ((frame (make-instance 'frame :destroy-after-evaluate-p destroy-after-evaluate-p)))
(defun make-frame (title content &key destroy-after-evaluate-p (class 'frame))
(let ((frame (make-instance class :destroy-after-evaluate-p destroy-after-evaluate-p)))
(prog1 frame
(set-title frame title)
(set-content frame content)
......@@ -6411,9 +6412,32 @@ PCL, the CLOS implementation written originally by Xerox.
(defmethod resize :after ((desktop desktop) width height)
(auto-arrange desktop))
#+end_src
#+begin_src lisp :tangle commands.lisp
(defclass buffer-frame (frame)
((buffer :initarg :buffer :accessor buffer)))
(defmethod initialize-instance :after ((frame buffer-frame) &key buffer)
(assert (not (null buffer)))
(set-title frame (buffer-name buffer))
(set-content frame buffer)
(resize frame 320 200))
(defmethod layout ((frame buffer-frame)) nil)
(defmethod resize :after ((frame buffer-frame) width height)
(with-slots (x y buffer) frame
(clip buffer x y width height)))
(defun show-cell-sheet ()
(let ((frame (make-instance 'buffer-frame :buffer (make-instance 'cell-sheet))))
(add-node (current-buffer) frame)
(resize frame 400 300)
(center frame)
(align-to-pixels frame)
(bring-to-front frame)))
#+end_src
......
......@@ -1848,7 +1848,7 @@ directory included with this application.
(defmethod initialize-instance :after ((arena arena) &key)
(setf *arena* arena)
(resize arena *width* *height*)
(bind-event arena '(:space) 'spacebar)
;; (bind-event arena '(:space) 'spacebar)
(bind-event arena '(:return) 'spacebar)
(bind-event arena '(:pageup) 'select-variation)
(bind-event arena '(:escape) 'setup)
......
* Task list
** TODO close menus after buffer switch
** TODO fix weird buffer switches
** TODO fix ESC binding not being caught by open shell
** TODO fix weird buffer switches when background click
** TODO cell cursor movement
** TODO buffer scrolling with mouse wheel
** TODO context tool buttons on / above modeline
** TODO [#A] allow recursive buffer view and split views
**** TODO buffer-proxy class
**** TODO
**** TODO fix project-window always before draw
**** TODO separate draw and draw-primary
** DONE [#B] allow double click desktop icons
CLOSED: [2017-04-26 Wed 18:39]
** TODO [#B] Design user experience
*** TODO launching external programs to edit assets. gimp, audacity, switch-to-emacs,. etc
*** TODO folders are virtual views, they don't nest
** DONE [#A] change-buffer-class
CLOSED: [2017-04-26 Wed 19:30]
** TODO [#A] command undo/redo
** TODO [#A] design layered tile map editing
** TODO [#A] snap-to-grid and offset
......@@ -1323,3 +1318,32 @@
*** TODO show change class
*** TODO show image browser
** DONE fix ESC binding not being caught by open shell
CLOSED: [2017-04-28 Fri 07:27]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-28 Fri 07:55
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#B] allow double click desktop icons
CLOSED: [2017-04-26 Wed 18:39]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-28 Fri 07:55
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#A] change-buffer-class
CLOSED: [2017-04-26 Wed 19:30]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-28 Fri 07:55
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
......@@ -117,6 +117,10 @@
;; (trace xelf::update-window-movement)
(trace xelf::clip)
(trace xelf::resize)
(trace xelf::set-clip-rectangle)
(setf xelf::*shell-enabled-p* t)
(squareball:squareball)
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