#lang syndicate/actor

(require racket/set)
(require data/order)
(require (prefix-in i: 2htdp/image))
(require (prefix-in p: pict))
(require syndicate-gl/2d)
(require "layout/main.rkt")
(require "hsv.rkt")

;;---------------------------------------------------------------------------

(define theme-font (make-parameter "Roboto"))
(define theme-font-size (make-parameter 16))
(define theme-title-font (make-parameter "Roboto Condensed"))
(define theme-title-font-size (make-parameter 20))
(define theme-title-font-color (make-parameter "white"))
(define theme-title-bar-color (make-parameter (hsv->color 260 1 1)))
(define theme-title-bar-height (make-parameter 48))
(define theme-button-background-color (make-parameter (hsv->color 30 0.9 1)))
(define theme-button-color (make-parameter "white"))
(define theme-button-x-padding (make-parameter 40))
(define theme-button-y-padding (make-parameter 24))
(define theme-button-min-height (make-parameter 48))
(define theme-window-border-width (make-parameter 8))
(define theme-window-resize-corner-size (make-parameter 16))
(define theme-menu-item-color (make-parameter "white"))
(define theme-menu-item-background-color (make-parameter (hsv->color 240 1 0.8)))
(define theme-menu-item-selected-background-color (make-parameter (hsv->color 345 1 1)))
(define theme-menu-item-padding (make-parameter 16))
(define theme-menu-separator-width (make-parameter 2))
(define theme-menu-separator-color (make-parameter "white"))

;;---------------------------------------------------------------------------

