diff --git a/desktop-mode.lisp b/desktop-mode.lisp index 4877dd5..ab26840 100644 --- a/desktop-mode.lisp +++ b/desktop-mode.lisp @@ -219,42 +219,6 @@ (setf (first-commit-animation surface) animation) (start-animation animation))) -#| -(defmethod first-commit ((mode desktop-mode) (surface ulubis-zxdg-surface)) - (let ((animation (sequential-animation - (lambda () - (setf (origin-x surface) 0.0) - (setf (origin-y surface) 0.0)) - (animation :target surface - :property 'scale-x - :easing-fn 'easing:out-exp - :from 0 - :to 1.0 - :duration 250) - (animation :target surface - :property 'scale-y - :easing-fn 'easing:out-exp - :to 1.0 - :duration 250)))) - (setf (origin-x surface) (/ (waylisp:width surface) 2)) - (setf (origin-y surface) (/ (waylisp:height surface) 2)) - (setf (scale-y surface) (/ 6 (waylisp:height surface))) - (start-animation animation))) -|# - - -#| -(defmethod first-commit ((mode desktop-mode) (surface wl-subsurface)) - ;; only animate the parent surface - ) -|# - -#| -(defmethod first-commit ((mode desktop-mode) (surface ulubis-cursor)) - ;; don't animate ulubis-cursor - ) -|# - (cepl:defun-g desktop-mode-vertex-shader ((vert cepl:g-pt) &uniform (origin :mat4) (origin-inverse :mat4) (surface-scale :mat4) (surface-translate :mat4)) (values (* *ortho* surface-translate origin-inverse surface-scale origin (cepl:v! (cepl:pos vert) 1)) (:smooth (cepl:tex vert)))) @@ -278,32 +242,28 @@ :do (render subsurface view-fbo)))) (defmethod render ((surface wl-subsurface) &optional view-fbo) - ;;(format t "Rendering wl-subsurface: ~A~%" surface) (when (texture (wl-surface surface)) (with-rect (vertex-stream (width (wl-surface surface)) (height (wl-surface surface))) (let ((texture (texture-of surface))) (gl:viewport 0 0 (screen-width *compositor*) (screen-height *compositor*)) (map-g-default/fbo view-fbo #'mapping-pipeline vertex-stream :origin (m4:translation (cepl:v! (+ (x surface) (- (origin-x (parent surface)))) - (+ (y surface) (- (origin-y (parent surface)))) 0)) + (+ (y surface) (- (origin-y (parent surface)))) + 0)) :origin-inverse (m4:translation (cepl:v! (+ (- (x surface)) (origin-x (parent surface))) - (+ (- (y surface)) (origin-y (parent surface))) 0)) + (+ (- (y surface)) (origin-y (parent surface))) + 0)) :surface-scale (m4:scale (cepl:v! (scale-x (parent surface)) - (scale-y (parent surface)) 1.0)) - :surface-translate (m4:translation (cepl:v! - (+ (x (parent surface)) (x surface)) - (+ (y (parent surface)) (y surface)) - 0.0)) + (scale-y (parent surface)) + 1.0)) + :surface-translate (m4:translation (cepl:v! (+ (x (parent surface)) (x surface)) + (+ (y (parent surface)) (y surface)) + 0.0)) :texture texture :alpha (opacity surface)))) (loop :for subsurface :in (subsurfaces surface) :do (render subsurface view-fbo)))) -#| -(defmethod render ((cursor ulubis-cursor) &optional view-fbo) - nil) -|# - (defmethod render ((mode desktop-mode) &optional view-fbo) (apply #'gl:clear-color (clear-color mode)) (when view-fbo diff --git a/wl-shell-impl.lisp b/wl-shell-impl.lisp index fe43489..c9e0c46 100644 --- a/wl-shell-impl.lisp +++ b/wl-shell-impl.lisp @@ -18,20 +18,3 @@ (def-wl-bind shell-bind (client (data :pointer) (version :uint32) (id :uint32)) (make-wl-shell client 1 id)) - -#| -(defcallback shell-bind :void ((client-ptr :pointer) (data :pointer) (version :uint32) (id :uint32)) - (bind-wl-shell client-ptr 1 id)) -|# - -#| -(defcallback shell-bind :void - ((client-ptr :pointer) (data :pointer) (version :uint32) (id :uint32)) - (format t "~%shell-bind called: ~A~%" client-ptr) - (waylisp:get-client client-ptr) - (wl-resource-set-implementation - (wl-resource-create client-ptr wl-shell-interface 1 id) - wl-shell-implementation - client-ptr - (null-pointer)));;(callback client-destroy))) -|# diff --git a/wl-subcompositor-impl.lisp b/wl-subcompositor-impl.lisp index 434400a..9e53d07 100644 --- a/wl-subcompositor-impl.lisp +++ b/wl-subcompositor-impl.lisp @@ -5,7 +5,7 @@ (let* ((subsurface (make-wl-subsurface client (get-version subcompositor) id)) (surface (find-resource client surface-ptr)) (parent (find-resource client parent-ptr))) - (setf (parent subsurface) parent) + (setf (parent subsurface) (role parent)) (setf (wl-surface subsurface) surface) (setf (role surface) subsurface) (push subsurface (subsurfaces (role parent)))))