#lang racket/base
(require racket/math
         racket/gui
         racket/class
         framework)

;; to bring back types, added "typed/" in front of the
;; racket/* imports, remove these macros and remove the
;; occurrences of "#;#;" that appear below
;; to get back to at least the most recently typed version
;; of this file, but there will be problems, including
;; getting the preferneces system to cooperate and the
;; font get-size method.
(define-syntax-rule (: . whatever) (void))
(define-syntax-rule (assert e) e)

(define (get-font-size)
  (editor:font-size-pref->current-font-size
   (preferences:get 'framework:standard-style-list:font-size)))

(provide tooltip-frame%)

(: tooltip-font (U #f (Instance Font%)))
(define tooltip-font #f)

(: get-tooltip-font (-> (Instance Font%)))
(define (get-tooltip-font)
  (cond
    [tooltip-font tooltip-font]
    [else
     (define default-font-size
       (let* ([txt (make-object text%)]
              [stl (send txt get-style-list)]
              [bcs (send stl basic-style)])
         (send bcs get-size)))
     (define ans (send the-font-list find-or-create-font
                       (* (/ (send small-control-font get-size) default-font-size)
                          (get-font-size))
                       (send small-control-font get-face)
                       (send small-control-font get-family)
                       (send small-control-font get-style)
                       (send small-control-font get-weight)
                       (send small-control-font get-underlined)
                       (send small-control-font get-smoothing)
                       (send small-control-font get-size-in-pixels)
                       (send small-control-font get-hinting)))
     (set! tooltip-font ans)
     ans]))

(define yellow-message%
  (class canvas%
    (inherit get-dc refresh get-client-size
             min-width min-height
             get-parent)


    (: labels (Listof (List String String)))
  the first string indicates the amount of leading space
  to give ; it should be as much width as the first string
  would require to draw . The second string is then actually drawn
    (define labels '(("" "")))

    (: set-lab (-> (Listof (List String String)) Void))
    (define/public (set-lab _ls)
      (unless (equal? labels _ls)
        (set! labels _ls)
        (update-size)
        (refresh)))
    (: update-size (-> Void))
    (define/private (update-size)
      (define dc (get-dc))
      (send dc set-font (get-tooltip-font))
      (define-values (w h)
# ; : Nonnegative - Real 0 ] [ h # ; # ; : Nonnegative - Real 0 ] )
                  ([space+label (in-list labels)])
          (define space (list-ref space+label 0))
          (define label (list-ref space+label 1))
          (define-values (space-w _1 _2 _3) (send dc get-text-extent space))
          (define-values (this-w this-h _4 _5) (send dc get-text-extent label))
          (values (max (+ space-w this-w) w)
                  (max this-h h))))
      (define parent (assert (get-parent)))
      (send parent begin-container-sequence)
      (min-width (+ 5 (exact-ceiling w)))
      (min-height (+ 5 (* (length labels) (exact-ceiling h))))
      (send parent end-container-sequence)
      (send parent reflow-container))

    ;; private field for gc reasons
    (define font-size-callback (λ (p v) (set! tooltip-font #f) (update-size)))
    (preferences:add-callback 'framework:standard-style-list:font-size
                              font-size-callback
                              #t)
    
    (define/override (on-paint)
      (define dc (get-dc))
      (send dc set-font (get-tooltip-font))
      (define-values (w h) (get-client-size))
      (define-values (_1 th _2 _3) (send dc get-text-extent "yX"))
      (send dc set-pen "black" 1 'transparent)
      (send dc set-brush "LemonChiffon" 'solid)
      (send dc set-pen "black" 1 'solid)
      (send dc draw-rectangle 0 0 w h)
      (for ([space+label (in-list labels)]
            [i (in-naturals)])
        (define space (list-ref space+label 0))
        (define label (list-ref space+label 1))
        (define-values (space-w _1 _2 _3) (send dc get-text-extent space #f 'grapheme))
        (send dc draw-text label (+ 2 space-w) (+ 2 (* i th)) 'grapheme)))
    (super-new [stretchable-width #f] [stretchable-height #f])))

(define tooltip-frame%
  (class frame%
    (inherit reflow-container move get-width get-height is-shown?)
    
    (init-field [frame-to-track #;#;: (Option (Instance Window<%>)) #f])
    (: timer (Option (Instance Timer%)))
    (define timer
      (let ([frame-to-track frame-to-track])
        (and frame-to-track
             (new timer%
                  [notify-callback
                   (λ ()
                     (unless (send frame-to-track is-shown?)
                       (show #f)
                       (send (assert timer) stop)))]))))
    
    
    (define/override (on-subwindow-event r evt)
      (and (is-shown?)
           (begin (show #f)
                  #t)))
    
    ;; ls may contain strings that have newlines; break up the strings here
    (: set-tooltip (-> (Listof String) Void))
    (define/public (set-tooltip ls)
      (define broken-up-lines
        (apply
         append
# ; : (  (  ( List String String ) ) ) ( [ str # ; # ; : String ( in - list ls ) ] )
           (strings->strings+spacers (regexp-split #rx"\n" str)))))
      (send yellow-message set-lab broken-up-lines))
    
    (define/override (show on?)
      (when timer
        (cond
          [on? (send timer start 200 #f)]
          [else (send timer stop)]))
      (super show on?))

    (: show-over (-> Integer Integer Integer Integer [#:prefer-upper-left? Any] Void))
    (define/public (show-over x y w h #:prefer-upper-left? [prefer-upper-left? #f])
      (reflow-container)
      (define mw (get-width))
      (define mh (get-height))
      (define (upper-left must?)
        (define the-x (- x mw))
        (define the-y (- y mh))
        (if must?
            (move the-x the-y)
            (try-moving-to the-x the-y mw mh)))
      (define (lower-right must?)
        (define the-x (+ x w))
        (define the-y (+ y h))
        (if must?
            (move the-x the-y)
            (try-moving-to the-x the-y mw mh)))
      (if prefer-upper-left?
          (or (upper-left #t) (lower-right #f) (upper-left #t))
          (or (lower-right #t) (upper-left #f) (lower-right #t)))
      (show #t))
    
    (: try-moving-to (Integer Integer Integer Integer -> Boolean))
    (define/private (try-moving-to x y w h)
      (and (for/or #;#;: Boolean ([m #;#;: Natural (in-range 0 (get-display-count))])
             (define-values (mx my) (get-display-left-top-inset #:monitor m))
             (define-values (mw mh) (get-display-size #:monitor m))
             (and mx my mw mh
                  (<= (- mx) x (+ x w) (+ (- mx) mw))
                  (<= (- my) y (+ y h) (+ (- my) mh))))
           (begin (move x y)
                  #t)))

    (super-new [style '(no-resize-border no-caption float)]
               [label ""]
               [parent frame-to-track]
               [stretchable-width #f]
               [stretchable-height #f])
    (: yellow-message (Object [set-lab ((Listof (List String String)) -> Void)]))
    (define yellow-message (new yellow-message% [parent this]))))


(: strings->strings+spacers (-> (Listof String) (Listof (List String String))))
(define (strings->strings+spacers strs)
  (let loop ([strs strs]
             [prefix ""])
    (cond
      [(null? strs) '()]
      [else
       (define str (car strs))
       (define leading-spaces (car (assert (regexp-match #rx"^ *" str))))
       (define this-entry
         (cond
           [(<= (string-length prefix) (string-length leading-spaces))
            (list prefix (substring str (string-length prefix) (string-length str)))]
           [else
            (list (substring prefix 0 (string-length leading-spaces))
                  (substring str (string-length leading-spaces) (string-length str)))]))
       (define new-prefix
         (cond
           [(< (string-length prefix) (string-length leading-spaces))
            prefix]
           [else
            (string-append (substring prefix 0 (string-length leading-spaces))
                           (substring str (string-length leading-spaces) (string-length str)))]))
       (cons this-entry (loop (cdr strs) new-prefix))])))


(module+ test
  (require rackunit)
  (check-equal? (strings->strings+spacers '()) '())
  (check-equal? (strings->strings+spacers '("x")) '(("" "x")))
  (check-equal? (strings->strings+spacers '("x" "x")) '(("" "x") ("" "x")))
  (check-equal? (strings->strings+spacers '("xx" " x")) '(("" "xx") ("x" "x")))
  (check-equal? (strings->strings+spacers '("abcdef"
                                            " pqrst"
                                            "  ijkl"
                                            "   mno"))
                '(("" "abcdef")
                  ("a" "pqrst")
                  ("ap" "ijkl")
                  ("api" "mno")))
  (check-equal? (strings->strings+spacers '("abcdef"
                                            " pqrst"
                                            "  ijkl"
                                            " mnozz"))
                '(("" "abcdef")
                  ("a" "pqrst")
                  ("ap" "ijkl")
                  ("a" "mnozz")))
  (check-equal? (strings->strings+spacers '("abcdef"
                                            " pqrst"
                                            " mnozz"
                                            "  ijkl"))
                '(("" "abcdef")
                  ("a" "pqrst")
                  ("a" "mnozz")
                  ("am" "ijkl")))
  (check-equal? (strings->strings+spacers '("abcdef"
                                            " pqrst"
                                            "  ijkl"
                                            "  mnoz"))
                '(("" "abcdef")
                  ("a" "pqrst")
                  ("ap" "ijkl")
                  ("ap" "mnoz")))
  (check-equal? (strings->strings+spacers '("   def"
                                            "abcxyz"))
                '(("" "   def")
                  ("" "abcxyz")))
  (check-equal? (strings->strings+spacers '("abcdef"
                                            "   xyz"
                                            "           pqrstuv"))
                '(("" "abcdef")
                  ("abc" "xyz")
                  ("abcxyz" "     pqrstuv"))))


(module+ main
  (require racket/gui/base)
  (define c%
    (class canvas%
      (inherit get-client-size client->screen)
      (: state (U False 'left 'right))
      (define state #f)
      (define/override (on-event evt)
        (define-values (w h) (get-client-size))
        (define new-state
          (cond
            [(not (<= 0 (send evt get-y) h)) #f]
            [(<= 0 (send evt get-x) (/ w 2))
             'left]
            [(<= (/ w 2) (send evt get-x) w)
             'right]
            [else
             #f]))
        (unless (equal? new-state state)
          (define old-state state)
          (set! state new-state)
          (send tooltip-frame show #f)
          (when state
            (send tooltip-frame set-tooltip
                  (case state
                    [(left) '("abcdef\n  ghij\n  klmn\n    op\n     q")]
                    [(right) '("right")]
                    [else '("whatever")]))
            (define-values (sx sy) (client->screen 10 10))
            (send tooltip-frame show-over sx sy 10 10))))
      (super-new)
      (define tooltip-frame (new tooltip-frame%))))
  (define f (new frame% [label ""] [width 200] [height 200]))
  (define c (new c% [parent f]))
  (send f show #t))

 to bring back types, added "typed/" in front of the
 racket/* imports, remove these macros and remove the
 occurrences of "#;#;" that appear below
 to get back to at least the most recently typed version
 of this file, but there will be problems, including
 getting the preferneces system to cooperate and the
 font get-size method.
 it should be as much width as the first string
 : Nonnegative - Real 0 ] [ h # ; # ; : Nonnegative - Real 0 ] )
 private field for gc reasons
#;: (Option (Instance Window<%>)) #f])
 ls may contain strings that have newlines; break up the strings here
 : (  (  ( List String String ) ) ) ( [ str # ; # ; : String ( in - list ls ) ] )
#;: Boolean ([m #;#;: Natural (in-range 0 (get-display-count))])
#lang racket/base
(require racket/math
         racket/gui
         racket/class
         framework)

(define-syntax-rule (: . whatever) (void))
(define-syntax-rule (assert e) e)

(define (get-font-size)
  (editor:font-size-pref->current-font-size
   (preferences:get 'framework:standard-style-list:font-size)))

(provide tooltip-frame%)

(: tooltip-font (U #f (Instance Font%)))
(define tooltip-font #f)

(: get-tooltip-font (-> (Instance Font%)))
(define (get-tooltip-font)
  (cond
    [tooltip-font tooltip-font]
    [else
     (define default-font-size
       (let* ([txt (make-object text%)]
              [stl (send txt get-style-list)]
              [bcs (send stl basic-style)])
         (send bcs get-size)))
     (define ans (send the-font-list find-or-create-font
                       (* (/ (send small-control-font get-size) default-font-size)
                          (get-font-size))
                       (send small-control-font get-face)
                       (send small-control-font get-family)
                       (send small-control-font get-style)
                       (send small-control-font get-weight)
                       (send small-control-font get-underlined)
                       (send small-control-font get-smoothing)
                       (send small-control-font get-size-in-pixels)
                       (send small-control-font get-hinting)))
     (set! tooltip-font ans)
     ans]))

(define yellow-message%
  (class canvas%
    (inherit get-dc refresh get-client-size
             min-width min-height
             get-parent)


    (: labels (Listof (List String String)))
  the first string indicates the amount of leading space
  would require to draw . The second string is then actually drawn
    (define labels '(("" "")))

    (: set-lab (-> (Listof (List String String)) Void))
    (define/public (set-lab _ls)
      (unless (equal? labels _ls)
        (set! labels _ls)
        (update-size)
        (refresh)))
    (: update-size (-> Void))
    (define/private (update-size)
      (define dc (get-dc))
      (send dc set-font (get-tooltip-font))
      (define-values (w h)
                  ([space+label (in-list labels)])
          (define space (list-ref space+label 0))
          (define label (list-ref space+label 1))
          (define-values (space-w _1 _2 _3) (send dc get-text-extent space))
          (define-values (this-w this-h _4 _5) (send dc get-text-extent label))
          (values (max (+ space-w this-w) w)
                  (max this-h h))))
      (define parent (assert (get-parent)))
      (send parent begin-container-sequence)
      (min-width (+ 5 (exact-ceiling w)))
      (min-height (+ 5 (* (length labels) (exact-ceiling h))))
      (send parent end-container-sequence)
      (send parent reflow-container))

    (define font-size-callback (λ (p v) (set! tooltip-font #f) (update-size)))
    (preferences:add-callback 'framework:standard-style-list:font-size
                              font-size-callback
                              #t)
    
    (define/override (on-paint)
      (define dc (get-dc))
      (send dc set-font (get-tooltip-font))
      (define-values (w h) (get-client-size))
      (define-values (_1 th _2 _3) (send dc get-text-extent "yX"))
      (send dc set-pen "black" 1 'transparent)
      (send dc set-brush "LemonChiffon" 'solid)
      (send dc set-pen "black" 1 'solid)
      (send dc draw-rectangle 0 0 w h)
      (for ([space+label (in-list labels)]
            [i (in-naturals)])
        (define space (list-ref space+label 0))
        (define label (list-ref space+label 1))
        (define-values (space-w _1 _2 _3) (send dc get-text-extent space #f 'grapheme))
        (send dc draw-text label (+ 2 space-w) (+ 2 (* i th)) 'grapheme)))
    (super-new [stretchable-width #f] [stretchable-height #f])))

(define tooltip-frame%
  (class frame%
    (inherit reflow-container move get-width get-height is-shown?)
    
    (: timer (Option (Instance Timer%)))
    (define timer
      (let ([frame-to-track frame-to-track])
        (and frame-to-track
             (new timer%
                  [notify-callback
                   (λ ()
                     (unless (send frame-to-track is-shown?)
                       (show #f)
                       (send (assert timer) stop)))]))))
    
    
    (define/override (on-subwindow-event r evt)
      (and (is-shown?)
           (begin (show #f)
                  #t)))
    
    (: set-tooltip (-> (Listof String) Void))
    (define/public (set-tooltip ls)
      (define broken-up-lines
        (apply
         append
           (strings->strings+spacers (regexp-split #rx"\n" str)))))
      (send yellow-message set-lab broken-up-lines))
    
    (define/override (show on?)
      (when timer
        (cond
          [on? (send timer start 200 #f)]
          [else (send timer stop)]))
      (super show on?))

    (: show-over (-> Integer Integer Integer Integer [#:prefer-upper-left? Any] Void))
    (define/public (show-over x y w h #:prefer-upper-left? [prefer-upper-left? #f])
      (reflow-container)
      (define mw (get-width))
      (define mh (get-height))
      (define (upper-left must?)
        (define the-x (- x mw))
        (define the-y (- y mh))
        (if must?
            (move the-x the-y)
            (try-moving-to the-x the-y mw mh)))
      (define (lower-right must?)
        (define the-x (+ x w))
        (define the-y (+ y h))
        (if must?
            (move the-x the-y)
            (try-moving-to the-x the-y mw mh)))
      (if prefer-upper-left?
          (or (upper-left #t) (lower-right #f) (upper-left #t))
          (or (lower-right #t) (upper-left #f) (lower-right #t)))
      (show #t))
    
    (: try-moving-to (Integer Integer Integer Integer -> Boolean))
    (define/private (try-moving-to x y w h)
             (define-values (mx my) (get-display-left-top-inset #:monitor m))
             (define-values (mw mh) (get-display-size #:monitor m))
             (and mx my mw mh
                  (<= (- mx) x (+ x w) (+ (- mx) mw))
                  (<= (- my) y (+ y h) (+ (- my) mh))))
           (begin (move x y)
                  #t)))

    (super-new [style '(no-resize-border no-caption float)]
               [label ""]
               [parent frame-to-track]
               [stretchable-width #f]
               [stretchable-height #f])
    (: yellow-message (Object [set-lab ((Listof (List String String)) -> Void)]))
    (define yellow-message (new yellow-message% [parent this]))))


(: strings->strings+spacers (-> (Listof String) (Listof (List String String))))
(define (strings->strings+spacers strs)
  (let loop ([strs strs]
             [prefix ""])
    (cond
      [(null? strs) '()]
      [else
       (define str (car strs))
       (define leading-spaces (car (assert (regexp-match #rx"^ *" str))))
       (define this-entry
         (cond
           [(<= (string-length prefix) (string-length leading-spaces))
            (list prefix (substring str (string-length prefix) (string-length str)))]
           [else
            (list (substring prefix 0 (string-length leading-spaces))
                  (substring str (string-length leading-spaces) (string-length str)))]))
       (define new-prefix
         (cond
           [(< (string-length prefix) (string-length leading-spaces))
            prefix]
           [else
            (string-append (substring prefix 0 (string-length leading-spaces))
                           (substring str (string-length leading-spaces) (string-length str)))]))
       (cons this-entry (loop (cdr strs) new-prefix))])))


(module+ test
  (require rackunit)
  (check-equal? (strings->strings+spacers '()) '())
  (check-equal? (strings->strings+spacers '("x")) '(("" "x")))
  (check-equal? (strings->strings+spacers '("x" "x")) '(("" "x") ("" "x")))
  (check-equal? (strings->strings+spacers '("xx" " x")) '(("" "xx") ("x" "x")))
  (check-equal? (strings->strings+spacers '("abcdef"
                                            " pqrst"
                                            "  ijkl"
                                            "   mno"))
                '(("" "abcdef")
                  ("a" "pqrst")
                  ("ap" "ijkl")
                  ("api" "mno")))
  (check-equal? (strings->strings+spacers '("abcdef"
                                            " pqrst"
                                            "  ijkl"
                                            " mnozz"))
                '(("" "abcdef")
                  ("a" "pqrst")
                  ("ap" "ijkl")
                  ("a" "mnozz")))
  (check-equal? (strings->strings+spacers '("abcdef"
                                            " pqrst"
                                            " mnozz"
                                            "  ijkl"))
                '(("" "abcdef")
                  ("a" "pqrst")
                  ("a" "mnozz")
                  ("am" "ijkl")))
  (check-equal? (strings->strings+spacers '("abcdef"
                                            " pqrst"
                                            "  ijkl"
                                            "  mnoz"))
                '(("" "abcdef")
                  ("a" "pqrst")
                  ("ap" "ijkl")
                  ("ap" "mnoz")))
  (check-equal? (strings->strings+spacers '("   def"
                                            "abcxyz"))
                '(("" "   def")
                  ("" "abcxyz")))
  (check-equal? (strings->strings+spacers '("abcdef"
                                            "   xyz"
                                            "           pqrstuv"))
                '(("" "abcdef")
                  ("abc" "xyz")
                  ("abcxyz" "     pqrstuv"))))


(module+ main
  (require racket/gui/base)
  (define c%
    (class canvas%
      (inherit get-client-size client->screen)
      (: state (U False 'left 'right))
      (define state #f)
      (define/override (on-event evt)
        (define-values (w h) (get-client-size))
        (define new-state
          (cond
            [(not (<= 0 (send evt get-y) h)) #f]
            [(<= 0 (send evt get-x) (/ w 2))
             'left]
            [(<= (/ w 2) (send evt get-x) w)
             'right]
            [else
             #f]))
        (unless (equal? new-state state)
          (define old-state state)
          (set! state new-state)
          (send tooltip-frame show #f)
          (when state
            (send tooltip-frame set-tooltip
                  (case state
                    [(left) '("abcdef\n  ghij\n  klmn\n    op\n     q")]
                    [(right) '("right")]
                    [else '("whatever")]))
            (define-values (sx sy) (client->screen 10 10))
            (send tooltip-frame show-over sx sy 10 10))))
      (super-new)
      (define tooltip-frame (new tooltip-frame%))))
  (define f (new frame% [label ""] [width 200] [height 200]))
  (define c (new c% [parent f]))
  (send f show #t))
