#lang racket/base
;; Copyright Neil Van Dyke.  See file "info.rkt".

(require racket/class
         racket/gui/base
         "rackout-infidelity.rkt")
         
(module+ test
  (require "planet-neil-overeasy.rkt"))

(define splash-frame #f)

(define splash-lines '())

(define splash-main-color    (make-object color% #xcc #xcc #xcc))
(define splash-url-color     (make-object color% #xaa #xff #xaa))
(define splash-error-color   (make-object color% #xff #x99 #x99))
(define splash-warning-color (make-object color% #xff #x99 #x99))

(define splash-title-font     (send the-font-list find-or-create-font 20 'swiss  'normal 'bold   #f 'partly-smoothed #t 'unaligned))
(define splash-main-font      (send the-font-list find-or-create-font 12 'roman  'normal 'normal #f 'partly-smoothed #t 'unaligned))
(define splash-error-font     (send the-font-list find-or-create-font 12 'roman  'normal 'bold   #f 'partly-smoothed #t 'unaligned))
(define splash-warning-font   (send the-font-list find-or-create-font 7  'roman  'normal 'normal #f 'partly-smoothed #t 'unaligned))
(define splash-big-url-font   (send the-font-list find-or-create-font 16 'modern 'normal 'bold   #f 'partly-smoothed #t 'unaligned))
(define splash-small-url-font (send the-font-list find-or-create-font 12 'modern 'normal 'bold   #f 'partly-smoothed #t 'unaligned))

(define (get-infidelity-tail-for-splash)
  ;; TODO: Change this to use futures.
  (cond ((get-infidelity-english)
         => (lambda (str)
              (list (list splash-warning-font
                          splash-warning-color
                          (string-append "Ahem. Free Software faux pas... This machine"))
                    (list splash-warning-font
                          splash-warning-color
                          (string-append str
                                         ".")))))
        (else #f)))

(define splash-infidelity-tail (get-infidelity-tail-for-splash))

(provide create-splash)
(define (create-splash)
  (let*-values
      (((frame-width frame-height) (get-display-size #t))
       ((frame)
        (new frame%
             (label  "RackOut")
             (x      0)
             (y      0)
             (width  frame-width)
             (height frame-height)
             (style  '(no-resize-border no-caption hide-menu-bar))))
       ((canvas)
        (new canvas% (parent frame)
             (paint-callback
              (lambda (canvas dc)
                (send dc set-background "black")
                (send dc clear)
                (send dc set-scale 1 1)
                (let*-values
                    (((lines) `((,splash-title-font ,splash-main-color "RackOut") ,@splash-lines))
                     ((bounds-width/drawing bounds-height/drawing sized-lines)
                      (let loop ((lines               lines)
                                 (bounds-width/drawing     0)
                                 (bounds-height/drawing    0)
                                 (reverse-sized-lines '())
                                 (prev-vert-space     #f))
                        (if (null? lines)
                            (values bounds-width/drawing bounds-height/drawing (reverse reverse-sized-lines))
                            (let ((line (car lines)))
                              (apply (lambda (font color str)
                                       (let-values (((width height descend extra) (send dc get-text-extent str font)))
                                         (let* ((default-vert-space (* 0.5 height))
                                                (vert-space-above (if prev-vert-space
                                                                      (max prev-vert-space default-vert-space)
                                                                      0)))
                                           (loop (cdr lines)
                                                 (max bounds-width/drawing width)
                                                 (+ bounds-height/drawing height vert-space-above)
                                                 (cons (cons width
                                                             (cons (+ bounds-height/drawing vert-space-above)
                                                                   line))
                                                       reverse-sized-lines)
                                                 default-vert-space))))
                                     line)))))
                     ((dc-width/screen dc-height/screen) (send dc get-size))
                     ((scale) (min (/ dc-width/screen
                                      (+ (* 2.0
                                            (* 0.1 bounds-width/drawing))
                                         bounds-width/drawing))
                                   (/ dc-height/screen
                                      (+ (* 2.0
                                            (* 0.1 bounds-height/drawing))
                                         bounds-height/drawing))))
                     ((dc-width/drawing)    (/ dc-width/screen  scale))
                     ((dc-height/drawing)   (/ dc-height/screen scale))
                     ((vert-margin/drawing) (/ (- dc-height/drawing
                                                  bounds-height/drawing)
                                               2.0)))
                  (let-values (((w h) (send dc get-size)))
                    (log-debug (format "(send dc get-size) ==> ~S ~S ; scale1"
                                       w h)))
                  (log-debug (format "(send dc set-scale ~S ~S)"
                                     scale
                                     scale))
                  (send dc set-scale scale scale)
                  (for-each (lambda (line)
                              (apply (lambda (width y-without-margin font color str)
                                       (send dc set-font font)
                                       (send dc set-text-foreground color)
                                       (let ((x (/ (- dc-width/drawing width) 2.0))
                                             (y (+ vert-margin/drawing y-without-margin)))
                                         (log-debug (format "(send dc draw-text ~S ~S ~S)"
                                                            str
                                                            x
                                                            y))
                                         (send dc draw-text str x y)))
                                     line))
                            
                            sized-lines))))))
       ((blank-cursor) (make-object cursor% 'blank))
       ((blank-cursor) (if (send blank-cursor ok?)
                           blank-cursor
                           #f)))
    (and blank-cursor
         (send frame set-cursor blank-cursor))
    (set! splash-frame frame)))

(provide show-splash)
(define (show-splash)
  (send splash-frame show #t))

(define (hide-splash)
  (send splash-frame show #f))

;; (provide update-splash-lines)
(define (update-splash-lines lines)
  (log-debug (format "update-splash-lines ~S" lines))
  (let ((lines (if splash-infidelity-tail
                   (append lines splash-infidelity-tail)
                   lines)))
    (set! splash-lines lines))
  (send splash-frame refresh)
  ;; Note: This yield won't necessarily result in a repaint.
  (yield))

(provide update-splash-lines/urls)
(define (update-splash-lines/urls main-dumb-url alternate-dumb-urls final?)
  (update-splash-lines
   (url-info->splash-lines main-dumb-url alternate-dumb-urls final?)))

(define (url-info->splash-lines main-dumb-url alternate-dumb-urls final?)
  (let ((alternate-lines (map (lambda (url)
                                `(,splash-small-url-font
                                  ,splash-url-color
                                  ,url))
                              alternate-dumb-urls)))
    (cond (main-dumb-url
           `((,splash-main-font    ,splash-main-color "Point your handheld Web browser at:")
             (,splash-big-url-font ,splash-url-color  ,main-dumb-url)
             ,@(if (null? alternate-lines)
                   '()
                   `((,splash-main-font ,splash-main-color "Or:")
                     ,@alternate-lines))))
          (final?
           (if (null? alternate-lines)
               `((,splash-error-font ,splash-error-color "Oops, we couldn't find a network interface!")
                 (,splash-main-font  ,splash-main-color  "(We can still function as a space heater.)"))
               `(
                 (,splash-main-font  ,splash-main-color  "Point your handheld Web browser at:")
                 ,@alternate-lines
                 (,splash-main-font ,splash-main-color "(We couldn't get a hostname.)"))))
          ((null? alternate-dumb-urls)
           `((,splash-main-font ,splash-main-color "Waiting for network to come up...")))
          (else
           `((,splash-main-font ,splash-main-color "Finding hostname...")
             ,@(if (null? alternate-lines)
                   '()
                   `((,splash-main-font ,splash-main-color "If this hangs, point your handheld Web browser at:")
                     ,@alternate-lines)))))))

(module+ test
  
  (let ((main-dumb-url       "rackout.lan")
        (alternate-dumb-urls '("123.123.123.123" "123.45.67.89")))
    
    (test (url-info->splash-lines main-dumb-url alternate-dumb-urls #t)
          (list (list splash-main-font      splash-main-color  "Point your handheld Web browser at:")
                (list splash-big-url-font   splash-url-color   "rackout.lan")
                (list splash-main-font      splash-main-color  "Or:")
                (list splash-small-url-font splash-url-color   "123.123.123.123")
                (list splash-small-url-font splash-url-color   "123.45.67.89")))
    
    (test (url-info->splash-lines main-dumb-url alternate-dumb-urls #f)
          (list (list splash-main-font      splash-main-color  "Point your handheld Web browser at:")
                (list splash-big-url-font   splash-url-color   "rackout.lan")
                (list splash-main-font      splash-main-color  "Or:")
                (list splash-small-url-font splash-url-color   "123.123.123.123")
                (list splash-small-url-font splash-url-color   "123.45.67.89")))
    
    (test (url-info->splash-lines main-dumb-url '() #f)
          (list (list splash-main-font      splash-main-color  "Point your handheld Web browser at:")
                (list splash-big-url-font   splash-url-color   "rackout.lan")))
    
    (test (url-info->splash-lines main-dumb-url '() #t)
          (list (list splash-main-font      splash-main-color  "Point your handheld Web browser at:")
                (list splash-big-url-font   splash-url-color   "rackout.lan")))
    
    (test (url-info->splash-lines #f '() #t)
          (list (list splash-error-font     splash-error-color "Oops, we couldn't find a network interface!")
                (list splash-main-font      splash-main-color  "(We can still function as a space heater.)")))
    
    (test (url-info->splash-lines #f '() #f)
          (list (list splash-main-font      splash-main-color  "Waiting for network to come up...")))
    
    (test (url-info->splash-lines #f alternate-dumb-urls #t)
          (list (list splash-main-font      splash-main-color  "Point your handheld Web browser at:")
                (list splash-small-url-font splash-url-color   "123.123.123.123")
                (list splash-small-url-font splash-url-color   "123.45.67.89")
                (list splash-main-font      splash-main-color "(We couldn't get a hostname.)")))
    
    (test (url-info->splash-lines #f alternate-dumb-urls #f)
          (list (list splash-main-font      splash-main-color  "Finding hostname...")
                (list splash-main-font      splash-main-color  "If this hangs, point your handheld Web browser at:")
                (list splash-small-url-font splash-url-color   "123.123.123.123")
                (list splash-small-url-font splash-url-color   "123.45.67.89")))))