view src/net/kryshen/indyvon/core.clj @ 50:409b1b16053d

Code cleanup and docstrings.
author Mikhail Kryshen <mikhail@kryshen.net>
date Thu, 29 Jul 2010 01:28:30 +0400
parents ca728127d605
children a20b1fccc0ef
line wrap: on
line source

;;
;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net>
;;
;; This file is part of Indyvon.
;;

(ns net.kryshen.indyvon.core
  (:import
   (java.awt Graphics2D Component Color Font AWTEvent)
   (java.awt.event MouseListener MouseMotionListener)
   (java.awt.font FontRenderContext)))

(def ^Graphics2D *graphics*)
(def ^FontRenderContext *font-context*)
(def ^Component *target*)
(def *bounds*)
(def *clip*)
(def *update*)
(def *event-dispatcher*)

(defrecord Theme [fore-color back-color alt-back-color border-color font])

(defn default-theme []
  (Theme. Color/BLACK Color/LIGHT_GRAY Color/WHITE
          Color/BLUE (Font. "Sans" Font/PLAIN 12)))

(def *theme* (default-theme))

(defrecord Location [x y])
(defrecord Size [width height])
(defrecord Bounds [x y width height])

(defprotocol Layer
  "Basic UI element."
  (render! [this])
  (layer-size [this]))

;; TODO: modifiers
(defrecord MouseEvent [id when x y x-on-screen y-on-screen button])

