#lang scheme/gui
(provide tray% make-icon)
(require ffi/unsafe)

(define-cstruct _point
  ((x _int)
   (y _int)))
(define pt (make-point 0 0))

(define sym-icon
  '((app . 32512)
    (err . 32513)
    (quest . 32514)
    (warning . 32515)
    (inform . 32516)
    (winlogo . 32517)
    (blank . 32518)))

(define tray-frame%
  (class frame%
    (init-field callback sender)
    (define/override (on-activate act)
      (let ([x (ffi-mouse)])
        (when x (callback sender x))))
    (define/public (new-callback clb) (set! callback clb))
    (super-new
     (label "Tray frame"))))

(define shell32 (ffi-lib "shell32.dll"))
(define user32 (ffi-lib "user32.dll"))

(define old-m-pos (cons -100 -100))

(define m-count 0);calc entering for emulate r-burron

(define (ffi-mouse)
  ((get-ffi-obj 'GetCursorPos user32 (_fun _pointer -> _void)) pt)
  (let ([pos (cons (ptr-ref pt _int 0) (ptr-ref pt _int 1))]
        [key (map not 
                  (map zero? 
                       (map (get-ffi-obj 'GetAsyncKeyState user32 (_fun _int -> _int))
                            '(1 2 4))))])
    (if (and (equal? old-m-pos pos) (equal? key '(#f #f #f)))
        (if (equal? m-count 2)
            (begin (set! m-count 0)
                   (new mouse-event%
                        [event-type 'enter]
                        [x (car pos)]
                        [y (cdr pos)]
                        [right-down #t]));bag of r-button
            (begin (set! m-count (add1 m-count)) #f))
        (begin
          (set! m-count 0)
          (when (not (equal? old-m-pos pos))
            (set!-values (old-m-pos key) (values pos '(#f #f #f))))
          (new mouse-event%
               [event-type 'enter]
               [x (car pos)]
               [y (cdr pos)]
               [left-down (car key)]
               [right-down (cadr key)]
               [middle-down (caddr key)])))))

(define (make-icon path)
  ((get-ffi-obj 'LoadImageA user32 (_fun _int _pointer _int _int _int _int -> _int))
   0 (bytes-append (string->bytes/utf-8 path) #"\0") 1 0 0 16))

(define tray%
  (class object%
    (init-field
     (label "")
     (icon 32516)
     (callback (lambda (snd ev) '())))
    (define show-flag #f)
    (define (reset-icon)
      (when (symbol? icon)
        (let ([ret (assoc icon sym-icon)])
          (set! icon (if ret (cdr ret) 32516)))))
    (reset-icon)
    (define timer (new timer%
                       [interval 5000]
                       [notify-callback
                        (lambda ()
                          '())]))
    
    (define tray (list->bytes (make-list 88 0)))
    (define (change-setting)
      ((get-ffi-obj 'Shell_NotifyIconA  shell32 (_fun _int _pointer -> _void)) 1 tray))
    (define/public (show x)
      (set! show-flag (not (not x)))
      (if x
          (send timer start 5000)
          (send timer stop))
      (if x
          ((get-ffi-obj 'Shell_NotifyIconA  shell32 (_fun _int _pointer -> _void)) 0 tray)
          ((get-ffi-obj 'Shell_NotifyIconA shell32 (_fun _int _pointer -> _void)) 2 tray)))
    (define/public (is-shown?) show-flag)
    (define/public (get-icon) (if (and (> icon 32511) (< icon 32519))
                                  (cdr (assoc icon (map (lambda (x) (cons (cdr x) (car x))) sym-icon)))
                                  icon))
    (define/public (set-icon ic) (set! icon ic) (reset-icon) (update-tray) (change-setting))
    (define/public (get-label) label)
    (define/public (set-label lb) (set! label lb) (update-tray) (change-setting))
    (define/public (new-callback x) (send tray-frame new-callback x))
    (super-new)
    (define tray-frame (new tray-frame%
                            [sender this]
                            [callback callback]))
    (define (update-tray) 
      (map (lambda (x y) (ptr-set! tray _int x y))
           '(0 1 2 3 4 5)
           (list 100 (send tray-frame get-handle) 1 7 6 
                 (if (and (> icon 32511) (< icon 32519))
                     ((get-ffi-obj 'LoadIconA user32 (_fun _int _int -> _int)) 0 icon)
                     icon)))
      (let ([label (bytes-append (string->bytes/utf-8 label) #"\0")])
        (bytes-copy! tray 24 (if (> (bytes-length label) 63) (subbytes label 63) label))))
    (update-tray)))