Mercurial > hg > indyvon
view src/net/kryshen/indyvon/layers.clj @ 106:f42e2b9e1ad9
Removed Anchored protocol, "layer-size" function in Layer replaced with "geometry" which returns a structure describing both layer size and anchor point.
Indyvon now requires Clojure 1.3.
author | Mikhail Kryshen <mikhail@kryshen.net> |
---|---|
date | Wed, 21 Sep 2011 02:27:11 +0300 |
parents | 24e98602b37e |
children | 5fdb0bb99f75 |
line wrap: on
line source
;; ;; Copyright 2010, 2011 Mikhail Kryshen <mikhail@kryshen.net> ;; ;; This file is part of Indyvon. ;; ;; Indyvon is free software: you can redistribute it and/or modify it ;; under the terms of the GNU Lesser General Public License version 3 ;; only, as published by the Free Software Foundation. ;; ;; Indyvon is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public ;; License along with Indyvon. If not, see ;; <http://www.gnu.org/licenses/>. ;; (ns net.kryshen.indyvon.layers "Implementations of Layer protocol." (:use (net.kryshen.indyvon core async)) (:import (java.lang.ref SoftReference) (java.awt Font Cursor Image Toolkit Point) java.awt.image.ImageObserver (java.awt.geom AffineTransform Point2D$Double) (java.awt.font FontRenderContext TextLayout) java.util.concurrent.TimeUnit com.google.common.collect.MapMaker com.google.common.base.Function)) ;; Define as macro to avoid unnecessary calculation of inner and outer ;; sizes in the first case. (defmacro align-xy [inner outer align first center last] `(case ~align ~first 0 ~center (/ (- ~outer ~inner) 2) ~last (- ~outer ~inner))) (defmacro align-x [inner outer align] `(align-xy ~inner ~outer ~align :left :center :right)) (defmacro align-y [inner outer align] `(align-xy ~inner ~outer ~align :top :center :bottom)) (defmacro decorate-layer "Decorate Layer replacing render! implementation." [layer & render-tail] `(let [layer# ~layer] (reify Layer (render! ~@render-tail) (geometry [t#] (geometry layer#))))) (defn padding "Decorates layer adding padding." ([content pad] (padding content pad pad pad pad)) ([content top left bottom right] (if (== 0 top left bottom right) content (reify Layer (render! [l] (draw! content left top (- *width* left right) (- *height* top bottom))) (geometry [l] (->NestedGeometry (geometry content) top left bottom right)))))) (defn border "Decorate layer with a border." ([content] (border content 1)) ([content width] (border content width 0)) ([content width gap] (let [layer (padding content (+ width gap))] (decorate-layer layer [_] (let [bw (int width) w (int *width*) h (int *height*) iw (- w bw) ih (- h bw)] (with-color :border-color (doto *graphics* (.fillRect 0 0 iw bw) (.fillRect iw 0 bw ih) (.fillRect bw ih iw bw) (.fillRect 0 bw bw ih)))) (render! layer))))) ;; TODO: opacity and blur. (defn shadow "Add shadow to content layer." ([content] (shadow content 1 1)) ([content x-offset y-offset] (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 Layer (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)))))) (defn panel "Opaque layer using theme's alt-back-color." ([content] (panel content 0)) ([content gap] (let [layer (padding content gap)] (decorate-layer layer [_] (with-color :alt-back-color (.fillRect *graphics* 0 0 *width* *height*)) (render! layer))))) (defn hbox "Creates layer that draws the specified content layers placing them horizontally." [& contents] (reify Layer (render! [_] (let [widths (map #(width (geometry %)) contents) xs (cons 0 (reductions + widths)) widths-sum (last xs) scale (/ *width* widths-sum)] (doseq [[c w x] (map vector contents widths xs)] (draw! c x 0 w *height*)))) (geometry [_] (reduce #(->Size (+ (width %1) (width %2)) (max (height %1) (height %2))) (->Size 0 0) (map geometry contents))))) (defn vbox "Creates layer that draws the specified content layers placing them vertically." [& contents] (reify Layer (render! [_] (let [heights (map #(height (geometry %)) contents) ys (cons 0 (reductions + heights)) heights-sum (last ys) scale (/ *height* heights-sum)] (doseq [[c h y] (map vector contents heights ys)] (draw! c 0 y *width* h)))) (geometry [_] (reduce #(->Size (max (width %1) (width %2)) (+ (height %1) (height %2))) (->Size 0 0) (map geometry contents))))) (defn- re-split [^java.util.regex.Pattern re s] (seq (.split re s))) (def ^{:private true} text-layout-cache (-> (MapMaker.) (.softValues) (.expireAfterAccess (long 1) TimeUnit/SECONDS) (.makeComputingMap (reify Function (apply [_ k] (TextLayout. ^String (k 0) ^Font (k 1) ^FontRenderContext (k 2))))))) (defn- get-text-layout [line font font-context] (get text-layout-cache [line font font-context])) (defn- layout-text [lines ^Font font ^FontRenderContext font-context] (map #(get-text-layout % font font-context) lines)) (defn- text-width [layouts] (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts)) (defn- text-height [layouts] (reduce (fn [w ^TextLayout tl] (+ w (.getAscent tl) (.getDescent tl) (.getLeading tl))) 0 layouts)) (defn label "Creates a layer to display multiline text." ([text] (label text :left :top)) ([text h-align v-align] (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text))] (reify Layer (render! [layer] (let [w *width* h *height* font (.getFont *graphics*) layouts (layout-text lines font *font-context*) y (align-y (text-height layouts) h v-align)] (loop [layouts layouts, y y] (when-first [^TextLayout layout layouts] (let [ascent (.getAscent layout) lh (+ ascent (.getDescent layout) (.getLeading layout)) x (align-x (.getAdvance layout) w h-align)] (.draw layout *graphics* x (+ y ascent)) (recur (next layouts) (+ y lh))))))) (geometry [layer] (let [layouts (layout-text lines (:font *theme*) *font-context*) w (text-width layouts) h (text-height layouts)] (->Size w h))))))) (defn- ^ImageObserver image-observer [layer] (reify ImageObserver (imageUpdate [this img infoflags x y width height] (update layer) (zero? (bit-and infoflags (bit-or ImageObserver/ALLBITS ImageObserver/ABORT)))))) (defn image-layer [image-or-uri] (let [^Image image (if (instance? Image image-or-uri) image-or-uri (.getImage (Toolkit/getDefaultToolkit) ^java.net.URL image-or-uri))] (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil) (reify Layer (render! [layer] (repaint-on-update layer) (.drawImage *graphics* image 0 0 (image-observer layer))) (geometry [layer] (let [observer (image-observer layer) width (.getWidth image observer) height (.getHeight image observer) width (if (pos? width) width 1) height (if (pos? height) height 1)] (->Size width height)))))) (def ^{:dynamic true} *miniature-thread-priority* 2) (defn- scaling [width height max-width max-height] (min (/ max-width width) (/ max-height height))) (defn miniature "Creates layer that asynchronously renders view of the content scaled to the specified size." [content mw mh] (async-layer (reify Layer (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 cw (/ mw s) :center) (align-y ch (/ mh s) :center) cw ch))) (geometry [_] (->Size mw mh))) mw mh *miniature-thread-priority*)) ;;(defn- translate [^AffineTransform transform ^double x ^double y] ;; (doto ^AffineTransform (.clone transform) ;; (.translate x y))) (defn- scale [^AffineTransform transform ^double sx ^double sy] (doto ^AffineTransform (.clone transform) (.scale sx sy))) (defn- pre-translate [^AffineTransform transform ^double x ^double y] (if (== 0.0 x y) transform (doto (AffineTransform/getTranslateInstance x y) (.concatenate transform)))) (def ^{:dynamic true} *viewport-scaling-step* (double 3/4)) (def ^{:dynamic true} *viewport-min-scale* 1E-6) (def ^{:dynamic true} *viewport-max-scale* 1E6) (defrecord Viewport [content h-align v-align ;; State (refs) transform fix-x fix-y last-width last-height last-anchor-x last-anchor-y] Layer (render! [layer] (repaint-on-update layer) (with-handlers layer (let [geom (geometry content) cw (width geom) ch (height geom) ax (anchor-x geom h-align cw) ay (anchor-y geom v-align ch)] (dosync (let [ax1 (align-x @last-width *width* h-align) ay1 (align-y @last-height *height* v-align) ax2 (- @last-anchor-x ax) ay2 (- @last-anchor-y ay)] (if-not (and (zero? ax1) (zero? ay1) (zero? ax2) (zero? ay2)) (ref-set transform (doto (AffineTransform/getTranslateInstance ax1 ay1) (.concatenate @transform) (.translate ax2 ay2))))) (ref-set last-width *width*) (ref-set last-height *height*) (ref-set last-anchor-x ax) (ref-set last-anchor-y ay)) ;; TODO: notify observers when size changes. (with-transform @transform (draw! content 0 0 cw ch false))) (:mouse-pressed e (dosync (ref-set fix-x (:x-on-screen e)) (ref-set fix-y (:y-on-screen e))) (when *target* (->> Cursor/MOVE_CURSOR Cursor. (.setCursor *target*)))) (:mouse-released e (when *target* (->> Cursor/DEFAULT_CURSOR Cursor. (.setCursor *target*)))) (:mouse-dragged e (dosync (alter transform pre-translate (- (:x-on-screen e) @fix-x) (- (:y-on-screen e) @fix-y)) (ref-set fix-x (:x-on-screen e)) (ref-set fix-y (:y-on-screen e))) (update layer)) (:mouse-wheel e (dosync (let [s (Math/pow *viewport-scaling-step* (:wheel-rotation e)) x (- (:x e) (* (:x e) s)) y (- (:y e) (* (:y e) s)) scaled (doto (AffineTransform/getTranslateInstance x y) (.scale s s) (.concatenate @transform)) sx (.getScaleX scaled) sy (.getScaleY scaled)] (if (<= *viewport-min-scale* (min sx sy) (max sx sy) *viewport-max-scale*) (ref-set transform scaled)))) (update layer)))) (geometry [_] (geometry content))) (defn viewport "Creates scrollable viewport layer." ([content] (viewport content :left :top)) ([content h-align v-align] (Viewport. content h-align v-align (ref (AffineTransform.)) ; transform (ref 0) (ref 0) ; fix-x fix-y (ref 0) (ref 0) ; last-width last-height (ref 0) (ref 0)))) ; last-anchor-x last-anchor-y (defn reset-viewport [viewport] (dosync (ref-set (:last-width viewport) 0) (ref-set (:last-height viewport) 0) (ref-set (:last-anchor-x viewport) 0) (ref-set (:last-anchor-y viewport) 0) (ref-set (:transform viewport) (AffineTransform.))) (update viewport)) (defn viewport-miniature "Creates miniature view of the viewport's contents." [viewport m-width m-height] (let [miniature (miniature (:content viewport) m-width m-height)] (decorate-layer miniature [l] (repaint-on-update viewport) (let [geom (geometry (:content viewport)) s (scaling (width geom) (height geom) m-width m-height) [vp-tr w h] (dosync [@(:transform viewport) @(:last-width viewport) @(:last-height viewport)]) vp-inverse (.createInverse ^AffineTransform vp-tr) ox (align-x (width geom) (/ m-width s) :center) oy (align-y (height geom) (/ m-height s) :center) transform (doto (AffineTransform.) (.scale s s) (.translate ox oy) (.concatenate vp-inverse)) move-vp (fn [x y] (dosync (let [x (- (/ x s) ox) y (- (/ y s) oy) [x y] (transform-point @(:transform viewport) x y) x (- x (/ @(:last-width viewport) 2)) y (- y (/ @(:last-height viewport) 2))] (alter (:transform viewport) pre-translate (- x) (- y)))) (update viewport))] (with-color :alt-back-color (.fillRect *graphics* 0 0 *width* *height*)) (with-transform transform (with-color :back-color (.fillRect *graphics* 0 0 w h))) (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 w h))))))) (defn ref-layer [layer-ref] (let [l (reify Layer (render! [l] (repaint-on-update l) (if-let [layer @layer-ref] (render! layer))) (geometry [_] (if-let [layer @layer-ref] (geometry layer) (->Size 1 1))))] (add-watch layer-ref l (fn [_ _ _ _] (update l))) l)) ;; ;; Layer context decorators. ;; (defmacro handler [layer & handlers] "Decorate layer to handle events." `(let [layer# ~layer] (decorate-layer layer# [t#] (with-handlers t# (render! layer#) ~@handlers)))) (defn themed [layer & map-or-keyvals] (let [theme (if (== (count map-or-keyvals) 1) (first map-or-keyvals) (apply array-map map-or-keyvals))] (reify Layer (render! [_] (with-theme theme (render! layer))) (geometry [_] (with-theme theme (geometry layer)))))) (defn hinted [layer & map-or-keyvals] (let [hints (if (== (count map-or-keyvals) 1) (first map-or-keyvals) (apply array-map map-or-keyvals))] (decorate-layer layer [_] (with-hints* hints render! layer)))) ;; ;; Measuring time ;; (def ^{:dynamic true} *interval*) (defn interval-layer "Creates layer that measures time between repaints ant draws it's content with the *interval* var bound to the measured time." [content] (let [last-time (atom nil)] (decorate-layer 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)))))) (defn- fps-label [text] (padding (label text :right :bottom) 5)) (defn fps-layer "Creates layer that draws content and displays the frames per seconds 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-layer 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))))) ;; ;; Overlayer. ;; (def ^{:private true :dynamic true} *above*) (defn- overlay* [f & args] (var-set #'*above* (conj *above* (apply partial f args)))) (defn- ^Point to-graphics-coords [^AffineTransform transform x y] (let [p (Point. x y)] (.transform transform p p) (.transform (.createInverse (.getTransform *graphics*)) p p) p)) (defn- draw-relative! ([layer transform x y] (let [p (to-graphics-coords transform x y)] (draw! layer (.x p) (.y p)))) ([layer transform x y w h] (let [p (to-graphics-coords transform x y)] (draw! layer (.x p) (.y p) w h)))) (defn- draw-relative-aligned! [layer transform h-align v-align x y] (let [geom (geometry layer) w (width geom) h (height geom) p (to-graphics-coords transform x y) x (- (.x p) (anchor-x geom h-align w)) y (- (.y p) (anchor-y geom v-align h))] (draw! layer x y w h))) (defn overlay! "Draws layer in the overlayer context above the other layers." ([layer] (overlay* draw-relative! layer (.getTransform *graphics*) 0 0)) ([layer x y] (overlay* draw-relative! layer (.getTransform *graphics*) x y)) ([layer x y w h] (overlay* draw-relative! layer (.getTransform *graphics*) x y w h))) (defn overlay-aligned! [layer h-align v-align x y] (overlay* draw-relative-aligned! layer (.getTransform *graphics*) h-align v-align x y)) (defn overlayer [content] (decorate-layer content [_] (binding [*above* []] (render! content) (doseq [f *above*] (f))))) (defn overlayer* [content] (decorate-layer content [_] (binding [*above* []] (render! content) (loop [above *above*] (when (seq above) (var-set #'*above* []) (doseq [f above] (f)) (recur *above*))))))