Mercurial > hg > indyvon
changeset 139:173616375eb5
Refactoring. Moved viewport functions into separate namespace.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Mon, 07 Jan 2013 19:52:23 +0400 |
| parents | e3eeb1478df1 |
| children | 4dd98ea3b475 |
| files | src/net/kryshen/indyvon/demo.clj src/net/kryshen/indyvon/layers.clj src/net/kryshen/indyvon/viewport.clj |
| diffstat | 3 files changed, 270 insertions(+), 222 deletions(-) [+] |
line wrap: on
line diff
--- a/src/net/kryshen/indyvon/demo.clj Mon Jan 07 19:51:21 2013 +0400 +++ b/src/net/kryshen/indyvon/demo.clj Mon Jan 07 19:52:23 2013 +0400 @@ -1,5 +1,5 @@ ;; -;; Copyright 2010, 2011 Mikhail Kryshen <mikhail@kryshen.net> +;; Copyright 2010, 2011, 2012 Mikhail Kryshen <mikhail@kryshen.net> ;; ;; This file is part of Indyvon. ;; @@ -21,7 +21,7 @@ "Indyvon demo and experiments." (:gen-class) (:use - (net.kryshen.indyvon core layers component)) + (net.kryshen.indyvon core layers viewport component)) (:import (java.awt Color) (javax.swing JFrame)))
--- a/src/net/kryshen/indyvon/layers.clj Mon Jan 07 19:51:21 2013 +0400 +++ b/src/net/kryshen/indyvon/layers.clj Mon Jan 07 19:52:23 2013 +0400 @@ -22,11 +22,10 @@ (:use (net.kryshen.indyvon core async)) (:import - (java.lang.ref SoftReference) - (java.awt Font Cursor Image Toolkit Point) + (java.awt Font Image Toolkit) java.awt.image.ImageObserver - (java.awt.geom AffineTransform Rectangle2D$Double Point2D$Double - Path2D Path2D$Double) + (java.awt.geom Area AffineTransform Rectangle2D$Double Point2D + Point2D$Double) (java.awt.font FontRenderContext TextLayout) java.util.concurrent.TimeUnit (com.google.common.cache Cache CacheBuilder CacheLoader))) @@ -94,12 +93,10 @@ (with-color :border-color (let [w (double *width*) h (double *height*) - outer (Rectangle2D$Double. 0.0 0.0 w h) - inner (Rectangle2D$Double. t t (- w t t) (- h t t))] - (.fill *graphics* - (doto (Path2D$Double. Path2D/WIND_EVEN_ODD) - (.append outer false) - (.append inner false))))))))) + 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))))))) ;; TODO: opacity and blur. (defn shadow @@ -261,196 +258,6 @@ (def ^:dynamic *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 *viewport-scaling-step* (double 3/4)) -(def ^:dynamic *viewport-min-scale* 1E-6) -(def ^:dynamic *viewport-max-scale* 1E6) - -(declare scale-viewport) - -(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))) - (set-cursor! (Cursor. Cursor/MOVE_CURSOR))) - (:mouse-released e - (set-cursor! (Cursor. Cursor/DEFAULT_CURSOR))) - (: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 - (scale-viewport - layer - (Math/pow *viewport-scaling-step* (:wheel-rotation e)) - true (:x e) (:y e))))) - (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 scale-viewport - ([viewport s] - (scale-viewport viewport s true)) - ([viewport s relative?] - (scale-viewport viewport s relative? nil nil)) - ([viewport s relative? x y] - (dosync - (let [^AffineTransform tr @(:transform viewport) - sx (if relative? s (/ s (.getScaleX tr))) - sy (if relative? s (/ s (.getScaleY tr))) - x (or x (align-x 0 @(:last-width viewport) (:h-align viewport))) - y (or y (align-y 0 @(:last-height viewport) (:v-align viewport))) - x (- x (* x sx)) - y (- y (* y sy)) - scaled (doto (AffineTransform/getTranslateInstance x y) - (.scale sx sy) - (.concatenate tr)) - sx (.getScaleX scaled) - sy (.getScaleY scaled)] - (if (<= *viewport-min-scale* - (min sx sy) - (max sx sy) - *viewport-max-scale*) - (ref-set (:transform viewport) scaled)))) - (update viewport))) - -(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 @@ -552,9 +359,9 @@ (defn- overlay* [f & args] (var-set #'*above* (conj *above* (apply partial f args)))) -(defn- ^Point to-graphics-coords +(defn- ^Point2D to-graphics-coords [^AffineTransform transform x y] - (let [p (Point. x y)] + (let [p (Point2D$Double. x y)] (.transform transform p p) (.transform (.createInverse (.getTransform *graphics*)) p p) p)) @@ -562,10 +369,10 @@ (defn- draw-relative! ([layer transform x y] (let [p (to-graphics-coords transform x y)] - (draw! layer (.x p) (.y p)))) + (draw! layer (.getX p) (.getY p)))) ([layer transform x y w h] (let [p (to-graphics-coords transform x y)] - (draw! layer (.x p) (.y p) w h)))) + (draw! layer (.getX p) (.getY p) w h)))) (defn- draw-relative-aligned! [layer transform h-align v-align x y] @@ -573,8 +380,8 @@ 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))] + x (- (.getX p) (anchor-x geom h-align w)) + y (- (.getY p) (anchor-y geom v-align h))] (draw! layer x y w h))) (defn overlay! @@ -591,22 +398,25 @@ 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) +(defn with-overlays* [rec? f & args] + (binding [*above* []] + (apply f args) + (if rec? (loop [above *above*] (when (seq above) (var-set #'*above* []) (doseq [f above] (f)) - (recur *above*)))))) + (recur *above*))) + (doseq [of *above*] + (of))))) + +(defmacro with-overlays [rec? & body] + `(with-overlays* ~rec? (fn [] ~@body))) + +(defn overlayer + ([content] + (overlayer content true)) + ([content rec?] + (decorate-layer content [_] + (with-overlays* rec? render! content))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/net/kryshen/indyvon/viewport.clj Mon Jan 07 19:52:23 2013 +0400 @@ -0,0 +1,238 @@ +;; +;; Copyright 2010, 2011, 2012 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.viewport + "Scrollable viewport and miniature." + (:use + (net.kryshen.indyvon core async layers)) + (:import + java.awt.Cursor + java.awt.geom.AffineTransform)) + +;;(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 *viewport-scaling-step* (double 3/4)) +(def ^:dynamic *viewport-min-scale* 1E-6) +(def ^:dynamic *viewport-max-scale* 1E6) + +(def ^:dynamic *viewport* nil) +(def ^:dynamic ^AffineTransform *viewport-transform*) + +(declare scale-viewport!) + +(defrecord ViewportState [transform + fix-x fix-y + last-width last-height + last-anchor-x last-anchor-y]) + +(defn- update-viewport [state content-geom h-align v-align] + (let [w *width* + h *height* + cw (width content-geom) + ch (height content-geom) + ax (anchor-x content-geom h-align cw) + ay (anchor-y content-geom v-align ch) + ax1 (align-x (:last-width state) w h-align) + ay1 (align-y (:last-height state) h v-align) + ax2 (- (:last-anchor-x state) ax) + ay2 (- (:last-anchor-y state) ay) + transform (:transform state) + transform (if (and (zero? ax1) (zero? ay1) + (zero? ax2) (zero? ay2)) + transform + (doto + (AffineTransform/getTranslateInstance ax1 ay1) + (.concatenate transform) + (.translate ax2 ay2)))] + (assoc state + :last-width w + :last-height h + :last-anchor-x ax + :last-anchor-y ay + :transform transform))) + +(defrecord Viewport [content h-align v-align state] + Layer + (render! [layer] + (repaint-on-update layer) + (with-handlers layer + (let [geom (geometry content) + new-state (swap! state update-viewport geom h-align v-align) + transform (:transform new-state)] + ;; TODO: notify observers when size changes. + (binding [*viewport* layer + *viewport-transform* transform] + (with-transform transform + (draw! content 0 0 (width geom) (height geom) false)))) + (:mouse-pressed e + (swap! state assoc + :fix-x (:x-on-screen e) + :fix-y (:y-on-screen e)) + (set-cursor! (Cursor. Cursor/MOVE_CURSOR))) + (:mouse-released e + (set-cursor! (Cursor. Cursor/DEFAULT_CURSOR))) + (:mouse-dragged e + (swap! state + (fn [s] + (assoc s + :transform (pre-translate + (:transform s) + (- (:x-on-screen e) (:fix-x s)) + (- (:y-on-screen e) (:fix-y s))) + :fix-x (:x-on-screen e) + :fix-y (:y-on-screen e)))) + (update layer)) + (:mouse-wheel e + (scale-viewport! + layer + (Math/pow *viewport-scaling-step* (:wheel-rotation e)) + true (:x e) (:y e))))) + (geometry [_] + (geometry content))) + +(def ^:private viewport-initial-state + (->ViewportState + (AffineTransform.) ; transform + 0 0 ; fix-x fix-y + 0 0 ; last-width last-height + 0 0)) + +(defn viewport + "Creates scrollable viewport layer." + ([content] + (viewport content :left :top)) + ([content h-align v-align] + (->Viewport content h-align v-align (atom viewport-initial-state)))) + +(defn- scale-viewport [state vp s relative? x y] + (let [^AffineTransform tr (:transform state) + sx (if relative? s (/ s (.getScaleX tr))) + sy (if relative? s (/ s (.getScaleY tr))) + x (or x (align-x 0 (:last-width state) (:h-align vp))) + y (or y (align-y 0 (:last-height state) (:v-align vp))) + x (- x (* x sx)) + y (- y (* y sy)) + scaled (doto (AffineTransform/getTranslateInstance x y) + (.scale sx sy) + (.concatenate tr)) + sx (.getScaleX scaled) + sy (.getScaleY scaled)] + (if (<= *viewport-min-scale* + (min sx sy) + (max sx sy) + *viewport-max-scale*) + (assoc state + :transform scaled) + state))) + +(defn scale-viewport! + ([viewport s] + (scale-viewport! viewport s true)) + ([viewport s relative?] + (scale-viewport! viewport s relative? nil nil)) + ([viewport s relative? x y] + (swap! (:state viewport) scale-viewport viewport s relative? x y) + (update viewport))) + +(defn reset-viewport! [viewport] + (reset! (:state viewport) viewport-initial-state) + (update viewport)) + +(defn ^AffineTransform viewport-transform [viewport] + (:transform @(:state viewport))) + +(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 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-state @(:state viewport) + {:keys [transform last-width last-height]} @(:state viewport) + ox (align-x (width geom) (/ m-width s) :center) + oy (align-y (height geom) (/ m-height s) :center) + 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) + (update 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)))))))