Browse files

Fucking christ

  • Loading branch information...
Shinmera committed Aug 4, 2017
1 parent ebabe54 commit aab03b1cd5240fec71258b581facba19b252309e
Showing with 121 additions and 43 deletions.
  1. +1 −0 editor/icons.lisp
  2. +3 −0 editor/inspector.lisp
  3. +14 −10 editor/object-inspector.lisp
  4. +61 −0 editor/selector.lisp
  5. +2 −1 editor/trial-editor.asd
  6. +1 −1 main.lisp
  7. +2 −2 pipeline.lisp
  8. +2 −3 render-texture.lisp
  9. +17 −6 selection-buffer.lisp
  10. +4 −0 shader-pass.lisp
  11. +14 −20 workbench.lisp
@@ -43,6 +43,7 @@
(setf (q+:icon button) (icon icon)) (setf (q+:icon button) (icon icon))
(when tooltip (setf (q+:tool-tip button) tooltip))) (when tooltip (setf (q+:tool-tip button) tooltip)))
(define-icon :select "mouse-pointer 6.svg")
(define-icon :add "plus 1512.svg") (define-icon :add "plus 1512.svg")
(define-icon :adjust "arrow-outside 262.svg") (define-icon :adjust "arrow-outside 262.svg")
(define-icon :refresh "arrow-repeat 235.svg") (define-icon :refresh "arrow-repeat 235.svg")
@@ -100,3 +100,6 @@
(defmethod add-item (item (inspector inspector)) (defmethod add-item (item (inspector inspector))
(signal! inspector (add-item qobject) (signal! inspector (add-item qobject)
(make-instance 'signal-carrier :object item))) (make-instance 'signal-carrier :object item)))
(defmethod (setf object) :after (object (inspector inspector))
(refresh-instances inspector))
@@ -16,20 +16,20 @@
(refresh-instances object-inspector)) (refresh-instances object-inspector))
(define-subwidget (object-inspector instance-label) (define-subwidget (object-inspector instance-label)
(q+:make-qlabel (safe-princ object)) (q+:make-qlabel)
(setf (q+:alignment instance-label) (q+:qt.align-center)) (setf (q+:alignment instance-label) (q+:qt.align-center))
(setf (q+:style-sheet instance-label) "margin: 2px; font-size: 16pt;")) (setf (q+:style-sheet instance-label) "margin: 2px; font-size: 16pt;"))
(define-subwidget (object-inspector class-button) (define-subwidget (object-inspector class-button)
(q+:make-qpushbutton (prin1-to-string (class-name (class-of object))))) (q+:make-qpushbutton))
(define-subwidget (object-inspector docstring) (define-subwidget (object-inspector docstring)
(q+:make-qlabel (or (documentation (class-of object) T) "<No documentation>")) (q+:make-qlabel)
(setf (q+:word-wrap docstring) T) (setf (q+:word-wrap docstring) T)
(setf (q+:style-sheet docstring) "margin: 10px;")) (setf (q+:style-sheet docstring) "margin: 10px;"))
(define-subwidget (object-inspector slots) (define-subwidget (object-inspector slots)
(make-instance 'slot-listing :object object)) (make-instance 'slot-listing :inspector object-inspector))
(define-subwidget (object-inspector scroller) (define-subwidget (object-inspector scroller)
(q+:make-qscrollarea) (q+:make-qscrollarea)
@@ -66,6 +66,9 @@
(define-slot (object-inspector refresh refresh-instances) () (define-slot (object-inspector refresh refresh-instances) ()
(declare (connected refresh (clicked))) (declare (connected refresh (clicked)))
(setf (q+:text instance-label) (safe-princ object))
(setf (q+:text class-button) (prin1-to-string (class-name (class-of object))))
(setf (q+:text docstring) (or (documentation (class-of object) T) "<No documentation>"))
(qui:clear-layout slots T) (qui:clear-layout slots T)
(dolist (slot (c2mop:class-slots (class-of object))) (dolist (slot (c2mop:class-slots (class-of object)))
(qui:add-item (c2mop:slot-definition-name slot) slots))) (qui:add-item (c2mop:slot-definition-name slot) slots)))
@@ -83,7 +86,7 @@
(trial:finalize object)) (trial:finalize object))
(define-widget slot-listing (QWidget qui:listing) (define-widget slot-listing (QWidget qui:listing)
((object :initarg :object :accessor object))) ((inspector :initarg :inspector :accessor inspector)))
(defmethod qui:coerce-item ((item symbol) (listing slot-listing)) (defmethod qui:coerce-item ((item symbol) (listing slot-listing))
(make-instance 'slot-listing-widget :item item :container listing)) (make-instance 'slot-listing-widget :item item :container listing))
@@ -94,11 +97,12 @@
(define-subwidget (slot-listing-widget name) (define-subwidget (slot-listing-widget name)
(q+:make-qlabel (format NIL "~(~s~)" (qui:widget-item slot-listing-widget))) (q+:make-qlabel (format NIL "~(~s~)" (qui:widget-item slot-listing-widget)))
(setf (q+:fixed-width name) 200)) (setf (q+:tool-tip name) (format NIL "~(~s~)" (qui:widget-item slot-listing-widget)))
(setf (q+:fixed-width name) 150))
(define-subwidget (slot-listing-widget value-button) (define-subwidget (slot-listing-widget value-button)
(q+:make-qpushbutton) (q+:make-qpushbutton)
(let ((object (object (qui:container slot-listing-widget))) (let ((object (object (inspector (qui:container slot-listing-widget))))
(slot (qui:widget-item slot-listing-widget))) (slot (qui:widget-item slot-listing-widget)))
(setf (q+:text value-button) (if (slot-boundp object slot) (setf (q+:text value-button) (if (slot-boundp object slot)
(safe-prin1 (slot-value object slot)) (safe-prin1 (slot-value object slot))
@@ -123,14 +127,14 @@
(define-slot (slot-listing-widget inspect-value) () (define-slot (slot-listing-widget inspect-value) ()
(declare (connected value-button (clicked))) (declare (connected value-button (clicked)))
(let ((object (object (qui:container slot-listing-widget))) (let ((object (object (inspector (qui:container slot-listing-widget))))
(slot (qui:widget-item slot-listing-widget))) (slot (qui:widget-item slot-listing-widget)))
(when (slot-boundp object slot) (when (slot-boundp object slot)
(inspect (slot-value object slot))))) (inspect (slot-value object slot)))))
(define-slot (slot-listing-widget set-value) () (define-slot (slot-listing-widget set-value) ()
(declare (connected set-value (clicked))) (declare (connected set-value (clicked)))
(let* ((object (object (qui:container slot-listing-widget))) (let* ((object (object (inspector (qui:container slot-listing-widget))))
(slot (qui:widget-item slot-listing-widget))) (slot (qui:widget-item slot-listing-widget)))
(multiple-value-bind (value got) (safe-input-value slot-listing-widget) (multiple-value-bind (value got) (safe-input-value slot-listing-widget)
(when got (when got
@@ -139,7 +143,7 @@
(define-slot (slot-listing-widget unbind-slot) () (define-slot (slot-listing-widget unbind-slot) ()
(declare (connected unbind-slot (clicked))) (declare (connected unbind-slot (clicked)))
(let ((object (object (qui:container slot-listing-widget))) (let ((object (object (inspector (qui:container slot-listing-widget))))
(slot (qui:widget-item slot-listing-widget))) (slot (qui:widget-item slot-listing-widget)))
(slot-makunbound object slot) (slot-makunbound object slot)
(setf (q+:text value-button) "<UNBOUND>"))) (setf (q+:text value-button) "<UNBOUND>")))
@@ -0,0 +1,61 @@
This file is a part of trial
(c) 2017 Shirakumo (
Author: Nicolas Hafner <>
(in-package #:org.shirakumo.trial.editor)
(in-readtable :qtools)
(define-widget selector (QDialog)
((scene :initarg :scene :accessor scene)
(buffer :initform NIL :accessor buffer))
(:default-initargs :scene (error "SCENE required.")))
(define-initializer (selector setup)
(setf (q+:window-title selector) "Selector")
(q+:resize selector 500 600)
(setf (buffer selector) (make-instance 'trial::selection-buffer :width 800 :height 600 :scene (scene selector)))
(trial:issue (scene selector) 'trial:load-request :asset (buffer selector) :action 'trial:load)
(trial:add-handler selector (scene selector)))
(define-finalizer (selector teardown)
(trial:issue (scene selector) 'trial:load-request :asset (buffer selector) :action 'trial:offload)
(trial:remove-handler selector (scene selector)))
(define-subwidget (selector empty-text)
(q+:make-qlabel "Select a subject in the game window.")
(setf (q+:alignment empty-text) (q+:qt.align-center)))
(define-subwidget (selector inspector)
(make-instance 'object-inspector :object NIL))
(define-subwidget (selector layout)
(q+:make-qhboxlayout selector)
(q+:add-widget layout empty-text)
(q+:add-widget layout inspector)
(q+:hide inspector)
(setf (q+:margin layout) 0)
(setf (q+:spacing layout) 0))
(define-signal (selector show-object) (qobject))
(define-slot (selector show-object) ((object qobject))
(declare (connected selector (show-object qobject)))
(let ((object (object object)))
(cond (object
(setf (object inspector) object)
(q+:show inspector) (q+:hide empty-text))
(q+:hide inspector) (q+:show empty-text)))))
(defmethod trial:handle (event (selector selector))
(trial:handle event (buffer selector)))
(defmethod trial:handle ((ev trial:reload-scene) (selector selector))
(trial:load (trial:offload (buffer selector))))
(defmethod trial:handle ((ev trial:mouse-release) (selector selector))
(trial:paint (buffer selector) (buffer selector))
(let ((object (trial::object-at-point (trial:pos ev) (buffer selector))))
(signal! selector (show-object qobject) (make-instance 'signal-carrier :object object))))
@@ -25,7 +25,8 @@
(:file "function-inspector") (:file "function-inspector")
(:file "subject-chooser") (:file "subject-chooser")
(:file "subject-class-chooser") (:file "subject-class-chooser")
(:file "scene-graph")) (:file "scene-graph")
(:file "selector"))
:depends-on (:trial :depends-on (:trial
:qtools :qtools
:qtcore :qtcore
@@ -75,7 +75,7 @@
(load (pipeline main))) (load (pipeline main)))
(defmethod paint ((source main) (target main)) (defmethod paint ((source main) (target main))
(paint source (pipeline target))) (paint-with (pipeline target) source))
(defmethod paint ((source main) (target shader-pass)) (defmethod paint ((source main) (target shader-pass))
(paint (scene source) target)) (paint (scene source) target))
@@ -125,7 +125,7 @@
(setf (passes pipeline) (coerce passes 'vector)) (setf (passes pipeline) (coerce passes 'vector))
(setf (textures pipeline) textures))) (setf (textures pipeline) textures)))
(defmethod paint (source (pipeline pipeline)) (defmethod paint-with ((pipeline pipeline) source)
(loop for pass across (passes pipeline) (loop for pass across (passes pipeline)
for fbo = (framebuffer pass) for fbo = (framebuffer pass)
do (gl:bind-framebuffer :framebuffer (resource fbo)) do (gl:bind-framebuffer :framebuffer (resource fbo))
@@ -141,7 +141,7 @@
(:default-initargs (:default-initargs
:name :pipeline)) :name :pipeline))
(defmethod paint :after ((source display) (pipeline frame-pipeline)) (defmethod paint-with :after ((pipeline frame-pipeline) (source display))
(gl:bind-framebuffer :draw-framebuffer 0) (gl:bind-framebuffer :draw-framebuffer 0)
(%gl:blit-framebuffer 0 0 (width source) (height source) 0 0 (width source) (height source) (%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-bitfield-value '%gl::ClearBufferMask :color-buffer)
@@ -23,8 +23,7 @@
(texture (find :color-attachment0 (flow:ports pass) (texture (find :color-attachment0 (flow:ports pass)
:key #'attachment)))) :key #'attachment))))
(defmethod paint :before (source (target render-texture)) (defmethod paint-with :before ((target render-texture) source)
(gl:viewport 0 0 (width target) (height target)) (gl:viewport 0 0 (width target) (height target))
(let ((c (clear-color target))) (let ((c (clear-color target)))
(gl:clear-color (vx c) (vy c) (vz c) (if (vec4-p c) (vw c) 0.0))) (gl:clear-color (vx c) (vy c) (vz c) (if (vec4-p c) (vw c) 0.0))))
(register-object-for-pass target source))
@@ -45,15 +45,20 @@
(defmethod initialize-instance :after ((buffer selection-buffer) &key scene) (defmethod initialize-instance :after ((buffer selection-buffer) &key scene)
(register (make-instance 'selection-buffer-pass) buffer) (register (make-instance 'selection-buffer-pass) buffer)
(pack buffer)
(register-object-for-pass buffer scene)
(add-handler buffer scene)) (add-handler buffer scene))
(defmethod load progn ((buffer selection-buffer))
(pack buffer)
(for:for ((object over (scene buffer)))
(register-object-for-pass buffer object))
(loop for pass across (passes buffer)
do (load pass)))
(defmethod finalize :after ((buffer selection-buffer)) (defmethod finalize :after ((buffer selection-buffer))
(remove-handler buffer (scene buffer))) (remove-handler buffer (scene buffer)))
(defmethod object-at-point ((point vec2) (buffer selection-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) (color->object (gl:read-pixels (round (vx point)) (- (height buffer) (round (vy point))) 1 1 :rgba :unsigned-byte)
buffer)) buffer))
(defmethod color->object (color (buffer selection-buffer)) (defmethod color->object (color (buffer selection-buffer))
@@ -68,6 +73,9 @@
(remhash (ensure-selection-color color) (remhash (ensure-selection-color color)
(color->object-map buffer)))) (color->object-map buffer))))
(defmethod register-object-for-pass :after ((buffer selection-buffer) (selectable selectable))
(setf (color->object (selection-color selectable) buffer) selectable))
(defmethod handle (thing (buffer selection-buffer))) (defmethod handle (thing (buffer selection-buffer)))
(defmethod handle ((resize resize) (buffer selection-buffer)) (defmethod handle ((resize resize) (buffer selection-buffer))
@@ -78,7 +86,6 @@
(defmethod handle ((enter enter) (buffer selection-buffer)) (defmethod handle ((enter enter) (buffer selection-buffer))
(let ((entity (entity enter))) (let ((entity (entity enter)))
(when (typep entity 'selectable) (when (typep entity 'selectable)
(setf (color->object (selection-color entity) buffer) entity)
(load (register-object-for-pass (aref (passes buffer) 0) entity))))) (load (register-object-for-pass (aref (passes buffer) 0) entity)))))
(defmethod handle ((leave leave) (buffer selection-buffer)) (defmethod handle ((leave leave) (buffer selection-buffer))
@@ -87,9 +94,13 @@
(setf (color->object (selection-color entity) buffer) NIL)))) (setf (color->object (selection-color entity) buffer) NIL))))
(defmethod paint ((source selection-buffer) (buffer selection-buffer)) (defmethod paint ((source selection-buffer) (buffer selection-buffer))
(paint (scene source) 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 :around (thing (buffer selection-buffer)) (defmethod paint-with :around ((buffer selection-buffer) thing)
(with-pushed-attribs (with-pushed-attribs
(disable :blend) (disable :blend)
(call-next-method))) (call-next-method)))
@@ -156,6 +156,10 @@
(defmethod register-object-for-pass ((pass per-object-pass) o)) (defmethod register-object-for-pass ((pass per-object-pass) o))
(defmethod register-object-for-pass ((pass per-object-pass) (container container))
(for:for ((object over container))
(register-object-for-pass pass object)))
(defmethod register-object-for-pass ((pass per-object-pass) (class shader-subject-class)) (defmethod register-object-for-pass ((pass per-object-pass) (class shader-subject-class))
(let ((shaders ())) (let ((shaders ()))
(let ((effective-class (determine-effective-shader-class class))) (let ((effective-class (determine-effective-shader-class class)))
@@ -7,32 +7,26 @@
(#p"teapot.vf") (#p"teapot.vf")
:mesh :TEAPOT01MESH) :mesh :TEAPOT01MESH)
(define-shader-subject teapot (vertex-subject colored-subject selectable) (define-asset (workbench cat) texture
() (#p"cat.png"))
(:default-initargs :vertex-array (asset 'workbench 'teapot)))
(define-subject clicky () (define-shader-subject teapot (vertex-subject colored-subject textured-subject located-entity rotated-entity selectable)
((buffer :initform NIL :accessor buffer))) ((vel :initform (/ (random 1.0) (+ 10 (random 20))) :accessor vel))
(:default-initargs :vertex-array (asset 'workbench 'teapot)
:texture (asset 'workbench 'cat)
:rotation (vec 0 0 0)
:color (vec4-random 0.2 0.8)
:location (vec3-random -80 80)))
(define-handler (clicky mouse-release) (ev pos) (define-handler (teapot tick) (ev)
(paint (buffer clicky) (buffer clicky)) (incf (vz (rotation teapot)) (vel teapot)))
(print (object-at-point pos (buffer clicky))))
(defmethod load progn ((clicky clicky))
(setf (buffer clicky) (load (make-instance 'selection-buffer
:scene *loop*
:width (width *context*)
:height (height *context*)))))
(defmethod offload progn ((clicky clicky))
(finalize (buffer clicky)))
(progn (progn
(defmethod setup-scene ((main main)) (defmethod setup-scene ((main main))
(let ((scene (scene main))) (let ((scene (scene main)))
(enter (make-instance 'teapot) scene) (dotimes (i 10)
(enter (make-instance 'target-camera) scene) (enter (make-instance 'teapot) scene))
(enter (make-instance 'clicky) scene))) (enter (make-instance 'target-camera :location (vec 0 100 100)) scene)))
(maybe-reload-scene)) (maybe-reload-scene))

0 comments on commit aab03b1

Please sign in to comment.