;;
;; 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*))))))