;;
;; Copyright 2010-2017 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 Rectangle2D$Double
                  Point2D Point2D$Double)
   (java.awt.font FontRenderContext TextLayout)
   java.util.concurrent.TimeUnit
   (com.google.common.cache Cache CacheBuilder CacheLoader)))

(defrecord Decorator [render-fn geometry-fn content]
  View
  (render! [decorator]
    (render-fn decorator content))
  (geometry [decorator]
    (geometry-fn decorator content)))

(defn- decorator-content-geometry [_ content]
  (geometry content))

(defn decorator
  "Creates a decorator view. Functions render-fn and geometry-fn will
  be called with the decorator and content as arguments. Use this in
  preference to (reify View) as it creates a defrecord instance
  instead of an opaque reify object. Prefer to pass render-fn and
  geometry-fn as Vars to allow the view to be printed and read back."
  ([render-fn content]
   (decorator render-fn #'decorator-content-geometry content))
  ([render-fn geometry-fn content]
   (->Decorator render-fn geometry-fn content)))

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

(def empty-view (->Empty))

(defrecord Padding [top left bottom right content]
  View
  (render! [l]
    (draw! content
           left top
           (- *width* left right)
           (- *height* top bottom)
           false))
  (geometry [l]
    (->NestedGeometry (geometry content) top left bottom right)))

(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
     (->Padding top left bottom right content))))

(defrecord Border [^double thickness content]
  View
  (render! [_]
    (render! content)
    (with-color :border-color
      (let [w (double *width*)
            h (double *height*)
            t thickness
            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))))
  (geometry [_] (geometry content)))

(defn border
  "Adds a border to the content view."
  ([content]
     (border 1 content))
  ([thickness content]
     (border thickness 0 content))
  ([thickness gap content]
   (->Border thickness (padding (+ thickness gap) content))))

;; TODO: opacity and blur.
(defrecord Shadow [^double x ^double y content]
  View
  (render! [_]
    (let [w (- *width* (Math/abs x))
          h (- *height* (Math/abs y))]
      (with-color :shadow-color
        (.fillRect *graphics* (max x 0.0) (max y 0.0) w h))
      (draw! content (max (- x) 0.0) (max (- y) 0.0) w h)))
  (geometry [_]
    (->NestedGeometry (geometry content)
                      (max (- y) 0.0) ;; top
                      (max (- x) 0.0) ;; left
                      (max y 0.0)     ;; bottom
                      (max x 0.0))))  ;; right
(defn shadow
  "Adds a shadow to the content view."
  ([content]
   (shadow 1 1 content))
  ([x-offset y-offset content]
   (->Shadow x-offset y-offset content)))

(defrecord Panel [back-color content]
  View
  (render! [_]
    (with-color back-color
      (.fill *graphics* (Rectangle2D$Double. 0.0 0.0 *width* *height*)))
    (render! content))
  (geometry [_] (geometry content)))

(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]
   (->Panel back-color content)))

(defrecord Box [proportional? translate-geometry contents]
  View
  (render! [_]
    (let [context-size (translate-geometry (->Size *width* *height*))
          dimxs (map (comp width translate-geometry geometry) contents)
          xs (cons 0 (reductions + dimxs))
          dimxs-sum (last xs)
          scale (if proportional? (/ (width context-size) dimxs-sum) 1)]
      (doseq [[c w x] (map vector contents dimxs xs)]
        (draw-aligned! c
                       (translate-geometry
                        (->FixedGeometry (- (* scale x)) 0
                                         (* scale w) (height context-size)))
                       :left :top
                       0 0))))
  (geometry [_]
    (translate-geometry
     (reduce #(->Size (+ (width %1) (width %2))
                      (max (height %1) (height %2)))
             (->Size 0 0)
             (map (comp translate-geometry geometry) contents)))))

(defn- hbox* [proportional? contents]
  (->Box proportional? #'identity contents))

(defn- vbox* [proportional? contents]
  (->Box proportional? #'->TransposedGeometry contents))

(defn hbox
  "Creates a view that draws the specified content views placing them
  horizontally."
  [& contents]
  (hbox* false contents))

(defn hbox-proportional
  "Like hbox, but proportionally distributes the available space."
  [& contents]
  (hbox* true contents))

(defn vbox
  "Creates a view that draws the specified content views placing them
  horizontally."
  [& contents]
  (vbox* false contents))

(defn vbox-proportional
  "Like vbox, but proportionally distributes the available space."
  [& contents]
  (vbox* true contents))

(defrecord BorderBox [north west south east center
                      ^boolean center-anchor?]
  View
  (render! [_]
    (let [w *width*
          h *height*
          t (height (geometry north) w)
          b (height (geometry south) w)
          ch (- h t b)
          l (width (geometry west) ch)
          r (width (geometry east) ch)
          cw (- w l r)]
      (draw! north 0 0 w t)
      (draw! west 0 t l ch)
      (draw! south 0 (- h b) w b)
      (draw! east (- w r) t r ch)
      (draw! center l t cw ch)))
  (geometry [_]
    (let [ng (geometry north)
          wg (geometry west)
          sg (geometry south)
          eg (geometry east)
          cg (geometry center)
          cw0 (width cg)
          ch0 (height cg)
          ch (max ch0 (height wg) (height eg))
          l (width wg ch)
          r (width eg ch)
          w (max (+ cw0 l r) (width ng) (width sg))
          t (height ng w)
          b (height sg w)
          h (+ ch t b)]
      (if center-anchor?
        (->NestedGeometry cg t l (- h ch0 t) (- w cw0 l))
        (->Size w h)))))

(defn border-box
  "reginonviews => region-key view
  Returns a View that organizes specified Views in five
  regions (:north, :south, :east, :west, and
  :center). Each region may contain no more than one View."
  [& regionviews]
  (let [opts (apply array-map regionviews)]
    (->BorderBox (:north opts empty-view)
                 (:west opts empty-view)
                 (:south opts empty-view)
                 (:east opts empty-view)
                 (:center opts empty-view)
                 (:center-anchor? opts false))))

(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]
  ;; XXX: TextLayout fails on empty strings, use zero-width space as a
  ;; workaround.
  (let [line (if (.isEmpty line) "\u200b" line)]
    (.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))

(defrecord Label [h-align v-align lines]
  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 (theme-get :font) (font-context))
          w (text-width layouts)
          h (text-height layouts)]
      (->Size w h))))

