;;; event.scm: user-interface auto-test functions (see snd-test.scm)

(provide 'snd-event.scm)

(if (not (provided? 'xm))
    (let ((hxm (dlopen "xm.so")))
      (if (string? hxm)
	  (snd-error (format #f "event.scm needs the xm module: ~A" hxm))
	  (dlinit hxm "Init_libxm"))))


(define key-event
  (let ((e (XEvent KeyPress))
	(cast-current-time (list 'Time CurrentTime)))
    (lambda (widget key state)
      (let ((dpy (XtDisplay widget))
	    (window (XtWindow widget)))
	(set! (.type e) KeyPress)
	(set! (.window e) window)
	(set! (.display e) dpy)
	(set! (.root e) (RootWindow dpy (DefaultScreen dpy)))
	(set! (.x e) 0)
	(set! (.y e) 0)
	(set! (.x_root e) 0)
	(set! (.y_root e) 0)
	(set! (.keycode e) (XKeysymToKeycode dpy (list 'KeySym key)))
	(set! (.state e) state)
	(set! (.time e) cast-current-time)
	(set! (.same_screen e) #t)
	(set! (.subwindow e) (list 'Window None))
	(let ((err (XSendEvent dpy window #f KeyPressMask e)))
	  (if (not (= err 0))
	      (begin
		(set! (.time e) cast-current-time)
		(set! (.type e) KeyRelease)
		(set! err (XSendEvent dpy window #f KeyReleaseMask e))))
	  (if (= err 0)
	      (display (format #f "[key-event error] " err)))
	  err)))))
    
;;; (key-event (car (channel-widgets)) (char->integer #\a) 4)

(define key-event-with-mouse
  (let ((e (XEvent KeyPress))
	(cast-current-time (list 'Time CurrentTime)))
    (lambda (widget key state x y)
      (let ((dpy (XtDisplay widget))
	    (window (XtWindow widget)))
	(set! (.type e) KeyPress)
	(set! (.window e) window)
	(set! (.display e) dpy)
	(set! (.root e) (RootWindow dpy (DefaultScreen dpy)))
	(set! (.x e) x)
	(set! (.y e) y)
	(set! (.x_root e) x)
	(set! (.y_root e) y)
	(set! (.keycode e) (XKeysymToKeycode dpy (list 'KeySym key)))
	(set! (.state e) state)
	(set! (.time e) cast-current-time)
	(set! (.same_screen e) #t)
	(set! (.subwindow e) (list 'Window None))
	(let ((err (XSendEvent dpy window #f KeyPressMask e)))
	  (if (not (= err 0))
	      (begin
		(set! (.time e) cast-current-time)
		(set! (.type e) KeyRelease)
		(set! err (XSendEvent dpy window #f KeyReleaseMask e))))
	  (if (= err 0)
	      (display (format #f "[key-event error] " err)))
	  err)))))

(define resize-event
  (let ((e (XEvent ResizeRequest)))
    (lambda (widget width height)
      (let ((dpy (XtDisplay widget))
	    (window (XtWindow widget)))
	(set! (.window e) window)
	(set! (.display e) dpy)
	(set! (.width e) width)
	(set! (.height e) height)
	(XSendEvent dpy window #f ResizeRedirectMask e)))))

(define enter-event
  (let ((e (XEvent EnterNotify)))
    (lambda (widget)
      (let ((dpy (XtDisplay widget))
	    (window (XtWindow widget)))
	(set! (.window e) window)
	(set! (.display e) dpy)
	(XSendEvent dpy window #f EnterWindowMask e)))))

(define leave-event
  (let ((e (XEvent LeaveNotify)))
    (lambda (widget)
      (let ((dpy (XtDisplay widget))
	    (window (XtWindow widget)))
	(set! (.window e) window)
	(set! (.display e) dpy)
	(XSendEvent dpy window #f LeaveWindowMask e)))))

(define expose-event
  (let ((e (XEvent Expose)))
    (lambda (widget x y width height)
      (let ((dpy (XtDisplay widget))
	    (window (XtWindow widget)))
	(set! (.window e) window)
	(set! (.display e) dpy)
	(set! (.width e) width)
	(set! (.height e) height)
	(set! (.x e) x)
	(set! (.y e) y)
	(set! (.count e) 0)
	(XSendEvent dpy window #f ExposureMask e)))))

(define click-event
  (let ((e (XEvent ButtonPress)))
    (lambda (widget button state x y)
      (let ((dpy (XtDisplay widget))
	    (window (XtWindow widget)))
	(set! (.type e) ButtonPress)
	(set! (.window e) window)
	(set! (.display e) dpy)
	(set! (.root e) (RootWindow dpy (DefaultScreen dpy)))
	(set! (.x e) x)
	(set! (.y e) y)
	(set! (.x_root e) 0)
	(set! (.y_root e) 0)
	(set! (.state e) state)
	(set! (.button e) button)
	(set! (.time e) (list 'Time CurrentTime))
	(set! (.same_screen e) #t)
	(set! (.subwindow e) (list 'Window None))
	(let ((err (XSendEvent dpy window #f ButtonPressMask e)))
	  (if (not (= err 0))
	      (begin
		(set! (.time e) (list 'Time CurrentTime))
		(set! (.type e) ButtonRelease)
		(set! err (XSendEvent dpy window #f ButtonReleaseMask e))))
	  (if (= err 0)
	      (display (format #f "[click-event error] " err)))
	  err)))))


(define drag-event
  (let ((e (XEvent ButtonPress))
	(e1 (XEvent MotionNotify)))
    (lambda (widget button state x0 y0 x1 y1)
      (let ((dpy (XtDisplay widget))
	    (window (XtWindow widget)))
	(set! (.type e) ButtonPress)
	(set! (.window e) window)
	(set! (.display e) dpy)
	(set! (.root e) (RootWindow dpy (DefaultScreen dpy)))
	(set! (.x e) x0)
	(set! (.y e) y0)
	(set! (.x_root e) 0)
	(set! (.y_root e) 0)
	(set! (.state e) state)
	(set! (.button e) button)
	(set! (.time e) (list 'Time CurrentTime))
	(set! (.same_screen e) #t)
	(set! (.subwindow e) (list 'Window None))
	(let ((err (XSendEvent dpy window #f ButtonPressMask e)))
	  (if (not (= err 0))
	      (begin
		(set! (.window e1) window)
		(set! (.display e1) dpy)
		(set! (.root e1) (RootWindow dpy (DefaultScreen dpy)))
		;(set! (.x e1) x1)
		;(set! (.y e1) y1)
		(set! (.x_root e1) x0)
		(set! (.y_root e1) y0)
		(set! (.state e1) state)
		(set! (.time e1) (list 'Time (+ 300 CurrentTime)))
		(set! (.same_screen e1) #t)
		(set! (.subwindow e1) (list 'Window None))
		(set! (.is_hint e1) NotifyNormal)
		(let* ((den (if (or (> (abs (- x1 x0)) 10)
				    (> (abs (- y1 y0)) 10))
				10
				2))
		       (xdiff (inexact->exact (floor (/ (- x1 x0) den))))
		       (ydiff (inexact->exact (floor (/ (- y1 y0) den)))))
		  (do ((xn (+ x0 xdiff) (+ xn xdiff))
		       (yn (+ y0 ydiff) (+ yn ydiff))
		       (i 0 (1+ i)))
		      ((= i den))
		    (set! (.x e1) xn)
		    (set! (.y e1) yn)
		    (XSendEvent dpy window #f ButtonMotionMask e1)))
		(set! (.type e) ButtonRelease)
		(set! (.time e) (list 'Time (+ 500 CurrentTime)))
		(set! (.x e) x1)
		(set! (.y e) y1)
		(XSendEvent dpy window #f ButtonReleaseMask e))))))))

(define (select-item wid pos)
  (if (not (XmIsList wid))
      (display (format #f "~A is not a list" (XtName wid)))
      (XmListSelectPos wid (+ pos 1) #t)))

(define* (click-button button #:optional value bits)
  (if (Widget? button)
      (if (XtIsSensitive button)
	  (if (or (XmIsPushButton button)
		  (XmIsPushButtonGadget button))
	      (if (= (XtHasCallbacks button XmNactivateCallback) XtCallbackHasSome)
		  (XtCallCallbacks button XmNactivateCallback 
				   (let ((but (XmPushButtonCallbackStruct)))
				     (set! (.click_count but) 0)
				     (set! (.event but) 
					   (let ((e (XEvent ButtonPress)))
					     (set! (.state e) (or bits 0))
					     e))
				     but))
		  (display (format #f 
				   ";pushbutton ~A has no activate callbacks~%" 
				   (XtName button))))
	      (if (or (XmIsToggleButton button)
		      (XmIsToggleButtonGadget button))
		  (if (= (XtHasCallbacks button XmNvalueChangedCallback) XtCallbackHasSome)
		      (XtCallCallbacks button XmNvalueChangedCallback 
				       (let ((tgl (XmToggleButtonCallbackStruct)))
					 (set! (.set tgl) value)
					 (set! (.event tgl) 
					       (let ((e (XEvent ButtonPress)))
						 (set! (.state e) (or bits 0))
						 e))
					 tgl))
		      (display (format #f 
				       ";togglebutton ~A has no valueChanged callbacks~%" 
				       (XtName button))))
		  (if (XmIsArrowButton button)
		      (if (= (XtHasCallbacks button XmNactivateCallback) XtCallbackHasSome)
			  (XtCallCallbacks button XmNactivateCallback
					   (let ((arr (XmArrowButtonCallbackStruct)))
					     (set! (.click_count arr) 0)
					     (set! (.event arr) 
						   (let ((e (XEvent ButtonPress)))
						     (set! (.state e) (or bits 0))
						     e))
					     arr))
			  (display (format #f 
					   ";arrowbutton ~A has no activate callbacks~%" 
					   (XtName button))))
		      (display (format #f 
				       ";~A (~A) is not a push or toggle button~%" 
				       (XtName button) (XtName (XtParent button)))))))
	  (display (format #f 
			   ";~A is not sensitive~%" 
			   (XtName button))))
      (display (format #f 
		       ";~A is not a widget~%" 
		       button))))

(define (resize-pane wid height)
  (XtUnmanageChild wid)
  (XtVaSetValues wid (list XmNpaneMinimum (if (> height 5) (- height 5) 0)
			   XmNpaneMaximum (+ height 5)))
  (XtManageChild wid)
  (XtVaSetValues wid (list XmNpaneMinimum 5
			   XmNpaneMaximum 1000)))

(define (force-event)
  (let ((app (car (main-widgets)))
	(done #f))
    (do ()
	(done)
      (let ((msk (XtAppPending app)))
	(if (= (logand msk (logior XtIMXEvent XtIMAlternateInput)) 0)
	    (set! done #t)
	    (XtDispatchEvent (XtAppNextEvent app)))))))
	      
(define (take-keyboard-focus wid)
  (if (and (XmIsTraversable wid)
	   (not (= (XmGetVisibility wid) XmVISIBILITY_FULLY_OBSCURED)))
      (XmProcessTraversal wid XmTRAVERSE_CURRENT)))

(define (move-scale scl val)
  (XmScaleSetValue scl val)
  (XtCallCallbacks scl XmNvalueChangedCallback
    (let ((cb (XmScaleCallbackStruct)))
      (set! (.value cb) val)
      (set! (.event cb) (XEvent))
      cb)))


(define (change-prop winat name command)
  (define (find-window dpy top natom)
    (let ((res (XGetWindowProperty dpy top natom 0 1024 #f XA_STRING)))
      (if (and (= (car res) Success) 
	       (not (equal? (cadr res) (list 'Atom None))))
	  top
	  (let ((vals (XQueryTree dpy top)))
	    (if (= (car vals) 0)
		#f
		(call-with-current-continuation
		 (lambda (return)
		   (for-each 
		    (lambda (win)
		      (let ((val (find-window dpy win natom)))
			(if (Window? val)
			    (return val))))
		    (list-ref vals 3)))))))))
  (let* ((dpy (XtDisplay (cadr (main-widgets))))
	 (natom (XInternAtom dpy winat #f))
	 (window (find-window dpy (DefaultRootWindow dpy) natom)))
    (if (Window? window)
	(begin
	  (XChangeProperty dpy window (XInternAtom dpy name #f) XA_STRING 8 PropModeReplace command)
	  (XFlush dpy)
	  command)
	#f)))

(define beep-state
  (make-procedure-with-setter
   (lambda ()
     ;; returns amp pitch duration
     (let ((vals (XGetKeyboardControl (XtDisplay (cadr (main-widgets))))))
       (list (list-ref vals 1) (list-ref vals 2) (list-ref vals 3))))
   (lambda (lst) 
     ; amp pitch dur
     ; (set! (beep-state) (list 100 200 100))
     (XChangeKeyboardControl 
       (XtDisplay (cadr (main-widgets)))
       (logior KBBellPercent KBBellPitch KBBellDuration)
       (cons 0 lst)))))

(define (beep)
  (XBell (XtDisplay (cadr (main-widgets))) 100))