;;
;; Copyright 2010-2014 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 indyvon.views
  "Implementations of the View protocol."
  (:use
   (indyvon core async))
  (:import
   (java.awt Font Image Toolkit)
   java.awt.image.ImageObserver
   (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)))

(defmacro decorate-view
  "Decorate the view replacing render! implementation."
  [view & render-tail]
  `(let [view# ~view]
     (reify
       View
       (render! ~@render-tail)
       (geometry [t#] (geometry view#)))))

(defrecord Empty []
  View
  (render! [_])
  (geometry [_]
    (->Size 0 0)))

(def empty-view (->Empty))

(defn padding
  "Adds padding to the content view."
  ([distance content]
     (padding distance distance distance distance content))
  ([top left bottom right content]
     (if (== 0 top left bottom right)
       content
       (reify
        View
        (render! [l]
           (draw! content
                  left top
                  (- *width* left right)
                  (- *height* top bottom)
                  false))
        (geometry [l]
          (->NestedGeometry (geometry content) top left bottom right))))))

(defn border
  "Adds a border to the content view."
  ([content]
     (border 1 content))
  ([thickness content]
     (border thickness 0 content))
  ([thickness gap content]
     (let [view (padding (+ thickness gap) content)
           t (double thickness)]
       (decorate-view view [_]
         (render! view)
         (with-color :border-color
           (let [w (double *width*)
                 h (double *height*)
                 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
  "Adds a shadow to the content view."
  ([content]
     (shadow 1 1 content))
  ([x-offset y-offset content]
     (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
        View
        (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
  "An opaque view using theme's alt-back-color or a custom background
  color."
  ([content]
     (panel :alt-back-color content))
  ([back-color content]
     (decorate-view content [_]
       (with-color back-color
         (.fill *graphics* (Rectangle2D$Double. 0.0 0.0 *width* *height*)))
       (render! content))))

(defn hbox
  "Creates a view that draws the specified content views placing them
   horizontally."
  [& contents]
  (reify
   View
   (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 a view that draws the specified content views placing them
   vertically."
  [& contents]
  (reify
   View
   (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 ^Cache text-layout-cache
  (-> (CacheBuilder/newBuilder)
      (.softValues)
      (.expireAfterAccess (long 1) TimeUnit/SECONDS)
      (.build)))

(defn- get-text-layout
  [^String line ^Font font ^FontRenderContext font-context]
  (.get text-layout-cache [line font font-context]
        #(TextLayout. line font font-context)))

(defn- layout-text
  [lines font 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 view to display multiline text."
  ([text]
     (label :left :top text))
  ([h-align v-align text]
     (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text))]
       (reify View
        (render! [view]
          (let [w *width*
                h *height*
                font (.getFont *graphics*)
                layouts (layout-text lines font (font-context))
                y (align-y v-align (text-height layouts) h)]
            (loop [layouts layouts, y y]
              (when-first [^TextLayout layout layouts]
                (let [ascent (.getAscent layout)
                      lh (+ ascent (.getDescent layout) (.getLeading layout))
                      x (align-x h-align (.getAdvance layout) w)]
                  (.draw layout *graphics* x (+ y ascent))
                  (recur (next layouts) (+ y lh)))))))
        (geometry [view]
          (let [layouts (layout-text lines (:font *theme*) (font-context))
                w (text-width layouts)
                h (text-height layouts)]
            (->Size w h)))))))

(defn- ^ImageObserver image-observer [view]
  (reify
   ImageObserver
   (imageUpdate [this img infoflags x y width height]
     (update view)
     (zero? (bit-and infoflags
                     (bit-or ImageObserver/ALLBITS
                             ImageObserver/ABORT))))))

(defn image-view
  [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
     View
     (render! [view]
       (repaint-on-update view)
       (.drawImage *graphics* image 0 0 (image-observer view)))
     (geometry [view]
       (let [observer (image-observer view)
             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 *miniature-thread-priority* 2)

(defn ref-view
  [view-ref]
  (let [l (reify
           View
           (render! [l]
             (repaint-on-update l)
             (if-let [view @view-ref]
               (render! view)))
           (geometry [_]
             (if-let [view @view-ref]
               (geometry view)
               (->Size 1 1))))]
    (add-watch view-ref l (fn [_ _ _ _] (update l)))
    l))

;;
;; View context decorators
;;

(defmacro add-handlers [view & handlers]
  "Adds event handling to the view."
  `(let [view# ~view]
     (decorate-view view# [t#]
       (with-handlers t#
         (render! view#)
         ~@handlers))))

(defn themed [theme view]
  (reify
    View
    (render! [_]
      (with-theme theme
        (apply-theme)
        (render! view)))
    (geometry [_]
      (with-theme* theme geometry view))))

(defn hinted [hints view]
  (reify
    View
    (render! [_]
      (with-hints* hints render! view))
    (geometry [_]
      (with-hints* hints geometry view))))

;;
;; Measuring time
;;

(def ^:dynamic *interval*)

(defn interval-view
  "Creates a view 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-view 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 5 (label :right :bottom text)))

(defn fps-view
  "Creates a view that draws content and displays the
  frames per second 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-view 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)))))

;;
;; Overlays
;;

(def ^:private ^:dynamic *above*)

(defn- overlay* [f & args]
  (var-set #'*above* (conj *above* (apply partial f args))))

(defn- ^Point2D to-graphics-coords
  [^AffineTransform transform x y]
  (let [p (Point2D$Double. x y)]
    (.transform transform p p)
    (.transform (.createInverse (.getTransform *graphics*)) p p)
    p))

(defn- draw-relative!
  ([view transform x y]
     (let [p (to-graphics-coords transform x y)]
       (draw! view (.getX p) (.getY p))))
  ([view transform x y w h]
     (let [p (to-graphics-coords transform x y)]
       (draw! view (.getX p) (.getY p) w h))))

(defn- draw-relative-aligned!
  [view transform h-align v-align x y]
  (let [geom (geometry view)
        w (width geom)
        h (height geom)
        p (to-graphics-coords transform x y)
        x (- (.getX p) (anchor-x geom h-align w))
        y (- (.getY p) (anchor-y geom v-align h))]
    (draw! view x y w h)))

(defn overlay!
  "Draws view in the overlay context above the other views."
  ([view]
     (overlay* draw-relative! view (.getTransform *graphics*) 0 0))
  ([view x y]
     (overlay* draw-relative! view (.getTransform *graphics*) x y))
  ([view x y w h]
     (overlay* draw-relative! view (.getTransform *graphics*) x y w h)))

(defn overlay-aligned! [view h-align v-align x y]
  (overlay* draw-relative-aligned!
            view
            (.getTransform *graphics*)
            h-align v-align
            x y))

(defn with-overlays* [recursive? f & args]
  (binding [*above* []]
    (apply f args)
    (if recursive?
      (loop [above *above*]
        (when (seq above)
          (var-set #'*above* [])
          (doseq [of above]
            (of))
          (recur *above*)))
      (doseq [of *above*]
        (of)))))

(defmacro with-overlays [recursive? & body]
  `(with-overlays* ~recursive? (fn [] ~@body)))

(defn layered
  ([content]
     (layered true content))
  ([recursive? content]
     (decorate-view content [_]
       (with-overlays* recursive? render! content))))