(define (*width x)
  (cond [(i:image? x) (i:image-width x)]
        [(p:pict? x) (p:pict-width x)]
        [else (error '*width "Neither an image nor a pict: ~v" x)]))

(define (*height x)
  (cond [(i:image? x) (i:image-height x)]
        [(p:pict? x) (p:pict-height x)]
        [else (error '*height "Neither an image nor a pict: ~v" x)]))

(define (costume #:id [id #f] #:parent [parent-id #f] i)
  (define iw (*width i))
  (define ih (*height i))
  (define iaspect (/ iw ih))
  (lambda (z rect)
    (match-define (rectangle left top sw sh) rect)
    (define saspect (if (and (positive? sw) (positive? sh)) (/ sw sh) 1))
    (define-values (scale-w scale-h translate-x translate-y)
      (if (> saspect iaspect)
          (let ((scale-h (/ sw iaspect)))
            (values sw scale-h 0 (/ (- sh scale-h) 2)))
          (let ((scale-w (* sh iaspect)))
            (values scale-w sh (/ (- sw scale-w) 2) 0))))
    (sprite #:id (or id (gensym 'costume))
            #:parent parent-id
            z
            `((translate ,left ,top)
              (push-matrix (scale ,sw ,sh)
                           ,@(if id
                                 `((touchable ,id ,in-unit-square?))
                                 `())
                           (texture ,i
                                    ,(- (/ translate-x scale-w))
                                    ,(- (/ translate-y scale-h))
                                    ,(/ sw scale-w)
                                    ,(/ sh scale-h)
                                    ))
              (render-children)))))

(define (draggable-mixin touching? x y z)
  (define (idle)
    (react (stop-when #:when (touching?)
                      (message (inbound (mouse-event 'left-down (mouse-state $mx $my _ _ _))))
                      (dragging (- mx (x)) (- my (y))))))

  (define (dragging dx dy)
    (z (- (current-inexact-milliseconds)))
    (react (on (message (inbound (mouse-event 'motion (mouse-state $mx $my _ _ _))))
               (x (- mx dx))
               (y (- my dy)))
           (stop-when (message (inbound (mouse-event 'left-up _))) (idle))
           (stop-when (message (inbound (mouse-event 'leave _))) (idle))))

  (idle))

(actor #:name 'root-window
       (define c (costume #:id 'root (i:bitmap "oakura-beach-20081225.jpg")))
       (define/query-value touching? #f (inbound (touching 'root)) #t)
       (on #:when (touching?) (message (inbound (mouse-event 'right-down (mouse-state $x $y _ _ _))))
           (send! (pop-up-menu-trigger 'system-menu x y 0 0.5 'right-up)))
       (during (inbound (window $width $height))
               (assert (outbound (c 0 (rectangle 0 0 width height))))))

(define (button-underlay i)
  (define w (+ (*width i) (theme-button-x-padding)))
  (define h (max (+ (*height i) (theme-button-y-padding)) (theme-button-min-height)))
  (i:rectangle w h "solid" (theme-button-background-color)))

;;---------------------------------------------------------------------------

(struct pop-up-menu-trigger (menu-id x y x-pin y-pin release-event) #:transparent)
(struct menu-separator (menu-id order) #:transparent)
(struct menu-item (menu-id order image message) #:transparent)

(actor #:name 'pop-up-menu-driver
       (on (message (pop-up-menu-trigger $menu-id $x $y $x-pin $y-pin $release-event))
           (run-pop-up-menu menu-id x y x-pin y-pin release-event)))

(define (menu-item-order-key i)
  (define v (cond [(menu-item? i) (menu-item-order i)]
                  [(menu-separator? i) (menu-separator-order i)]))
  (if (number? v)
      (exact->inexact v)
      v))

(define (run-pop-up-menu menu-id pop-up-cursor-x pop-up-cursor-y x-pin y-pin release-event)
  (define instance-id (list menu-id (gensym 'instance)))
  (define pad (theme-menu-item-padding))
  (define pad2 (* pad 2))
  (define highlight (i:rectangle 1 1 "solid" (theme-menu-item-selected-background-color)))
  (define separator (i:rectangle 1 1 "solid" (theme-menu-separator-color)))
  (actor #:name instance-id
         (define/query-set items ($ i (menu-item menu-id _ _ _)) i)
         (define/query-set separators ($ s (menu-separator menu-id _)) s)
         (define/dataflow ordered-items (sort (append (set->list (items))
                                                      (set->list (separators)))
                                              (order-<? datum-order)
                                              #:key menu-item-order-key)
           #:default '())
         (define/dataflow menu-table (for/list [(i (ordered-items))]
                                       (match i
                                         [(menu-item _ _ (seal im) _)
                                          (list (box-size (sizing (+ pad2 (*width im)) 0 0)
                                                          (sizing (+ pad2 (*height im)) 0 0)))]
                                         [(menu-separator _ _)
                                          (list (box-size (sizing 0 weak-fill 0)
                                                          (sizing (theme-menu-separator-width) 0 0)))])))
         (define/dataflow total-size (table-sizing (menu-table))
           #:default zero-box-size)
         (define (menu-width) (sizing-ideal (box-size-horizontal (total-size))))
         (define (menu-height) (sizing-ideal (box-size-vertical (total-size))))
         (define/dataflow layout (table-layout (menu-table) 0 0 (menu-width) (menu-height))
           #:default '())

         (define (render-menu)
           (define offset-x (- pop-up-cursor-x (* x-pin (+ (menu-width) 2)) -1))
           (define offset-y (- pop-up-cursor-y (* y-pin (+ (menu-height) 2)) -1))
           (sprite #:id instance-id
                   -1
                   `((translate ,offset-x ,offset-y)
                     (push-matrix (scale ,(menu-width) ,(menu-height))
                                  (texture ,(i:rectangle 1 1 "solid" (theme-menu-item-background-color))))
                     ,@(for/list [(item (ordered-items)) (row (layout))]
                         (match-define (rectangle left top width height) (car row))
                         (match item
                           [(menu-item _ _ (seal im) _)
                            `(begin
                               (push-matrix (translate ,left ,top)
                                            (scale ,width ,height)
                                            (touchable (,instance-id ,(seal item)) ,in-unit-square?)
                                            ,@(if (eq? (selected-item) item)
                                                  `((texture ,highlight))
                                                  `()))
                               (push-matrix (translate ,(+ left pad) ,(+ top pad))
                                            (scale ,(*width im) ,(*height im))
                                            (texture ,im)))]
                           [(menu-separator _ _)
                            `(push-matrix (translate ,left ,top)
                                          (scale ,width ,height)
                                          (texture ,separator))]))
                     (render-children))))

         (define/query-value selected-item* #f (inbound (touching `(,instance-id ,$sealed-item)))
           (seal-contents sealed-item))
         (field [selected-item #f])
         (begin/dataflow (when (not (eq? (selected-item) (selected-item*)))
                           (selected-item (selected-item*))))

         (assert (outbound (render-menu)))
         (stop-when (message (inbound (mouse-event release-event _)))
                    (when (selected-item)
                      (send! (menu-item-message (selected-item)))))
         (on (asserted ($ s (mouse-state _ _ _ _ _)))
             (log-info "MENU ~v: ~v" menu-id s))))

;;---------------------------------------------------------------------------

(define (system-text str [color #f])
  (i:text/font str (theme-font-size) (or color "white")
               (theme-font) 'default 'normal 'normal #f))

(define (title-font-text str)
  (i:text/font str (theme-title-font-size) (theme-title-font-color)
               (theme-title-font) 'default 'normal 'normal #f))

(define (menu-item/text menu-id order str message)
  (menu-item menu-id order (seal (system-text str (theme-menu-item-color))) message))

;;---------------------------------------------------------------------------

(struct window-state (window-id state) #:transparent)
(struct raise-widget (id) #:transparent)

(define close-icon-i
  (parameterize ((theme-font-size (round (* 4/3 (theme-title-font-size)))))
    (system-text "×" (theme-title-font-color))))

(define (window-frame id title backdrop-color
                      #:close-icon? [close-icon? #t]
                      #:parent [parent-id 'root])
  (define title-text-i (title-font-text title))
  (define title-text-w (i:image-width title-text-i))
  (define title-text-h (i:image-height title-text-i))
  (define title-bar-i (i:rectangle 1 1 "solid" (theme-title-bar-color)))
  (define close-icon-w (i:image-width close-icon-i))
  (define close-icon-h (i:image-height close-icon-i))
  (define gap (/ (- (theme-title-bar-height) close-icon-w) 2))
  (define backdrop (i:rectangle 1 1 "solid" backdrop-color))
  (lambda (z rect)
    (match-define (rectangle left top width height) rect)
    (sprite #:id id
            #:parent parent-id
            z
            `((translate ,left ,top)
              (push-matrix (translate ,(- (theme-window-border-width))
                                      ,(- (theme-title-bar-height)))
                           (scale ,(+ width (* 2 (theme-window-border-width)))
                                  ,(+ height (theme-title-bar-height) (theme-window-border-width)))
                           (touchable (,id window-backdrop) ,in-unit-square?)
                           (texture ,title-bar-i))
              (push-matrix (translate 0 ,(- (theme-title-bar-height)))
                           (scale ,width ,(theme-title-bar-height))
                           (touchable (,id title-bar) ,in-unit-square?))
              (push-matrix (translate ,(- (+ width (theme-window-border-width))
                                          (theme-window-resize-corner-size))
                                      ,(- (+ height (theme-window-border-width))
                                          (theme-window-resize-corner-size)))
                           (scale ,(theme-window-resize-corner-size)
                                  ,(theme-window-resize-corner-size))
                           (touchable (,id resize-corner) ,in-unit-square?))
              ,@(if close-icon?
                    `((push-matrix
                       (translate ,gap ,(- (/ (+ (theme-title-bar-height) close-icon-h) 2)))
                       (scale ,close-icon-w ,close-icon-h)
                       (touchable (,id close-icon) ,in-unit-square?)
                       (texture ,close-icon-i)))
                    `())
              (push-matrix (translate ,(/ (- width title-text-w) 2)
                                      ,(- (/ (+ (theme-title-bar-height) title-text-h) 2)))
                           (scale ,title-text-w ,title-text-h)
                           (texture ,title-text-i))
              (push-matrix (scale ,width ,height)
                           (texture ,backdrop))
              (render-children)))))

(define (open-window window-id window-title x y width height [backdrop-color (hsv->color 200 1 1)]
                     #:resizable? [resizable? #t])
  (define c (window-frame window-id window-title backdrop-color))

  (field [z (- (current-inexact-milliseconds))])
  (define/query-value touching-title-bar?
    #f (inbound (touching `(,window-id title-bar))) #t)
  (on-start (draggable-mixin touching-title-bar? x y z))

  (when resizable?
    (define/query-value touching-resize-corner?
      #f (inbound (touching `(,window-id resize-corner))) #t)
    (on-start (draggable-mixin touching-resize-corner? width height z)))

  (define/query-value touching-close-icon?
    #f (inbound (touching `(,window-id close-icon))) #t)
  (stop-when #:when (touching-close-icon?) (message (inbound (mouse-event 'left-up _))))

  (on (message (raise-widget window-id))
      (z (- (current-inexact-milliseconds))))

  (define/dataflow bounds (rectangle (x) (y) (width) (height)) #:default zero-rectangle)
  (assert (window-state window-id (bounds)))
  (assert (outbound (c (z) (bounds)))))

;;---------------------------------------------------------------------------

(struct button-click (id mouse-state) #:transparent)

(begin-for-declarations
  ;; TODO: figure out what it is about (define (f #:x x) x) that
  ;; mandates begin-for-declarations to hide it from syndicate/lang's
  ;; local-expansion here :-(
  (define (pushbutton label-str x y
                      #:id id
                      #:parent parent-id
                      #:trigger-event [trigger-event 'left-up])
    (define label (system-text label-str (theme-button-color)))
    (define i (i:overlay/align "middle" "middle" label (button-underlay label)))
    (define c (costume #:id id #:parent parent-id i))

    (define/query-value touching? #f (inbound (touching id)) #t)
    (on #:when (touching?) (message (inbound (mouse-event trigger-event $s)))
        (send! (button-click id s)))
    (assert (outbound (c 0 (rectangle x y (*width i) (*height i)))))))

;;---------------------------------------------------------------------------

(define (enforce-minimum f v)
  (begin/dataflow (when (< (f) v) (f v))))

(begin-for-declarations
  (define (message-box title init-x init-y body #:id id)
    (define msg (system-text body))
    (actor #:name (list 'message-box id)
           (field [x init-x]
                  [y init-y]
                  [width (max 250 (*width msg))]
                  [height (max 100 (*height msg))])
           (open-window id title x y width height #:resizable? #f)
           (assert (outbound ((costume #:parent id msg)
                              0
                              (rectangle (/ (- (width) (*width msg)) 2)
                                         (/ (- (height) (*height msg)) 2)
                                         (*width msg)
                                         (*height msg))))))))

(actor #:name 'test-window

       (field [x 140] [y 140] [width 400] [height 300])
       (open-window 'w "Window Title" x y width height)
       (enforce-minimum width 300)
       (enforce-minimum height 300)

       (assert (menu-item/text 'testmenu 0 "First item" '(testmenu first)))
       (assert (menu-item/text 'testmenu 1 "Second item" '(testmenu second)))
       (assert (menu-item/text 'testmenu 2 "Third item" '(testmenu third)))

       (during (inbound (window $width $height))
               (on (message `(testmenu ,$which))
                   (define box-id (gensym 'box))
                   (message-box #:id box-id
                                "Menu item selected" (random width) (random height)
                                (format "~a" which))))

       (pushbutton "Click me" 100 100 #:id 'click-me #:parent 'w #:trigger-event 'left-down)
       (on (message (button-click 'click-me (mouse-state $x $y _ _ _)))
           (send! (pop-up-menu-trigger 'testmenu x y 0 0.5 'left-up))))

;;---------------------------------------------------------------------------

(actor #:name 'fullscreen-menu-item
       (field [fullscreen? #t])
       (assert (menu-item/text 'system-menu -1
                               (if (fullscreen?)
                                   "Fullscreen ✓"
                                   "Fullscreen")
                               '(system-menu toggle-fullscreen)))
       (assert (menu-separator 'system-menu -0.9))
       (on (message '(system-menu toggle-fullscreen))
           (fullscreen? (not (fullscreen?))))
       (assert #:when (fullscreen?) (outbound 'fullscreen)))

(actor #:name 'quit-menu-item
       (assert (menu-item/text 'system-menu 0 "Quit" '(system-menu quit)))
       (stop-when (message '(system-menu quit))
                  (actor (assert (outbound 'stop))))
       (stop-when (message (inbound (key-event #\q #t _)))
                  (actor (assert (outbound 'stop)))))

;; (actor #:name 'toolbar

;;        (field [window-width 0] [window-height 0])
;;        (on (asserted (inbound (window $w $h)))
;;            (window-width w)
;;            (window-height h))

;;        (assert (outbound ((costume #:id 'toolbar #:parent #f
;;                                    (i:rectangle 1 1 "solid" "black"))
;;                           -0.5
;;                           (rectangle 0
;;                                      (- (window-height) (theme-title-bar-height))
;;                                      (window-width)
;;                                      (theme-title-bar-height))))))

(module+ main
  (current-ground-dataspace (2d-dataspace)))