drag.cljs

(ns drag.core
  (:use [jayq.core :only [$ bind]]
        [cljs.core.async :only [chan put! <!]])
  (:require-macros [cljs.core.async.macros :refer [go]]))

(defn create-canvas
  [& {:keys [width height]}]
  (let [canvas ($ "<canvas>")
        context (-> canvas (aget 0) (.getContext "2d"))]
    (doto canvas
      (.width width)
      (.height height))
    (set! (.-width (.-canvas context)) width)
    (set! (.-height (.-canvas context)) height)
    (.append ($ "body") canvas)
    {:el canvas
     :context context
     :width width
     :height height}))

(defn draw-rect
  [{:keys [context]} & {:keys [x y width height color]}]
  (doto context
    .beginPath
    (#(set! (.-fillStyle %) color))
    (.fillRect x y width height)))

(defn clear
  [{:keys [width height] :as canvas}]
  (draw-rect canvas :x 0 :y 0 :width width :height height :color "white"))

(defn draw-box
  [canvas {:keys [x y width height]}]
  (clear canvas)
  (draw-rect canvas
             :x (- x (/ width 2))
             :y (- y (/ height 2))
             :width width
             :height height
             :color "red"))

(defn start-rendering
  [canvas box-ref]
  (add-watch box-ref nil (fn [_ _ _ box] (draw-box canvas box)))
  (draw-box canvas @box-ref))

(defn relative-pos
  [e el]
  {:x (- (.-pageX e) (-> el .parent .offset .-left))
   :y (- (.-pageY e) (-> el .parent .offset .-top))})

(defn watch-mouse-events
  [el]
  (let [channel (chan)
        push-mouse-event (fn [event-type]
                           #(put! channel
                                  [event-type (relative-pos % el)]))]
    (doto el
      (bind "mousemove" (push-mouse-event :mouse-move))
      (bind "mousedown" (push-mouse-event :mouse-down))
      (bind "mouseup" (push-mouse-event :mouse-up)))
    channel))

(defn in-box?
  [{some-x :x some-y :y} {:keys [x y width height]}]
  (and
    (>= some-x (- x (/ width 2)))
    (<= some-x (+ x (/ width 2)))
    (>= some-y (- y (/ height 2)))
    (<= some-y (+ y (/ height 2)))))

(defn set-pos
  [box pos]
  (merge box pos))

(defn drag-box
  [box mouse-events]
  (go (loop [[event-type pos] (<! mouse-events)]
        (swap! box set-pos pos)
        (when-not (= :mouse-up event-type)
          (recur (<! mouse-events))))))

(defn watch-for-dragging
  [box mouse-events]
  (go (loop [[event-type pos] (<! mouse-events)]
        (when (and (= :mouse-down event-type)
                   (in-box? pos @box))
          (<! (drag-box box mouse-events)))
        (recur (<! mouse-events)))))

(defn run
  []
  (let [box (atom {:x 0 :y 0 :width 50 :height 50})
        canvas (create-canvas :width 640 :height 480)
        mouse-events (watch-mouse-events (:el canvas))]
    (start-rendering canvas box)
    (watch-for-dragging box mouse-events)))

($ run)