Mercurial > hg > indyvon
changeset 179:e73174356504
Use defrecord for Views for easier printing and introspection.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Sun, 20 Sep 2015 02:00:53 +0300 |
| parents | 8ba774291bac |
| children | dcb941086063 |
| files | src/indyvon/core.clj src/indyvon/demo.clj src/indyvon/viewport.clj src/indyvon/views.clj |
| diffstat | 4 files changed, 306 insertions(+), 248 deletions(-) [+] |
line wrap: on
line diff
--- a/src/indyvon/core.clj Fri Sep 18 17:59:50 2015 +0300 +++ b/src/indyvon/core.clj Sun Sep 20 02:00:53 2015 +0300 @@ -643,17 +643,20 @@ *event-dispatcher* handle handlers)] (apply f args))) +(defmacro handlers [& specs] + (reduce (fn [m spec] + (assoc m (first spec) + `(fn [~(second spec)] + ~@(nnext spec)))) {} + specs)) + (defmacro with-handlers "specs => (:event-id name & handler-body)* Execute form with the specified event handlers." [handle form & specs] `(with-handlers* ~handle - ~(reduce (fn [m spec] - (assoc m (first spec) - `(fn [~(second spec)] - ~@(nnext spec)))) {} - specs) + (handlers ~@specs) (fn [] ~form))) (defn picked? [handle]
--- a/src/indyvon/demo.clj Fri Sep 18 17:59:50 2015 +0300 +++ b/src/indyvon/demo.clj Sun Sep 20 02:00:53 2015 +0300 @@ -201,14 +201,15 @@ ;; Main scene (def scene - (fps-view - (decorate-view vp [_] - (draw! vp) - (draw-aligned! - (label (str "Drag mouse to pan," \newline - "use mouse wheel to zoom.")) - :left :bottom 5 (- *height* 5)) - (draw! vp-miniature (- *width* 105) 5)))) + (->> vp + (decorator (fn [_ content] + (draw! content) + (draw-aligned! + (label (str "Drag mouse to pan," \newline + "use mouse wheel to zoom.")) + :left :bottom 5 (- *height* 5)) + (draw! vp-miniature (- *width* 105) 5))) + fps-view)) (defn show-frame [view] (doto (make-jframe "Test" view)
--- a/src/indyvon/viewport.clj Fri Sep 18 17:59:50 2015 +0300 +++ b/src/indyvon/viewport.clj Sun Sep 20 02:00:53 2015 +0300 @@ -174,65 +174,67 @@ (min (/ max-width width) (/ max-height height))) +(def ^:dynamic *miniature-thread-priority* 2) + (defn miniature "Creates a view that asynchronously renders the content view scaled to the specified size." [mw mh content] - (async-view - mw mh *miniature-thread-priority* - (reify - View - (render! [this] - (let [geom (geometry content) - cw (width geom) - ch (height geom) - s (scaling cw ch mw mh)] - (.scale *graphics* s s) - (draw! content - (align-x :center cw (/ mw s)) - (align-y :center ch (/ mh s)) - cw ch))) - (geometry [_] - (->Size mw mh))))) + (->> content + (decorator (fn [_ content] + (let [geom (geometry content) + cw (width geom) + ch (height geom) + s (scaling cw ch mw mh)] + (.scale *graphics* s s) + (draw! content + (align-x :center cw (/ mw s)) + (align-y :center ch (/ mh s)) + cw ch))) + (fn [_ _] + (->Size mw mh))) + (async-view mw mh *miniature-thread-priority*))) (defn viewport-miniature "Creates miniature view of the viewport's contents." [m-width m-height viewport] - (let [miniature (miniature m-width m-height (:content viewport))] - (decorate-view miniature [l] - (repaint-on-update! viewport) - (let [geom (geometry (:content viewport)) - s (scaling (width geom) (height geom) m-width m-height) - vp-state @(:state viewport) - {:keys [transform last-width last-height]} @(:state viewport) - ox (align-x :center (width geom) (/ m-width s)) - oy (align-y :center (height geom) (/ m-height s)) - inverse (.createInverse ^AffineTransform transform) - transform (doto (AffineTransform.) - (.scale s s) - (.translate ox oy) - (.concatenate inverse)) - move-vp (fn [state x y] - (let [x (- (/ x s) ox) - y (- (/ y s) oy) - tr (:transform state) - [x y] (transform-point tr x y) - x (- x (/ (:last-width state) 2)) - y (- y (/ (:last-height state) 2))] - (assoc state - :transform (pre-translate tr (- x) (- y))))) - move-vp! (fn [x y] - (swap! (:state viewport) move-vp x y) - (notify! viewport))] - (with-color :alt-back-color - (.fillRect *graphics* 0 0 *width* *height*)) - (with-transform transform - (with-color :back-color - (.fillRect *graphics* 0 0 last-width last-height))) - (with-handlers l - (draw! miniature) - [:mouse-pressed e (move-vp! (:x e) (:y e))] - [:mouse-dragged e (move-vp! (:x e) (:y e))]) - (with-transform transform - (with-color :border-color - (.drawRect *graphics* 0 0 last-width last-height))))))) + (->> (:content viewport) + (miniature m-width m-height) + (decorator + (fn [v m] + (repaint-on-update! viewport) + (let [geom (geometry (:content viewport)) + s (scaling (width geom) (height geom) m-width m-height) + vp-state @(:state viewport) + {:keys [transform last-width last-height]} @(:state viewport) + ox (align-x :center (width geom) (/ m-width s)) + oy (align-y :center (height geom) (/ m-height s)) + inverse (.createInverse ^AffineTransform transform) + transform (doto (AffineTransform.) + (.scale s s) + (.translate ox oy) + (.concatenate inverse)) + move-vp (fn [state x y] + (let [x (- (/ x s) ox) + y (- (/ y s) oy) + tr (:transform state) + [x y] (transform-point tr x y) + x (- x (/ (:last-width state) 2)) + y (- y (/ (:last-height state) 2))] + (assoc state + :transform (pre-translate tr (- x) (- y))))) + move-vp! (fn [x y] + (swap! (:state viewport) move-vp x y) + (notify! viewport))] + (with-color :alt-back-color + (.fillRect *graphics* 0 0 *width* *height*)) + (with-transform transform + (with-color :back-color + (.fillRect *graphics* 0 0 last-width last-height))) + (with-handlers v + (draw! m) + [:mouse-pressed e (move-vp! (:x e) (:y e))] + [:mouse-dragged e (move-vp! (:x e) (:y e))]) + (with-transform transform + (with-color :border-color + (.drawRect *graphics* 0 0 last-width last-height))))))))
--- a/src/indyvon/views.clj Fri Sep 18 17:59:50 2015 +0300 +++ b/src/indyvon/views.clj Sun Sep 20 02:00:53 2015 +0300 @@ -30,14 +30,26 @@ java.util.concurrent.TimeUnit (com.google.common.cache Cache CacheBuilder CacheLoader))) -(defmacro decorate-view - "Decorate the view replacing render! implementation." - [view & render-tail] - `(let [view# ~view] - (reify - View - (render! ~@render-tail) - (geometry [t#] (geometry view#))))) +(defrecord Decorator [render-fn geometry-fn content] + View + (render! [decorator] + (render-fn decorator content)) + (geometry [decorator] + (geometry-fn decorator content))) + +(defn- decorator-content-geometry [_ content] + (geometry content)) + +(defn decorator + "Creates a decorator view. Functions render-fn and geometry-fn will + be called with the decorator and content as arguments. Use this in + preference to (reify View) as it creates a defrecord instance + instead of an opaque reify object. Prefer to pass render-fn and + geometry-fn as Vars to allow the view to be printed and read back." + ([render-fn content] + (decorator render-fn #'decorator-content-geometry content)) + ([render-fn geometry-fn content] + (->Decorator render-fn geometry-fn content))) (defrecord Empty [] View @@ -47,23 +59,39 @@ (def empty-view (->Empty)) +(defrecord Padding [top left bottom right content] + View + (render! [l] + (draw! content + left top + (- *width* left right) + (- *height* top bottom) + false)) + (geometry [l] + (->NestedGeometry (geometry content) top left bottom right))) + (defn padding "Adds padding to the content view." ([distance content] - (padding distance distance distance distance content)) + (padding distance distance distance distance content)) ([top left bottom right content] - (if (== 0 top left bottom right) - content - (reify - View - (render! [l] - (draw! content - left top - (- *width* left right) - (- *height* top bottom) - false)) - (geometry [l] - (->NestedGeometry (geometry content) top left bottom right)))))) + (if (== 0 top left bottom right) + content + (->Padding top left bottom right content)))) + +(defrecord Border [^double thickness content] + View + (render! [_] + (render! content) + (with-color :border-color + (let [w (double *width*) + h (double *height*) + t thickness + outer (Area. (Rectangle2D$Double. 0.0 0.0 w h)) + inner (Area. (Rectangle2D$Double. t t (- w t t) (- h t t)))] + (.subtract outer inner) + (.fill *graphics* outer)))) + (geometry [_] (geometry content))) (defn border "Adds a border to the content view." @@ -72,52 +100,45 @@ ([thickness content] (border thickness 0 content)) ([thickness gap content] - (let [view (padding (+ thickness gap) content) - t (double thickness)] - (decorate-view view [_] - (render! view) - (with-color :border-color - (let [w (double *width*) - h (double *height*) - outer (Area. (Rectangle2D$Double. 0.0 0.0 w h)) - inner (Area. (Rectangle2D$Double. t t (- w t t) (- h t t)))] - (.subtract outer inner) - (.fill *graphics* outer))))))) + (->Border thickness (padding (+ thickness gap) content)))) ;; TODO: opacity and blur. +(defrecord Shadow [^double x ^double y content] + View + (render! [_] + (let [w (- *width* (Math/abs x)) + h (- *height* (Math/abs y))] + (with-color :shadow-color + (.fillRect *graphics* (max x 0.0) (max y 0.0) w h)) + (draw! content (max (- x) 0.0) (max (- y) 0.0) w h))) + (geometry [_] + (->NestedGeometry (geometry content) + (max (- y) 0.0) ;; top + (max (- x) 0.0) ;; left + (max y 0.0) ;; bottom + (max x 0.0)))) ;; right (defn shadow "Adds a shadow to the content view." ([content] - (shadow 1 1 content)) + (shadow 1 1 content)) ([x-offset y-offset content] - (let [x (if (neg? x-offset) (- x-offset) 0) - y (if (neg? y-offset) (- y-offset) 0) - abs-x (if (neg? x-offset) (- x-offset) x-offset) - abs-y (if (neg? y-offset) (- y-offset) y-offset) - shadow-x (+ x-offset x) - shadow-y (+ y-offset y)] - (reify - View - (render! [_] - (let [w (- *width* abs-x) - h (- *height* abs-y)] - (with-color :shadow-color - (.fillRect *graphics* shadow-x shadow-y w h)) - (draw! content x y w h))) - (geometry [_] - (->NestedGeometry (geometry content) - y x shadow-y shadow-x)))))) + (->Shadow x-offset y-offset content))) + +(defrecord Panel [back-color content] + View + (render! [_] + (with-color back-color + (.fill *graphics* (Rectangle2D$Double. 0.0 0.0 *width* *height*))) + (render! content)) + (geometry [_] (geometry content))) (defn panel "An opaque view using theme's alt-back-color or a custom background color." ([content] - (panel :alt-back-color content)) + (panel :alt-back-color content)) ([back-color content] - (decorate-view content [_] - (with-color back-color - (.fill *graphics* (Rectangle2D$Double. 0.0 0.0 *width* *height*))) - (render! content)))) + (->Panel back-color content))) (defrecord Box [proportional? translate-geometry contents] View @@ -242,40 +263,53 @@ (.getLeading tl))) 0 layouts)) +(defrecord Label [h-align v-align lines] + View + (render! [view] + (let [w *width* + h *height* + font (.getFont *graphics*) + layouts (layout-text lines font (font-context)) + y (align-y v-align (text-height layouts) h)] + (loop [layouts layouts, y y] + (when-first [^TextLayout layout layouts] + (let [ascent (.getAscent layout) + lh (+ ascent (.getDescent layout) (.getLeading layout)) + x (align-x h-align (.getAdvance layout) w)] + (.draw layout *graphics* x (+ y ascent)) + (recur (next layouts) (+ y lh))))))) + (geometry [view] + (let [layouts (layout-text lines (theme-get :font) (font-context)) + w (text-width layouts) + h (text-height layouts)] + (->Size w h)))) + (defn label "Creates a view to display multiline text." ([text] - (label :left :top text)) + (label :left :top text)) ([h-align v-align text] - (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text))] - (reify View - (render! [view] - (let [w *width* - h *height* - font (.getFont *graphics*) - layouts (layout-text lines font (font-context)) - y (align-y v-align (text-height layouts) h)] - (loop [layouts layouts, y y] - (when-first [^TextLayout layout layouts] - (let [ascent (.getAscent layout) - lh (+ ascent (.getDescent layout) (.getLeading layout)) - x (align-x h-align (.getAdvance layout) w)] - (.draw layout *graphics* x (+ y ascent)) - (recur (next layouts) (+ y lh))))))) - (geometry [view] - (let [layouts (layout-text lines (theme-get :font) (font-context)) - w (text-width layouts) - h (text-height layouts)] - (->Size w h))))))) + (->Label h-align + v-align + (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text))))) -(defn- ^ImageObserver image-observer [view] - (reify - ImageObserver - (imageUpdate [this img infoflags x y width height] - (notify! view) - (zero? (bit-and infoflags - (bit-or ImageObserver/ALLBITS - ImageObserver/ABORT)))))) +(defrecord ImageView [^Image image] + View + (render! [view] + (repaint-on-update! view) + (.drawImage *graphics* image 0 0 view)) + (geometry [view] + (let [width (.getWidth image view) + height (.getHeight image view) + width (if (pos? width) width 1) + height (if (pos? height) height 1)] + (->Size width height))) + ImageObserver + (imageUpdate [view img infoflags x y width height] + (notify! view) + (zero? (bit-and infoflags + (bit-or ImageObserver/ALLBITS + ImageObserver/ABORT))))) (defn image-view [image-or-uri] @@ -284,93 +318,97 @@ (.getImage (Toolkit/getDefaultToolkit) ^java.net.URL image-or-uri))] (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil) - (reify - View - (render! [view] - (repaint-on-update! view) - (.drawImage *graphics* image 0 0 (image-observer view))) - (geometry [view] - (let [observer (image-observer view) - width (.getWidth image observer) - height (.getHeight image observer) - width (if (pos? width) width 1) - height (if (pos? height) height 1)] - (->Size width height)))))) + (->ImageView image))) -(def ^:dynamic *miniature-thread-priority* 2) +(defrecord RefView [reference view-delay-atom] + View + (render! [v] + (repaint-on-update! v) + (when-let [view @@view-delay-atom] + (render! view))) + (geometry [v] + (if-let [view @@view-delay-atom] + (geometry view) + (->Size 1 1)))) (defn ref-view - ([view-ref] - (ref-view view-ref identity)) - ([view-ref view-fn] - (let [v (reify - View - (render! [v] - (repaint-on-update! v) - (when-let [view (view-fn @view-ref)] - (render! view))) - (geometry [_] - (if-let [view (view-fn @view-ref)] - (geometry view) - (->Size 1 1))))] - (add-watch view-ref v (fn [_ _ _ _] (notify! v))) + ([reference] + (ref-view reference #'identity)) + ([reference view-fn] + ;; The reference may update multiple times before repaint happens, + ;; delay is used to avoid unnecessary invocations of view-fn. + (let [view-delay-atom (atom (delay (view-fn @reference))) + v (->RefView reference view-delay-atom)] + (add-watch reference v (fn [_ _ _ n] + (reset! view-delay-atom (delay (view-fn n))) + (notify! v))) v))) ;; ;; View context decorators ;; -(defmacro add-handlers [view & handlers] +(defrecord Active [handlers content] + View + (render! [v] + (with-handlers* v handlers render! content)) + (geometry [_] + (geometry content))) + +(defmacro add-handlers [view & event-handlers] "Adds event handling to the view." - `(let [view# ~view] - (decorate-view view# [t#] - (with-handlers t# - (render! view#) - ~@handlers)))) + `(->Active (handlers ~@event-handlers) ~view)) + +(defrecord Themed [theme view] + View + (render! [_] + (with-theme theme + (apply-theme) + (render! view))) + (geometry [_] + (with-theme* theme geometry view))) (defn themed [theme view] - (reify - View - (render! [_] - (with-theme theme - (apply-theme) - (render! view))) - (geometry [_] - (with-theme* theme geometry view)))) + (->Themed theme view)) + +(defrecord Hinted [hints view] + View + (render! [_] + (with-hints* hints render! view)) + (geometry [_] + (if (bound? #'*graphics*) + (with-hints* hints geometry view) + (geometry view)))) (defn hinted [hints view] - (reify - View - (render! [_] - (with-hints* hints render! view)) - (geometry [_] - (if (bound? #'*graphics*) - (with-hints* hints geometry view) - (geometry view))))) + (->Hinted hints view)) (defn- transform-bounds ^Rectangle2D [^AffineTransform tr ^double w ^double h] (.getBounds2D (.createTransformedShape tr (Rectangle2D$Double. 0 0 w h)))) +(defrecord Transform [transform view] + View + (render! [v] + (let [g (geometry view) + w (double (width g)) + h (double (height g)) + ^Rectangle2D bounds (transform-bounds transform w h) + g *graphics*] + (.translate g (- (.getX bounds)) (- (.getY bounds))) + (.transform g transform) + ;; TODO: scale w and h to fit *width* and *height*. + (draw! view 0 0 w h))) + (geometry [_] + (let [g (geometry view) + w (double (width g)) + h (double (height g)) + ^Rectangle2D bounds (transform-bounds transform w h)] + (->Size (.getWidth bounds) (.getHeight bounds))))) + (defn transform [tr view] - (reify View - (render! [v] - (let [g (geometry view) - w (double (width g)) - h (double (height g)) - ^Rectangle2D bounds (transform-bounds tr w h) - g *graphics*] - (.translate g (- (.getX bounds)) (- (.getY bounds))) - (.transform g tr) - ;; TODO: scale w and h to fit *width* and *height*. - (draw! view 0 0 w h))) - (geometry [_] - (let [g (geometry view) - w (double (width g)) - h (double (height g)) - ^Rectangle2D bounds (transform-bounds tr w h)] - (->Size (.getWidth bounds) (.getHeight bounds)))))) + (->Transform tr view)) (defn rotate [^double degrees view] (transform @@ -383,44 +421,51 @@ (def ^:dynamic *interval*) +(defrecord IntervalView [last-time content] + View + (render! [_] + (compare-and-set! last-time nil *time*) + (let [lt @last-time] + (binding [*interval* (if (compare-and-set! last-time lt *time*) + (- *time* lt) + 0)] ; already measured on parallel thread + (render! content)))) + (geometry [_] + (geometry content))) + (defn interval-view - "Creates a view that measures time between repaints ant draws it's + "Creates a view that measures time between repaints and draws it's content with the *interval* var bound to the measured time." [content] - (let [last-time (atom nil)] - (decorate-view content [_] - (compare-and-set! last-time nil *time*) - (let [lt @last-time] - (binding [*interval* (if (compare-and-set! last-time lt *time*) - (- *time* lt) - 0)] ; already measured on parallel thread - (render! content)))))) + (->IntervalView (atom nil) content)) (defn- fps-label [text] (padding 5 (label :right :bottom text))) +(defrecord FPSView [update-interval frames prev-time display content] + View + (render! [_] + (draw! content) + (draw! + (dosync + (alter frames inc) + (if @prev-time + (let [elapsed (- *time* @prev-time)] + (when (> elapsed update-interval) + (let [fps (/ @frames (/ elapsed 1E9))] + (ref-set display (fps-label (format "%.1f" fps))) + (ref-set frames 0) + (ref-set prev-time *time*)))) + (ref-set prev-time *time*)) + @display))) + (geometry [_] (geometry content))) + (defn fps-view "Creates a view that draws content and displays the frames per second rate." [content] - (let [update-interval 2E8 ; 0.2 s in nanoseconds - frames (ref 0) - prev-time (ref nil) - display (ref (fps-label "fps n/a"))] - (decorate-view content [_] - (draw! content) - (draw! - (dosync - (alter frames inc) - (if @prev-time - (let [elapsed (- *time* @prev-time)] - (when (> elapsed update-interval) - (let [fps (/ @frames (/ elapsed 1E9))] - (ref-set display (fps-label (format "%.1f" fps))) - (ref-set frames 0) - (ref-set prev-time *time*)))) - (ref-set prev-time *time*)) - @display))))) + ;; 2E8 ns = 0.2 s. + (->FPSView 2E8 (ref 0) (ref nil) (ref (fps-label "fps n/a")) content)) ;; ;; Overlays @@ -457,7 +502,7 @@ (draw! view x y w h))) (defn overlay! - "Draws view in the overlay context above the other views." + "Draws view in the overlay context above the current layer." ([view] (overlay* draw-relative! view (.getTransform *graphics*) 0 0)) ([view x y] @@ -488,9 +533,16 @@ (defmacro with-overlays [recursive? & body] `(with-overlays* ~recursive? (fn [] ~@body))) +(defrecord Layered [recursive? content] + View + (render! [_] + (with-overlays* recursive? render! content)) + (geometry [_ ] + (geometry content))) + (defn layered + "Allows content view to display pop-ups on top of itself." ([content] - (layered true content)) + (layered true content)) ([recursive? content] - (decorate-view content [_] - (with-overlays* recursive? render! content)))) + (->Layered recursive? content)))