Skip to content
Branch: master
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
134 lines (108 sloc) 4.7 KB
This file is a part of trial
(c) 2017 Shirakumo (
Author: Nicolas Hafner <>
(in-package #:org.shirakumo.fraf.trial)
(defvar *selection-color-counter* 0)
(defun ensure-selection-color (color)
(etypecase color
((unsigned-byte 32) color)
(let ((id 0))
(setf (ldb (byte 8 0) id) (floor (* 255 (vw color))))
(setf (ldb (byte 8 8) id) (floor (* 255 (vz color))))
(setf (ldb (byte 8 16) id) (floor (* 255 (vy color))))
(setf (ldb (byte 8 24) id) (floor (* 255 (vx color))))
(let ((id 0))
(setf (ldb (byte 8 0) id) (fourth color))
(setf (ldb (byte 8 8) id) (third color))
(setf (ldb (byte 8 16) id) (second color))
(setf (ldb (byte 8 24) id) (first color))
((vector integer 4)
(let ((id 0))
(setf (ldb (byte 8 0) id) (aref color 3))
(setf (ldb (byte 8 8) id) (aref color 2))
(setf (ldb (byte 8 16) id) (aref color 1))
(setf (ldb (byte 8 24) id) (aref color 0))
(defclass selection-buffer (render-texture bakable)
((scene :initarg :scene :accessor scene)
(color->object-map :initform (make-hash-table :test 'eql) :accessor color->object-map))
:width (error "WIDTH required.")
:height (error "HEIGHT required.")
:scene (error "SCENE required.")))
(defmethod initialize-instance :after ((buffer selection-buffer) &key scene)
(enter (make-instance 'selection-buffer-pass) buffer)
(add-handler buffer scene))
(defmethod bake ((buffer selection-buffer))
(pack buffer)
(for:for ((object over (scene buffer)))
(register-object-for-pass buffer object)))
(defmethod finalize :after ((buffer selection-buffer))
(remove-handler buffer (scene buffer)))
(defmethod object-at-point ((point vec2) (buffer selection-buffer))
(color->object (gl:read-pixels (round (vx point)) (round (vy point)) 1 1 :rgba :unsigned-byte)
(defmethod color->object (color (buffer selection-buffer))
(gethash (ensure-selection-color color)
(color->object-map buffer)))
(defmethod (setf color->object) (object color (buffer selection-buffer))
(if object
(setf (gethash (ensure-selection-color color)
(color->object-map buffer))
(remhash (ensure-selection-color color)
(color->object-map buffer))))
(defmethod handle (thing (buffer selection-buffer)))
(defmethod handle ((resize resize) (buffer selection-buffer))
(setf (width buffer) (width resize)
(height buffer) (height resize))
(resize buffer (width resize) (height resize)))
(defmethod handle ((enter enter) (buffer selection-buffer))
(let ((entity (entity enter)))
(when (typep entity 'selectable)
(register-object-for-pass (aref (passes buffer) 0) entity))))
(defmethod handle ((leave leave) (buffer selection-buffer))
(let ((entity (entity leave)))
(when (typep entity 'selectable)
(setf (color->object (selection-color entity) buffer) NIL))))
(defmethod paint ((source selection-buffer) (buffer selection-buffer))
(paint-with buffer (scene source))
(gl:bind-framebuffer :draw-framebuffer 0)
(%gl:blit-framebuffer 0 0 (width source) (height source) 0 0 (width source) (height source)
(cffi:foreign-bitfield-value '%gl::ClearBufferMask :color-buffer)
(cffi:foreign-enum-value '%gl:enum :nearest)))
(defmethod paint-with :around ((buffer selection-buffer) thing)
(disable :blend)
(define-shader-pass selection-buffer-pass (render-pass)
(define-class-shader (selection-buffer-pass :fragment-shader)
"uniform vec4 selection_color;
out vec4 color;
void main(){
color = selection_color;
(define-shader-entity selectable ()
((selection-color :initarg :selection-color :initform (find-new-selection-color) :accessor selection-color)))
(defun find-new-selection-color ()
(let ((num (incf *selection-color-counter*)))
(vec4 (/ (ldb (byte 8 24) num) 255.0)
(/ (ldb (byte 8 16) num) 255.0)
(/ (ldb (byte 8 8) num) 255.0)
(/ (ldb (byte 8 0) num) 255.0))))
(defmethod paint :around ((entity entity) (pass selection-buffer-pass))
(when (or (typep entity 'selectable)
(typep entity 'container))
(defmethod paint :before ((entity selectable) (pass selection-buffer-pass))
(let ((shader (shader-program-for-pass pass entity)))
(setf (uniform shader "selection_color") (selection-color entity))))
(defmethod register-object-for-pass :after ((buffer selection-buffer) (selectable selectable))
(setf (color->object (selection-color selectable) buffer) selectable))
You can’t perform that action at this time.