Mercurial > hg > indyvon
view src/indyvon/core.clj @ 25:07ee065cbb3e
Avoid some code repetition by using macros.
author | Mikhail Kryshen <mikhail@kryshen.net> |
---|---|
date | Mon, 21 Jun 2010 01:18:50 +0400 |
parents | c17e3588ede9 |
children | 1237f7555029 |
line wrap: on
line source
;; ;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net> ;; ;; This file is part of Indyvon. ;; (ns indyvon.core (:import (java.awt Color Font Cursor) (java.awt.font FontRenderContext TextLayout) (java.awt.event MouseEvent))) (defprotocol Layer "Basic UI element." (render! [this context graphics]) (size [this context])) (defprotocol MouseHandler "Layers that also satisfy this protocol will recieve mouse events." (handle-mouse [this context event])) (defprotocol EventDispatcher (listen! [this component]) (register [this context]) (commit [this]) (hovered? [this layer]) (picked? [this layer])) (defrecord Theme [fore-color back-color border-color font]) (defn default-theme [] (Theme. Color/BLACK Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12))) (defrecord LayerContext [layer parent x y width height update-fn dispatcher font-context theme target]) (defn default-context [] (LayerContext. nil nil 0 0 0 0 nil nil nil (default-theme) nil)) (defn update [context] ((:update-fn context))) (defn- make-graphics [graphics x y w h clip] (if clip (.create graphics x y w h) (doto (.create graphics) (.translate x y)))) (defn- apply-theme [graphics theme] (doto graphics (.setColor (:fore-color theme)) (.setFont (:font theme)))) (defn draw! "Render layer in a new graphics context." ([layer context graphics] (draw! layer context graphics 0 0 (:width context) (:height context))) ([layer context graphics x y] (draw! layer context graphics x y true)) ([layer context graphics x y clip] (let [s (size layer context)] (draw! layer context graphics x y (s 0) (s 1) clip))) ([layer context graphics x y w h] (draw! layer context graphics x y w h true)) ([layer context graphics x y w h clip] (let [context (assoc context :layer layer :parent context :x (+ (:x context) x) :y (+ (:y context) y) :width w :height h) graphics (make-graphics graphics x y w h clip) graphics (apply-theme graphics (:theme context))] (try (register (:dispatcher context) context) (render! layer context graphics) (finally (.dispose graphics)))))) ;; ;; Layer implementations. ;; (defn border-layer "Decorate layer with a border." ([content] (border-layer content 1)) ([content width] (border-layer content width 0)) ([content width gap] (let [offset (+ width gap)] (reify Layer (render! [l c g] (let [w (:width c) h (:height c)] (.setColor g (-> c :theme :border-color)) (doseq [i (range 0 width)] (.drawRect g i i (- w 1 i i) (- h 1 i i))) (draw! content c g offset offset (- w offset offset) (- h offset offset)))) (size [l c] (let [s (size content c)] [(+ (s 0) offset offset) (+ (s 1) offset offset)])))))) ;; 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)) (defn- re-split [re s] (seq (.split re s))) (defn- layout-text [lines font font-context] (map #(TextLayout. % font font-context) lines)) (defn- text-width [layouts] (reduce #(max %1 (.getAdvance %2)) 0 layouts)) (defn- text-height [layouts] (reduce #(+ %1 (.getAscent %2) (.getDescent %2) (.getLeading %2)) 0 layouts)) (defn text-layer "Creates a layer to display multiline text." ([text] (text-layer text :left :top)) ([text h-align v-align] (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" text)] (reify Layer (render! [l c g] (let [w (:width c) h (:height c) font (.getFont g) font-context (:font-context c) layouts (layout-text lines font font-context) y (align-y (text-height layouts) h v-align)] (loop [layouts layouts, y y] (when-first [layout layouts] (let [ascent (.getAscent layout) lh (+ ascent (.getDescent layout) (.getLeading layout)) x (align-x (.getAdvance layout) w h-align)] (.draw layout g x (+ y ascent)) (recur (next layouts) (+ y lh))))))) (size [l c] (let [layouts (layout-text lines (-> c :theme :font) (:font-context c)) width (text-width layouts) height (text-height layouts)] [width height])))))) (defprotocol Anchored "Provide anchor point for Layers. Used by viewport." (anchor [this context] "Anchor point: [x y]")) ;; Default implementation of Anchored for any Layer. (extend-protocol Anchored indyvon.core.Layer (anchor [this context] [0 0])) (defn viewport "Creates scrollable viewport layer." ([content] (viewport content :left :top)) ([content h-align v-align] (let [x (ref 0) y (ref 0) fix-x (ref 0) fix-y (ref 0) last-width (ref 0) last-height (ref 0)] (reify Layer (render! [layer c g] (let [anchor (anchor content c) width (:width c) height (:height c)] (dosync (alter x + (align-x width @last-width h-align)) (alter y + (align-y height @last-height v-align)) (ref-set last-width width) (ref-set last-height height)) (draw! content c g (- 0 @x (anchor 0)) (- 0 @y (anchor 1))))) (size [layer c] (size content c)) MouseHandler (handle-mouse [layer c e] (when (= (.getID e) MouseEvent/MOUSE_PRESSED) (dosync (ref-set fix-x (.getXOnScreen e)) (ref-set fix-y (.getYOnScreen e))) (->> Cursor/MOVE_CURSOR Cursor. (.setCursor (:target c)))) (when (= (.getID e) MouseEvent/MOUSE_RELEASED) (->> Cursor/DEFAULT_CURSOR Cursor. (.setCursor (:target c)))) (when (= (.getID e) MouseEvent/MOUSE_DRAGGED) (dosync (alter x + (- @fix-x (.getXOnScreen e))) (alter y + (- @fix-y (.getYOnScreen e))) (ref-set fix-x (.getXOnScreen e)) (ref-set fix-y (.getYOnScreen e))) (update c)))))))