(defn label
  "Creates a view to display multiline text."
  ([text]
   (label :left :top text))
  ([h-align v-align text]
   (->Label h-align
            v-align
            (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text)))))

(defrecord ImageView [^Image image]
  View
  (render! [view]
    (repaint-on-update! view)
    (.drawImage *graphics* image 0 0 view))
  (geometry [view]
    (let [width (.getWidth image view)
          height (.getHeight image view)
          width (if (pos? width) width 1)
          height (if (pos? height) height 1)]
      (->Size width height)))
  ImageObserver
  (imageUpdate [view img infoflags x y width height]
    (notify! 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)
    (->ImageView image)))

(defrecord RefView [reference view-delay-atom]
  View
  (render! [v]
    (repaint-on-update! v)
    (when-let [view @@view-delay-atom]
      (render! view)))
  (geometry [v]
    (if-let [view @@view-delay-atom]
      (geometry view)
      (->Size 1 1))))

(defn ref-view
  ([reference]
   (ref-view reference #'identity))
  ([reference view-fn]
   ;; The reference may update multiple times before repaint happens,
   ;; delay is used to avoid unnecessary invocations of view-fn.
   (let [view-delay-atom (atom (delay (view-fn @reference)))
         v (->RefView reference view-delay-atom)]
     (add-watch reference v (fn [_ _ _ n]
                              (reset! view-delay-atom (delay (view-fn n)))
                              (notify! v)))
     v)))

;;
;; View context decorators
;;

(defrecord Active [handlers content]
  View
  (render! [v]
    (with-handlers* v handlers render! content))
  (geometry [_]
    (geometry content)))

(defmacro add-handlers
  "Adds event handling to the view."
  [view & event-handlers]
  `(->Active (handlers ~@event-handlers) ~view))

(defrecord Themed [theme view]
  View
  (render! [_]
    (with-theme theme
      (apply-theme)
      (render! view)))
  (geometry [_]
    (with-theme* theme geometry view)))

(defn themed [theme view]
  (->Themed theme view))

(defrecord Hinted [hints view]
  View
  (render! [_]
    (with-hints* hints render! view))
  (geometry [_]
    (if (bound? #'*graphics*)
      (with-hints* hints geometry view)
      (geometry view))))

(defn hinted [hints view]
  (->Hinted hints view))

(defn- transform-bounds
  ^Rectangle2D [^AffineTransform tr ^double w ^double h]
  (.getBounds2D
   (.createTransformedShape tr (Rectangle2D$Double. 0 0 w h))))

(defrecord Transform [transform view]
  View
  (render! [v]
    (let [g (geometry view)
          w (double (width g))
          h (double (height g))
          ^Rectangle2D bounds (transform-bounds transform w h)
          g *graphics*]
      (.translate g (- (.getX bounds)) (- (.getY bounds)))
      (.transform g transform)
      ;; TODO: scale w and h to fit *width* and *height*.
      (draw! view 0 0 w h)))
  (geometry [_]
    (let [g (geometry view)
          w (double (width g))
          h (double (height g))
          ^Rectangle2D bounds (transform-bounds transform w h)]
      (->Size (.getWidth bounds) (.getHeight bounds)))))

(defn transform [tr view]
  (->Transform tr view))

(defn rotate [^double degrees view]
  (transform
   (AffineTransform/getRotateInstance (Math/toRadians degrees))
   view))

;;
;; Measuring time
;;

(def ^:dynamic *interval*)

(defrecord IntervalView [last-time content]
  View
  (render! [_]
    (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))))
  (geometry [_]
    (geometry content)))

(defn interval-view
  "Creates a view that measures time between repaints and draws it's
  content with the *interval* var bound to the measured time."
  [content]
  (->IntervalView (atom nil) content))

(defn- fps-label [text]
  (padding 5 (label :right :bottom text)))

(defrecord FPSView [update-interval frames prev-time display content]
  View
  (render! [_]
    (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)))
  (geometry [_] (geometry content)))

(defn fps-view
  "Creates a view that draws content and displays the
  frames per second rate."
  [content]
  ;; 2E8 ns = 0.2 s.
  (->FPSView 2E8 (ref 0) (ref nil) (ref (fps-label "fps n/a")) content))

;;
;; 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 current layer."
  ([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)))

(defrecord Layered [recursive? content]
  View
  (render! [_]
    (with-overlays* recursive? render! content))
  (geometry [_ ]
    (geometry content)))

(defn layered
  "Allows content view to display pop-ups on top of itself."
  ([content]
   (layered true content))
  ([recursive? content]
   (->Layered recursive? content)))