(defprotocol EventDispatcher
  (listen! [this ^Component component]
     "Listen for events on the specified AWT Component.")
  (create-dispatcher [this handle handlers]
     "Returns new event dispatcher associated with the specified event
      handlers (an event-id -> handler-fn map). Handle is used to
      match the contexts between commits.")
  (commit [this]
     "Apply the registered handlers for event processing."))

(defprotocol Anchored
  "Provide anchor point for Layers. Used by viewport."
  (anchor [this h-align v-align]
     "Anchor point: [x y], h-align could be :left, :center or :right,
      v-align is :top, :center or :bottom"))

;; Default implementation of Anchored for any Layer.
(extend-protocol Anchored
  net.kryshen.indyvon.core.Layer
  (anchor [this h-align v-align]
     (if (and (= h-align :left)
              (= v-align :top))
       (Location. 0 0)
       (let [size (layer-size this)]
         (Location.
          (case h-align
            :top 0
            :center (/ (:width size) 2)
            :right (:width size))
          (case v-align
            :left 0
            :center (/ (:height size) 2)
            :bottom (:height size)))))))

(defn- ^Graphics2D make-graphics [^Graphics2D graphics x y w h]
  (.create graphics x y w h))

(defn- ^Graphics2D apply-theme [^Graphics2D graphics theme]
  (doto graphics
    (.setColor (:fore-color theme))
    (.setFont (:font theme))))

(defn intersect
  "Compute intersection between a pair of rectangles (Bounds)."
  ([b1 b2]
     (let [x1 (:x b1)
           y1 (:y b1)
           x2 (:x b2)
           y2 (:y b2)]
       (intersect x1 y1 (+ x1 (:width b1)) (+ y1 (:height b1))
                  x2 y2 (+ x2 (:width b2)) (+ y2 (:height b2)))))
  ([x11 y11 x12 y12, x21 y21 x22 y22]
     (let [x1 (max x11 x21)
           y1 (max y11 y21)
           x2 (min x12 x22)
           y2 (min y12 y22)]
       (Bounds. x1 y1 (- x2 x1) (- y2 y1)))))

(defn ^Graphics2D create-graphics
  ([]
     (create-graphics 0 0 (:width *bounds*) (:height *bounds*)))
  ([x y w h]
     (apply-theme (.create *graphics* x y w h) *theme*)))

(defmacro with-bounds [x y w h & body]
  `(let [bounds# (Bounds. (+ ~x (:x *bounds*))
                          (+ ~y (:y *bounds*))
                          ~w ~h)
         clip# (intersect bounds# *clip*)]
     (when (and (pos? (:width clip#)) (pos? (:height clip#)))
       (let [graphics# (create-graphics ~x ~y ~w ~h)]
         (try
           (binding [*bounds* bounds#
                     *clip* clip#
                     *graphics* graphics#]
             ~@body)
           (finally
            (.dispose graphics#)))))))

(defmacro with-handlers* [handle handlers & body]
  `(binding
       [*event-dispatcher*
        (create-dispatcher *event-dispatcher* ~handle ~handlers)]
     ~@body))

(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)
     ~form))

(defn with-theme* [theme f & args]
  (apply with-bindings* {#'*theme* (merge *theme* theme)}
         f args))

(defmacro with-theme [theme & body]
  `(binding [*theme* (merge *theme* ~theme)]
     ~@body))

(defmacro with-color [color & body]
  `(let [color# (.getColor *graphics*)]
     (try
       (.setColor *graphics* ~color)
       ~@body
       (finally
        (.setColor *graphics* color#)))))

(defn- geometry-vec [geometry]
  (if (vector? geometry)
    geometry
    [(:x geometry) (:y geometry) (:width geometry) (:height geometry)]))

(defn draw!
  ([layer]
     (let [graphics (create-graphics)]
       (try
         (binding [*graphics* graphics]
           (render! layer))
         (finally
          (.dispose graphics)))))
  ([layer x y]
     (let [size (layer-size layer)]
       (draw! layer x y (:width size) (:height size))))
  ([layer x y width height]
     (with-bounds x y width height
       (render! layer))))

(defn draw-anchored!
  "Draw with location relative to the anchor point."
  ([layer h-align v-align x y]
     (let [anchor (anchor layer h-align v-align)]
       (draw! layer (- x (:x anchor)) (- y (:y anchor)))))
  ([layer h-align v-align x y w h]
     (let [anchor (anchor layer h-align v-align)]
       (draw! layer (- x (:x anchor)) (- y (:y anchor)) w h))))

;;
;; EventDispatcher implementation
;;

(def awt-events
     {java.awt.event.MouseEvent/MOUSE_CLICKED  :mouse-clicked
      java.awt.event.MouseEvent/MOUSE_DRAGGED  :mouse-dragged
      java.awt.event.MouseEvent/MOUSE_ENTERED  :mouse-entered
      java.awt.event.MouseEvent/MOUSE_EXITED   :mouse-exited
      java.awt.event.MouseEvent/MOUSE_MOVED    :mouse-moved
      java.awt.event.MouseEvent/MOUSE_PRESSED  :mouse-pressed
      java.awt.event.MouseEvent/MOUSE_RELEASED :mouse-released})

(defrecord DispatcherNode [handle handlers parent bounds bindings]
  EventDispatcher
  (listen! [this component]
     (listen! parent component))
  (create-dispatcher [this handle handlers]
     (create-dispatcher parent handle handlers))
  (commit [this]
     (commit parent)))

(defn- make-node [handle handlers]
  (DispatcherNode. handle handlers *event-dispatcher* *clip*
                   (get-thread-bindings)))

(defn- assoc-cons [m key val]
  (assoc m key (cons val (get m key))))

(defn- add-node [tree node]
  (assoc-cons tree (:parent node) node))

(defn- inside?
  ([x y bounds]
     (inside? x y (:x bounds) (:y bounds)
              (:width bounds) (:height bounds)))
  ([px py x y w h]
     (and (>= px x)
          (>= py y)
          (< px (+ x w))
          (< py (+ y h)))))

(defn- under-cursor
  "Returns a vector of child nodes under cursor."
  [x y tree node]
  (some #(if (inside? x y (:bounds %))
           (conj (vec (under-cursor x y tree %)) %))
        (get tree node)))

(defn- remove-all [coll1 coll2 pred]
  (filter #(not (some (partial pred %) coll2)) coll1))

(defn- translate-mouse-event [^java.awt.event.MouseEvent event x y id]
  (MouseEvent. id (.getWhen event)
               (- (.getX event) x) (- (.getY event) y)
               (.getXOnScreen event) (.getYOnScreen event)
               (.getButton event)))

(defn- translate-and-dispatch
  ([nodes first-only ^java.awt.event.MouseEvent event]
     (translate-and-dispatch nodes first-only
       event (awt-events (.getID event))))
  ([nodes first-only event id]
     (if-let [node (first nodes)]
       (if-let [handler (get (:handlers node) id)]
         (do
           (with-bindings* (:bindings node)
             handler
             (translate-mouse-event event
               (-> node :bounds :x) (-> node :bounds :y) id))
           (if-not first-only
             (recur (rest nodes) false event id)))
         (recur (rest nodes) first-only event id)))))

(defn- dispatch-mouse-motion
  "Dispatches mouse motion events."
  [hovered-ref tree root ^java.awt.event.MouseEvent event]
  (let [x (.getX event)
        y (.getY event)
        [hovered hovered2] (dosync
                            [@hovered-ref
                             (ref-set hovered-ref
                                      (under-cursor x y tree root))])
        pred #(= (:handle %1) (:handle %2))
        exited (remove-all hovered hovered2 pred)
        entered (remove-all hovered2 hovered pred)
        moved (remove-all hovered2 entered pred)]
    (translate-and-dispatch exited false event :mouse-exited)
    (translate-and-dispatch entered false event :mouse-entered)
    (translate-and-dispatch moved true event :mouse-moved)))

(defn- dispatch-mouse-button
  [picked-ref hovered-ref ^java.awt.event.MouseEvent event]
  (let [id (awt-events (.getID event))
        hovered (if (= id :mouse-pressed)
                  (dosync (ref-set picked-ref @hovered-ref))
                  @hovered-ref)]
    (translate-and-dispatch hovered true event id)))

(defn root-event-dispatcher []
  (let [tree-r (ref {})   ; register
        tree (ref {})     ; dispatch
        hovered (ref '())
        picked (ref '())]
    (reify
     EventDispatcher
     (listen! [this component]
        (doto component
          (.addMouseListener this)
          (.addMouseMotionListener this)))
     (create-dispatcher [this handle handlers]
        (let [node (make-node handle handlers)]
          (dosync (alter tree-r add-node node))
          node))
     (commit [this]
        (dosync (ref-set tree @tree-r)
                (ref-set tree-r {})))
     MouseListener
     (mouseEntered [this event]
        (dispatch-mouse-motion hovered @tree this event))
     (mouseExited [this event]
        (dispatch-mouse-motion hovered @tree this event))
     (mouseClicked [this event]
        (dispatch-mouse-button picked hovered event))
     (mousePressed [this event]
        (dispatch-mouse-button picked hovered event))
     (mouseReleased [this event]
        (translate-and-dispatch @picked true event))
        ;;(dispatch-mouse-button picked hovered event))
     MouseMotionListener
     (mouseDragged [this event]
        (translate-and-dispatch @picked true event))
     (mouseMoved [this event]
        (dispatch-mouse-motion hovered @tree this event)))))

;;
;; ИДЕИ:
;;
;; Контекст: биндинги или запись?
;;
;; Установка обработчиков (в контексте слоя):
;;
;; (listen
;;   (:mouse-entered e
;;     ...)
;;   (:mouse-exited e
;;     ...))
;;
;; Не надо IMGUI.
;; Построение сцены путем декорирования слоев:
;;
;; (listener
;;  (:action e (println e))
;;  (:mouse-dragged e (println e))
;;  (theme :font "Helvetica-14"
;;    (vbox
;;      (button (text-layer "Button 1"))
;;      (button (text-layer "Button 2")))))
;;