Plaster

common-lisp
(ql:quickload '(flare qtools qtgui)) (defpackage #:presenter (:use #:cl+qt #:3d-vectors) (:shadow #:fill) (:export #:define-presentation #:present #:entity #:location #:paint #:sized-entity #:size #:box #:background #:border #:text #:color #:alignment #:textbox)) (in-package #:presenter) (in-readtable :qtools) (define-widget canvas (QWidget) ((progression :initarg :progression :reader progression) (scene :initform (make-instance 'flare:scene) :reader scene) (background :initform (vec 0 0 0) :accessor background))) (defmethod initialize-instance :after ((canvas canvas) &key width height) (setf (q+:fixed-size canvas) (values width height)) (flare:start (scene canvas)) (flare:start (flare:enter (flare:progression-instance (progression canvas)) (scene canvas)))) (define-subwidget (canvas timer) (q+:make-qtimer canvas) (setf (q+:single-shot timer) NIL) (q+:start timer (round 1000/30))) (define-slot (canvas update) () (declare (connected timer (timeout))) (flare:update (scene canvas)) (q+:repaint canvas)) (define-override (canvas paint-event) (ev) (declare (ignore ev)) (with-finalizing ((painter (q+:make-qpainter canvas)) (back (brush (background canvas)))) (setf (q+:background painter) back) (q+:erase-rect painter (q+:rect canvas)) (q+:save painter) (flare:paint scene painter) (q+:restore painter)) (stop-overriding)) (defmethod flare:call-with-translation (func (target qobject) vec) (q+:save target) (unwind-protect (with-finalizing ((point (q+:make-qpointf (vx vec) (vy vec)))) (q+:translate target point) (funcall func)) (q+:restore target))) (defmacro define-presentation (name (width height &rest initargs) &body intervals) `(progn (define-widget ,name (QWidget canvas) () (:default-initargs :progression ',name :width ,width :height ,height ,@initargs)) (flare:define-progression ,name ,@intervals))) (defun present (name) (with-main-window (w name))) (defclass entity (flare:entity) ((flare:location :accessor location))) (defgeneric paint (thing painter) (:method-combination progn)) (defmethod paint progn ((entity entity) painter)) (defmethod flare:paint ((entity entity) target) (flare:with-translation ((location entity) target) (paint entity target))) (defclass sized-entity (entity) ((size :initarg :size :accessor size)) (:default-initargs :size (vec 50 50))) (defclass box (sized-entity) ((background :initarg :background :accessor background) (border :initarg :border :accessor border)) (:default-initargs :background (vec 0 0 0 0) :border (cons (vec 0 0 0 0) (vec 0 0 0 0)))) (defmethod rect ((rect vec4)) (q+:make-qrectf (coerce (vx rect) 'single-float) (coerce (vy rect) 'single-float) (coerce (vz rect) 'single-float) (coerce (vw rect) 'single-float))) (defmethod rect ((rect vec2)) (q+:make-qrectf 0.0 0.0 (coerce (vx rect) 'single-float) (coerce (vy rect) 'single-float))) (defmethod brush ((color vec4)) (q+:make-qbrush (q+:make-qcolor (floor (* 255 (vx color))) (floor (* 255 (vy color))) (floor (* 255 (vz color))) (floor (* 255 (vw color)))))) (defmethod brush ((color vec3)) (q+:make-qbrush (q+:make-qcolor (floor (* 255 (vx color))) (floor (* 255 (vy color))) (floor (* 255 (vz color)))))) (defun fill (painter brush rect) (with-finalizing ((rect (rect rect))) (q+:fill-rect painter rect brush))) (defmethod paint progn ((box box) painter) (let ((size (size box))) (destructuring-bind (offset . color) (border box) (with-finalizing ((brush (brush color))) (fill painter brush (vec (- (vw offset)) (- (vx offset)) (+ (vx size) (vw offset) (vy offset)) (vx offset))) (fill painter brush (vec (vx size) (- (vx offset)) (vy offset) (+ (vy size) (vx offset) (vz offset)))) (fill painter brush (vec (- (vw offset)) (vy size) (+ (vx size) (vw offset) (vy offset)) (vz offset))) (fill painter brush (vec (- (vw offset)) (- (vx offset)) (vw offset) (+ (vy size) (vx offset) (vz offset)))))) (with-finalizing ((brush (brush (background box)))) (fill painter brush (vec 0 0 (vx size) (vy size)))))) (defclass text (sized-entity) ((text :initarg :text :accessor text) (color :initarg :color :accessor color) (alignment :initarg :align :accessor alignment)) (:default-initargs :text "< >" :color (vec 0 0 0 1) :align (cons :center :center))) (defmethod paint progn ((text text) painter) (with-finalizing ((brush (brush (color text))) (rect (rect (size text))) (option (q+:make-qtextoption (logior (ecase (car (alignment text)) (:left (q+:qt.align-left)) (:right (q+:qt.align-right)) (:center (q+:qt.align-hcenter)) (:justify (q+:qt.align-justify))) (ecase (cdr (alignment text)) (:top (q+:qt.align-top)) (:bottom (q+:qt.align-bottom)) (:center (q+:qt.align-vcenter))))))) (setf (q+:brush painter) brush) (q+:draw-text painter rect (text text) option))) (defclass textbox (box text) ()) (define-presentation test (800 600) 1 1 (T (flare:enter textbox :border (cons (vec 3 3 3 3) (vec 0.8 0 0)) :location (vec 50 50) :text "Hi iso" :size (vec 100 30) :name :box)) 0 T (:box (flare:calc location :to (vec (+ 400 (* 400 (sin flare:clock))) 50))))