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

(require racket/port
         racket/system
         "rackout-system.rkt")

(module+ test
  (require (planet neil/overeasy:2)))

;; TODO: Replace "max-pixels-pair" field with 2 fields: one for the rows of
;; resolutions and frequencies, and one that indicates the current resolution
;; and frequency.  This would help us better restore xrandr configuration when
;; exiting app, for one thing.
(provide xrandr-display?
         xrandr-display-name-string
         xrandr-display-connected?
         xrandr-display-mm-pair
         xrandr-display-max-pixels-pair)
(define-struct xrandr-display
  (name-string
   connected?
   mm-pair
   max-pixels-pair)
  #:transparent)

(define (%xrandr:bytes->integer bstr)
  (string->number (bytes->string/latin-1 bstr)))

(provide parse-xrandr-output)
(define (parse-xrandr-output in
                             #:connected-only? (connected-only? #false))
  (let loop-no-display ((reverse-result '())
                        (screen-number  #f))
    ;; TODO: Is this notion of "screen-number" correct?  We don't use it
    ;; anyway, right now.
    (cond ((eof-object? (peek-byte in))
           (reverse reverse-result))
          ((regexp-try-match #rx#"^Screen +([0-9]+):[^\n]*\n" in)
           => (lambda (m)
                (loop-no-display reverse-result
                                 (%xrandr:bytes->integer (cadr m)))))
          ((regexp-try-match #rx#"^([-A-Za-z0-9]+) (connected )?" in)
           ;;
           => (lambda (m)
                (apply (lambda (all name connected)
                         (let ((mm-pair (cond ((regexp-try-match #rx#"^[^\n]*[^0-9]([0-9]+)mm x ([0-9]+)mm[^\n]*\n" in)
                                               => (lambda (m)
                                                    (apply (lambda (all width-mm height-mm)
                                                             (cons (%xrandr:bytes->integer width-mm)
                                                                   (%xrandr:bytes->integer height-mm)))
                                                           m)))
                                              ((regexp-try-match #rx#"^[^\n]*\n" in)
                                               #f)
                                              (else (error 'parse-xrandr-output
                                                           "could not find end of display line at: ~S"
                                                           (port->bytes in))))))
                           (let loop-modes ((pixel-resolution-pair #f))
                             (cond ((regexp-try-match #rx#"^ +([0-9]+)x([0-9]+) [^\n]*\n" in)
                                    => (lambda (m)
                                         (loop-modes (or pixel-resolution-pair
                                                         (cons (%xrandr:bytes->integer (list-ref m 1))
                                                               (%xrandr:bytes->integer (list-ref m 2)))))))
                                   (else
                                    (loop-no-display (if (or connected (not connected-only?))
                                                         (cons (make-xrandr-display
                                                                (bytes->string/latin-1 name)
                                                                (and connected #t)
                                                                mm-pair
                                                                pixel-resolution-pair)
                                                               reverse-result)
                                                         reverse-result)
                                                     screen-number))))))
                       m)))
          (else (error 'parse-xrandr-output
                       "could not parse display start at: ~S"
                       (port->bytes in))))))

(module+ test
  (test (let ((bstr
               (bytes-append
                ;; Note: This output doesn't fully make sense, because it's been edited.
                #"Screen 0: minimum 320 x 200, current 2480 x 1920, maximum 8192 x 8192\n"
                #"VGA-0 disconnected (normal left inverted right x axis y axis)\n"
                #"LVDS connected 1400x1050+1080+0 (normal left inverted right x axis y axis) 287mm x 215mm\n"
                #"   1400x1050      60.0*+   50.0  \n"
                #"   1280x1024      59.9     60.0  \n"
                #"   1280x960       59.9  \n"
                #"   1280x854       59.9  \n"
                #"   1280x800       59.8  \n"
                #"   1280x720       59.9  \n"
                #"   1152x768       59.8  \n"
                #"   1024x768       60.0     59.9  \n"
                #"   800x600        60.3     59.9  \n"
                #"   848x480        59.7  \n"
                #"   720x480        59.7  \n"
                #"   640x480        60.0     59.4  \n"
                #"DVI-0 connected 1920x1080+0+0 left (normal left inverted right x axis y axis) 510mm x 287mm\n"
                #"   1920x1080      60.0*+   60.0  \n"
                #"   1280x1024      75.0     60.0  \n"
                #"   1152x864       75.0  \n"
                #"   1024x768       75.1     60.0  \n"
                #"   800x600        75.0     60.3  \n"
                #"   640x480        75.0     60.0  \n"
                #"   720x400        70.1  \n")))
          (values (parse-xrandr-output (open-input-bytes bstr))
                  (parse-xrandr-output (open-input-bytes bstr) #:connected-only? #t)))
        (values (list (make-xrandr-display "VGA-0" #f #f           #f)
                      (make-xrandr-display "LVDS"  #t '(287 . 215) '(1400 . 1050))
                      (make-xrandr-display "DVI-0" #t '(510 . 287) '(1920 . 1080)))
                (list (make-xrandr-display "LVDS"  #t '(287 . 215) '(1400 . 1050))
                      (make-xrandr-display "DVI-0" #t '(510 . 287) '(1920 . 1080)))))
  (test (let ((bstr
               (bytes-append
                #"Screen 0: minimum 320 x 200, current 3520 x 1080, maximum 8192 x 8192\n"
                #"LVDS1 connected 1600x900+1920+0 (normal left inverted right x axis y axis) 309mm x 174mm\n"
                #"   1600x900       60.0*+   40.0\n"
                #"   1440x900       59.9\n"
                #"   1360x768       59.8     60.0\n"
                #"   1152x864       60.0\n"
                #"   1024x768       60.0\n"
                #"   800x600        60.3     56.2\n"
                #"   640x480        59.9\n"
                #"VGA1 disconnected (normal left inverted right x axis y axis)\n"
                #"HDMI1 connected 1920x1080+0+0 (normal left inverted right x axis y axis) 477mm x 268mm\n"
                #"   1920x1080      60.0*+\n"
                #"   1680x1050      60.0\n"
                #"   1280x1024      60.0\n"
                #"   1280x960       60.0\n"
                #"   1152x864       60.0\n"
                #"   1024x768       60.0\n"
                #"   800x600        60.3\n"
                #"   640x480        60.0\n"
                #"DP1 disconnected (normal left inverted right x axis y axis)\n"
                #"HDMI2 disconnected (normal left inverted right x axis y axis)\n"
                #"HDMI3 disconnected (normal left inverted right x axis y axis)\n"
                #"DP2 disconnected (normal left inverted right x axis y axis)\n"
                #"DP3 disconnected (normal left inverted right x axis y axis)\n")))
          (values (parse-xrandr-output (open-input-bytes bstr))
                  (parse-xrandr-output (open-input-bytes bstr) #:connected-only? #t)))
        (values (list (make-xrandr-display "LVDS1" #t '(309 . 174) '(1600 . 900))
                      (make-xrandr-display "VGA1" #f #f #f)
                      (make-xrandr-display "HDMI1" #t '(477 . 268) '(1920 . 1080))
                      (make-xrandr-display "DP1" #f #f #f)
                      (make-xrandr-display "HDMI2" #f #f #f)
                      (make-xrandr-display "HDMI3" #f #f #f)
                      (make-xrandr-display "DP2" #f #f #f)
                      (make-xrandr-display "DP3" #f #f #f))
                (list (make-xrandr-display "LVDS1" #t '(309 . 174) '(1600 . 900))
                      (make-xrandr-display "HDMI1" #t '(477 . 268) '(1920 . 1080)))))
  (test (let ((bstr
               (bytes-append
                #"Screen 0: minimum 320 x 200, current 2960 x 1050, maximum 8192 x 8192\n"
                #"DisplayPort-0 connected 1680x1050+1280+0 (normal left inverted right x axis y axis) 474mm x 296mm\n"
                #"   1680x1050 60.0*+\n"
                #"   1280x1024 75.0 60.0\n"
                #"   1280x960 60.0\n"
                #"   1152x864 75.0\n"
                #"   1024x768 75.1 70.1 60.0\n"
                #"   832x624 74.6\n"
                #"   800x600 72.2 75.0 60.3 56.2\n"
                #"   640x480 72.8 75.0 66.7 60.0\n"
                #"   720x400 70.1\n"
                #"DisplayPort-1 connected 1280x1024+0+0 (normal left inverted right x axis y axis) 337mm x 270mm\n"
                #"   1280x1024 60.0* \n")))
          (values (parse-xrandr-output (open-input-bytes bstr))
                  (parse-xrandr-output (open-input-bytes bstr) #:connected-only? #t)))
        (values (list (make-xrandr-display "DisplayPort-0" #t '(474 . 296) '(1680 . 1050))
                      (make-xrandr-display "DisplayPort-1" #t '(337 . 270) '(1280 . 1024)))
                (list (make-xrandr-display "DisplayPort-0" #t '(474 . 296) '(1680 . 1050))
                      (make-xrandr-display "DisplayPort-1" #t '(337 . 270) '(1280 . 1024)))))
  (test (let ((bstr
               (bytes-append
                #"Screen 0: minimum 320 x 200, current 2480 x 1920, maximum 16384 x 16384\n"
                #"DisplayPort-0 connected 1200x1920+1280+0 left (normal left inverted right x axis y axis) 518mm x 324mm\n"
                #"   1920x1200      60.0*+\n"
                #"   1920x1080      60.0  \n"
                #"   1600x1200      60.0  \n"
                #"   1680x1050      60.0  \n"
                #"   1280x1024      60.0  \n"
                #"   1280x960       60.0  \n"
                #"   1024x768       60.0  \n"
                #"   800x600        60.3  \n"
                #"   640x480        60.0  \n"
                #"   720x400        70.1  \n"
                #"DVI-0 connected 1024x1280+0+283 left (normal left inverted right x axis y axis) 376mm x 301mm\n"
                #"   1280x1024      60.0*+   75.0  \n"
                #"   1152x864       75.0  \n"
                #"   1024x768       75.1     60.0  \n"
                #"   800x600        75.0     60.3  \n"
                #"   640x480        75.0     60.0  \n"
                #"   720x400        70.1  \n")))
          (values (parse-xrandr-output (open-input-bytes bstr))
                  (parse-xrandr-output (open-input-bytes bstr) #:connected-only? #t)))
        (values (list (make-xrandr-display "DisplayPort-0" #t '(518 . 324) '(1920 . 1200))
                      (make-xrandr-display "DVI-0"         #t '(376 . 301) '(1280 . 1024)))
                (list (make-xrandr-display "DisplayPort-0" #t '(518 . 324) '(1920 . 1200))
                      (make-xrandr-display "DVI-0"         #t '(376 . 301) '(1280 . 1024))))))

(define (find-big-xrandr-display-and-resolution xrandr-displays)
  
  (cond ((null? xrandr-displays)
         (error 'find-big-xrandr-display-and-resolution
                "no displays"))
        ((null? (cdr xrandr-displays))
         (let ((dpy (car xrandr-displays)))
           
           (values dpy (xrandr-display-max-pixels-pair dpy))))
        (else
         (let* ((scored-dpys (map (lambda (dpy)
                                    (cons (+ (cond ((xrandr-display-max-pixels-pair dpy) => cdr)
                                                   (else 0))
                                             (cond ((xrandr-display-mm-pair dpy) => cdr)
                                                   (else 0)))
                                          dpy))
                                  xrandr-displays))
                (scored-dpys (sort scored-dpys >= #:key car))
                (dpy         (cdar scored-dpys)))
           (values dpy (xrandr-display-max-pixels-pair dpy))))))

(module+ test
  
  (let ((lvds  (make-xrandr-display "LVDS"  #t '(287 . 215) '(1400 . 1050)))
        (dvi-0 (make-xrandr-display "DVI-0" #t '(510 . 287) '(1920 . 1080))))
    (test (find-big-xrandr-display-and-resolution (list lvds dvi-0))
          (values dvi-0
                  '(1920 . 1080))))
  
  (let ((lvds1 (make-xrandr-display "LVDS1" #t '(309 . 174) '(1600 . 900)))
        (hdmi1 (make-xrandr-display "HDMI1" #t '(477 . 268) '(1920 . 1080))))
    (test (find-big-xrandr-display-and-resolution (list lvds1 hdmi1))
          (values hdmi1 '(1920 . 1080))))
  
  (let ((dp-0 (make-xrandr-display "DisplayPort-0" #t '(474 . 296) '(1680 . 1050)))
        (dp-1 (make-xrandr-display "DisplayPort-1" #t '(337 . 270) '(1280 . 1024))))
    (test (find-big-xrandr-display-and-resolution (list dp-0 dp-1))
          (values dp-0 '(1680 . 1050))))
  
  (let ((dp-0  (make-xrandr-display "DisplayPort-0" #t '(518 . 324) '(1920 . 1200)))
        (dvi-0 (make-xrandr-display "DVI-0"         #t '(376 . 301) '(1280 . 1024))))
    (test (find-big-xrandr-display-and-resolution (list dp-0 dvi-0))
          (values dp-0 '(1920 . 1200)))))

(define current-xrandr-command
  (make-parameter "/usr/bin/xrandr"))

(define (xrandr-pixels-pair->command-line-arg pixels-pair)
  (string-append (number->string (car pixels-pair))
                 "x"
                 (number->string (cdr pixels-pair))))

(define (xrandr-arguments-for-only-one-display-on all-xds on-xd pixels-pair)
  (let ((on-xd-name (xrandr-display-name-string on-xd)))
    `("--output"
      ,on-xd-name
      "--auto"
      ;; "--primary"
      "--size"
      ,(xrandr-pixels-pair->command-line-arg (xrandr-display-max-pixels-pair on-xd))
      ,@(let loop ((all-xds all-xds))
          (if (null? all-xds)
              '()
              (let ((off-xd-name (xrandr-display-name-string (car all-xds))))
                (if (equal? off-xd-name on-xd-name)
                    (loop (cdr all-xds))
                    `("--output"
                      ,off-xd-name
                      "--off"
                      ,@(loop (cdr all-xds))))))))))

(module+ test
  (let ((dp-0  (make-xrandr-display "DisplayPort-0" #t '(518 . 324) '(1920 . 1200)))
        (dvi-0 (make-xrandr-display "DVI-0"         #t '(376 . 301) '(1280 . 1024))))
    (test (xrandr-arguments-for-only-one-display-on (list dp-0 dvi-0)
                                                    dp-0
                                                    '(1920 . 1200))
          (list "--output"
                "DisplayPort-0"
                "--auto"
                ;; "--primary"
                "--size"
                "1920x1200"
                "--output"
                "DVI-0"
                "--off"))))

(define (xrandr-panning-args fb-pixels-pair output-pixels-pair)
  (let ((width-arg (if (> (car fb-pixels-pair) (car output-pixels-pair))
                       (car fb-pixels-pair)
                       0))
        (height-arg (if (> (cdr fb-pixels-pair) (cdr output-pixels-pair))
                        (cdr fb-pixels-pair)
                        0)))
    (if (and (zero? width-arg) (zero? height-arg))
        '()
        `("--panning"
          ,(xrandr-pixels-pair->command-line-arg (cons width-arg height-arg))))))

(define (xrandr-arguments-for-all-connected-displays-on all-xds)
  (let*-values (((big-xd big-pixels-pair) (find-big-xrandr-display-and-resolution all-xds))
                ((big-xd-name) (xrandr-display-name-string big-xd))
                ((width height) (let loop ((all-xds all-xds)
                                           (width   1)
                                           (height  1))
                                  (if (null? all-xds)
                                      (values width height)
                                      (let* ((xd     (car all-xds))
                                             (xd-mpp (xrandr-display-max-pixels-pair xd)))
                                        (loop (cdr all-xds)
                                              (max width (car xd-mpp))
                                              (max height (cdr xd-mpp)))))))
                ((fb-pixels-pair) (cons width height)))
    `("--fb"
      ,(xrandr-pixels-pair->command-line-arg fb-pixels-pair)
      "--output"
      ,big-xd-name
      "--auto"
      "--size"
      ,(xrandr-pixels-pair->command-line-arg big-pixels-pair)
      ,@(xrandr-panning-args fb-pixels-pair big-pixels-pair)
      ,@(let loop ((all-xds all-xds))
          (if (null? all-xds)
              '()
              (let* ((xd             (car all-xds))
                     (xd-name        (xrandr-display-name-string xd))
                     (xd-pixels-pair (xrandr-display-max-pixels-pair xd)))
                (if (equal? xd-name big-xd-name)
                    (loop (cdr all-xds))
                    `("--output"
                      ,(xrandr-display-name-string xd)
                      "--auto"
                      "--same-as"
                      ,big-xd-name
                      "--size"
                      ,(xrandr-pixels-pair->command-line-arg xd-pixels-pair)
                      ,@(xrandr-panning-args fb-pixels-pair xd-pixels-pair)
                      ,@(loop (cdr all-xds))))))))))

(module+ test
  (let ((dp-0  (make-xrandr-display "DisplayPort-0" #t '(518 . 324) '(1920 . 1200)))
        (dvi-0 (make-xrandr-display "DVI-0"         #t '(376 . 301) '(1280 . 1024))))
    (test (xrandr-arguments-for-all-connected-displays-on (list dp-0 dvi-0))
          (list "--fb"
                "1920x1200"
                "--output"
                "DisplayPort-0"
                "--auto"
                "--size"
                "1920x1200"
                "--output"
                "DVI-0"
                "--auto"
                "--same-as"
                "DisplayPort-0"
                "--size"
                "1280x1024"
                "--panning"
                "1920x1200"))))

(provide get-xrandr-displays)
(define (get-xrandr-displays #:connected-only? (connected-only? #false))
  ;; Note: We ignore stderr, because, when running under kvm/qemu, we get a
  ;; stderr message "/usr/bin/xrandr: Failed to get size of gamma for output
  ;; default\n".
  (parse-xrandr-output
   (open-input-bytes (system-command/stdout-bytes
                      #:error-name     'get-xrandr-displays
                      #:sudo?          #false
                      #:stderr-ignore? #true
                      #:command        (current-xrandr-command)
                      #:args           '()))
   #:connected-only? connected-only?))

(provide xrandr-use-big-display-only)
(define (xrandr-use-big-display-only)
  (let*-values (((all-xds)           (get-xrandr-displays #:connected-only? #true))
                ((on-xd pixels-pair) (find-big-xrandr-display-and-resolution all-xds))
                ((args)              (xrandr-arguments-for-only-one-display-on all-xds on-xd pixels-pair)))
    (system-command/ignored-output
     #:error-name 'xrandr-use-big-display-only
     #:sudo?      #false
     #:command    (current-xrandr-command)
     #:args       args)))

(provide xrandr-use-all-connected-displays-with-panning)
(define (xrandr-use-all-connected-displays-with-panning)
  (system-command/ignored-output
   #:error-name 'xrandr-use-all-connected-displays-with-panning
   #:sudo?      #false
   #:command    (current-xrandr-command)
   #:args       (xrandr-arguments-for-all-connected-displays-on
                 (get-xrandr-displays #:connected-only? #true))))