Commit 692d5387 authored by David O'Toole's avatar David O'Toole

test normal buffer behavior

parent 7fbf831c
......@@ -43,15 +43,15 @@
;; [[file:~/xelf/gui.org::*Shell%20operations][Shell operations:1]]
(defmethod drag ((self shell) x y)
(with-slots (target-x target-y) self
(setf target-x (- x (window-x)))
(setf target-y (- y (window-y)))
(setf target-x (- x (window-origin-x)))
(setf target-y (- y (window-origin-y)))
(move-to self x y)))
(defmethod layout ((self shell))
;; (with-slots (target-x target-y) self
;; (move-to self
;; (+ target-x (window-x))
;; (+ target-y (window-y)))
;; (+ target-x (window-origin-x))
;; (+ target-y (window-origin-y)))
(with-slots (target-x target-y) self
(setf target-x 0 target-y 0))
(with-slots (inputs orientation) self
......@@ -61,7 +61,7 @@
(:horizontal (layout-horizontally self))
(:vertical (layout-vertically self)))))
(call-next-method)
(move-to self (window-x) (- (+ (window-y) *screen-height*) (slot-value self 'height)))
(move-to self (window-origin-x) (- (+ (window-origin-y) *screen-height*) (slot-value self 'height)))
(resize self *screen-width* (slot-value self 'height)))
(defmethod layout :after ((self shell))
......@@ -780,7 +780,7 @@
(defmethod layout ((self menubar))
(with-slots (x y width height inputs) self
(setf x (window-x) y (window-y) width *screen-width* height (dash 1))
(setf x (window-origin-x) y (window-origin-y) width *screen-width* height (dash 1))
(let ((x1 (dash 1)))
(dolist (item inputs)
(move-to item x1 y)
......
......@@ -34,6 +34,7 @@
:initarg :buffer-name
:type string)
(variables :initform nil :accessor variables :initarg :variables)
(clip-rectangle :initform nil :accessor clip-rectangle :initarg :clip-rectangle)
(point :initform nil)
(modified-p :initform nil)
(redraw-cursor :initform t)
......@@ -94,6 +95,26 @@
(drag-offset :initform nil)))
;; Class declaration:1 ends here
;; Render a buffer with clipping
;; [[file:~/xelf/gui.org::*Render%20a%20buffer%20with%20clipping][Render a buffer with clipping:1]]
(defun enable-clipping ()
(gl:enable :scissor-test))
(defun disable-clipping ()
(gl:disable :scissor-test))
(defun set-clip-rectangle (x y width height)
(gl:scissor x y width height))
(defmethod clip ((buffer buffer) &rest args)
(setf (clip-rectangle buffer) args))
(defmethod clipped-p ((buffer buffer))
(not (null (clip-rectangle buffer))))
;; Render a buffer with clipping:1 ends here
;; Initialization
......@@ -189,7 +210,7 @@
;; [[file:~/xelf/gui.org::*Showing%20a%20help%20box][Showing a help box:1]]
(defun show-help ()
(let ((help (make-instance 'text :text *help-text*)))
(add-node (current-buffer) help (window-x) (window-y))
(add-node (current-buffer) help (window-origin-x) (window-origin-y))
(layout help)
(center help)
(align-to-pixels help)
......@@ -481,8 +502,8 @@
;; [[file:~/xelf/gui.org::*Smoothly%20scrolling%20the%20buffer's%20window][Smoothly scrolling the buffer's window:1]]
(defun window-y () (slot-value (current-buffer) 'window-y))
(defun window-x () (slot-value (current-buffer) 'window-x))
(defun window-origin-y () (slot-value (current-buffer) 'window-y))
(defun window-origin-x () (slot-value (current-buffer) 'window-x))
(defmethod window-bounding-box ((self buffer))
(values (cfloat (slot-value self 'window-y))
......@@ -709,13 +730,41 @@
;; [[file:~/xelf/gui.org::*Drawing%20the%20buffer][Drawing the buffer:1]]
(defmethod grab-focus ((self buffer)))
(defmethod after-draw-object ((self buffer) object))
(defmethod after-draw-object ((self buffer) object))
(defmethod draw :before ((self buffer))
(with-buffer self
(project-window self)))
(defmethod draw :before ((self buffer))
(if (not (clipped-p self))
(project-window self)
(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)
(disable-clipping)))
(defmethod visit :after ((self buffer))
(clip self))
(defmethod bounding-box :around ((self buffer))
(if (clipped-p self)
(destructuring-bind (x y width height) (clip-rectangle self)
(values y x (+ x width) (+ y height)))
(call-next-method)))
(defmethod add-node :after ((parent buffer) (child buffer) &optional x y z)
(clip child 0 0 256 256))
(defmethod move-to :after ((child buffer) x y &optional z)
(when (clipped-p child)
(setf (first (clip-rectangle child)) x)
(setf (second (clip-rectangle child)) y)))
(defmethod draw-object-layer ((self buffer))
(defmethod draw-object-layer ((self buffer))
(multiple-value-bind (top left right bottom) (window-bounding-box self)
(loop for object being the hash-keys of (slot-value self 'objects) do
;; only draw onscreen objects
......@@ -1441,7 +1490,7 @@
(defmethod scroll ((self buffer) direction)
(multiple-value-bind (x y)
(scroll-position self (window-x) (window-y) direction)
(scroll-position self (window-origin-x) (window-origin-y) direction)
(glide-window-to self x y)))
(defmethod scroll-up ((self buffer))
......
......@@ -86,6 +86,7 @@ every BUFFER is also a NODE.)
:initarg :buffer-name
:type string)
(variables :initform nil :accessor variables :initarg :variables)
(clip-rectangle :initform nil :accessor clip-rectangle :initarg :clip-rectangle)
(point :initform nil)
(modified-p :initform nil)
(redraw-cursor :initform t)
......@@ -146,6 +147,25 @@ every BUFFER is also a NODE.)
(drag-offset :initform nil)))
#+end_src
** Render a buffer with clipping
#+begin_src lisp
(defun enable-clipping ()
(gl:enable :scissor-test))
(defun disable-clipping ()
(gl:disable :scissor-test))
(defun set-clip-rectangle (x y width height)
(gl:scissor x y width height))
(defmethod clip ((buffer buffer) &rest args)
(setf (clip-rectangle buffer) args))
(defmethod clipped-p ((buffer buffer))
(not (null (clip-rectangle buffer))))
#+end_src
** Initialization
#+begin_src lisp
......@@ -235,7 +255,7 @@ See also "Command shell" below.
#+begin_src lisp
(defun show-help ()
(let ((help (make-instance 'text :text *help-text*)))
(add-node (current-buffer) help (window-x) (window-y))
(add-node (current-buffer) help (window-origin-x) (window-origin-y))
(layout help)
(center help)
(align-to-pixels help)
......@@ -514,8 +534,8 @@ Destroy the objects intersecting the region, without selecting them.
** Smoothly scrolling the buffer's window
#+begin_src lisp
(defun window-y () (slot-value (current-buffer) 'window-y))
(defun window-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))
......@@ -735,15 +755,43 @@ This section is obsolete and will be removed in the future.
** Drawing the buffer
#+begin_src lisp
(defmethod grab-focus ((self buffer)))
(defmethod grab-focus ((self buffer)))
(defmethod after-draw-object ((self buffer) object))
(defmethod after-draw-object ((self buffer) object))
(defmethod draw :before ((self buffer))
(with-buffer self
(project-window self)))
(defmethod draw :before ((self buffer))
(if (not (clipped-p self))
(project-window self)
(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)
(disable-clipping)))
(defmethod visit :after ((self buffer))
(clip self))
(defmethod bounding-box :around ((self buffer))
(if (clipped-p self)
(destructuring-bind (x y width height) (clip-rectangle self)
(values y x (+ x width) (+ y height)))
(call-next-method)))
(defmethod add-node :after ((parent buffer) (child buffer) &optional x y z)
(clip child 0 0 256 256))
(defmethod move-to :after ((child buffer) x y &optional z)
(when (clipped-p child)
(setf (first (clip-rectangle child)) x)
(setf (second (clip-rectangle child)) y)))
(defmethod draw-object-layer ((self buffer))
(defmethod draw-object-layer ((self buffer))
(multiple-value-bind (top left right bottom) (window-bounding-box self)
(loop for object being the hash-keys of (slot-value self 'objects) do
;; only draw onscreen objects
......@@ -1460,7 +1508,7 @@ This section is obsolete and will be removed in the future.
(defmethod scroll ((self buffer) direction)
(multiple-value-bind (x y)
(scroll-position self (window-x) (window-y) direction)
(scroll-position self (window-origin-x) (window-origin-y) direction)
(glide-window-to self x y)))
(defmethod scroll-up ((self buffer))
......@@ -4681,15 +4729,15 @@ supported compiler.
#+begin_src lisp :tangle commands.lisp
(defmethod drag ((self shell) x y)
(with-slots (target-x target-y) self
(setf target-x (- x (window-x)))
(setf target-y (- y (window-y)))
(setf target-x (- x (window-origin-x)))
(setf target-y (- y (window-origin-y)))
(move-to self x y)))
(defmethod layout ((self shell))
;; (with-slots (target-x target-y) self
;; (move-to self
;; (+ target-x (window-x))
;; (+ target-y (window-y)))
;; (+ target-x (window-origin-x))
;; (+ target-y (window-origin-y)))
(with-slots (target-x target-y) self
(setf target-x 0 target-y 0))
(with-slots (inputs orientation) self
......@@ -4699,7 +4747,7 @@ supported compiler.
(:horizontal (layout-horizontally self))
(:vertical (layout-vertically self)))))
(call-next-method)
(move-to self (window-x) (- (+ (window-y) *screen-height*) (slot-value self 'height)))
(move-to self (window-origin-x) (- (+ (window-origin-y) *screen-height*) (slot-value self 'height)))
(resize self *screen-width* (slot-value self 'height)))
(defmethod layout :after ((self shell))
......@@ -5415,7 +5463,7 @@ supported compiler.
(defmethod layout ((self menubar))
(with-slots (x y width height inputs) self
(setf x (window-x) y (window-y) width *screen-width* height (dash 1))
(setf x (window-origin-x) y (window-origin-y) width *screen-width* height (dash 1))
(let ((x1 (dash 1)))
(dolist (item inputs)
(move-to item x1 y)
......
......@@ -117,5 +117,6 @@
;; (trace xelf::update-window-movement)
(setf xelf::*shell-enabled-p* t)
(squareball:squareball)
......@@ -4545,8 +4545,8 @@ Returns a newly allocated list."
(and windows-target 64-bit-target)) ;; ccl
(defun draw-textured-rectangle-* (x y z width height texture
&key u1 v1 u2 v2
(window-x (window-x))
(window-y (window-y))
(window-x (window-origin-x))
(window-y (window-origin-y))
angle
(blend :alpha)
(opacity 1.0)
......@@ -4631,8 +4631,8 @@ Returns a newly allocated list."
&key u1 v1 u2 v2
(window-x 0)
(window-y 0)
;; (window-x (window-x))
;; (window-y (window-y))
;; (window-x (window-origin-x))
;; (window-y (window-origin-y))
angle
(blend :alpha)
(opacity 1.0)
......
......@@ -4506,7 +4506,7 @@ This is for OpenGL ES 2 on Android, and not currently documented.
** Drawing images :linux:mac:windows:
#+begin_src lisp
,#+(or linux darwin win32
#+(or linux darwin win32
(and win32 64-bit) ;; sbcl
(and windows-target 64-bit-target)) ;; ccl
......@@ -4540,13 +4540,13 @@ This is for OpenGL ES 2 on Android, and not currently documented.
(gl:tex-coord 0 0)
(gl:vertex x y (- 0 z)))))
,#+(or linux darwin win32
#+(or linux darwin win32
(and win32 64-bit) ;; sbcl
(and windows-target 64-bit-target)) ;; ccl
(defun draw-textured-rectangle-* (x y z width height texture
&key u1 v1 u2 v2
(window-x (window-x))
(window-y (window-y))
(window-x (window-origin-x))
(window-y (window-origin-y))
angle
(blend :alpha)
(opacity 1.0)
......@@ -4630,8 +4630,8 @@ This is for OpenGL ES 2 on Android, and not currently documented.
&key u1 v1 u2 v2
(window-x 0)
(window-y 0)
;; (window-x (window-x))
;; (window-y (window-y))
;; (window-x (window-origin-x))
;; (window-y (window-origin-y))
angle
(blend :alpha)
(opacity 1.0)
......
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