;;; -*- Mode:LISP; Package:MAC; Base:10; Readtable:ZL -*-
;;;
;;;  Keyboard and Mouse descriptor
;;;



(defconst  KEYBOARD-EVENT  0)
(defconst  MOUSE-EVENT     1)



(defun share-kbd-hardware-char-available ()
  (let ((struct (kbd-mouse-descriptor Header-Table)))
    (and (not (equal (kbd-buffer-input  struct)
		     (kbd-buffer-output struct)))
	 (= KEYBOARD-EVENT (ldb (byte 8 24.) (kbd-entry-type-modifiers (kbd-buffer-input struct)))))))

(defun share-kbd-get-hardware-char ()
  (let* ((struct (kbd-mouse-descriptor Header-Table))
	 (input-ptr  (kbd-buffer-input  struct))
	 (output-ptr (kbd-buffer-output struct))
	 (start-ptr  (kbd-buffer-start  struct))
	 (end-ptr    (kbd-buffer-end    struct)))
    (if (or (= input-ptr output-ptr)
	    ( KEYBOARD-EVENT (ldb (byte 8 24.) (kbd-entry-type-modifiers  input-ptr))))
	(ferror "No characters in the share ring buffer!!!")
      (prog1 (kbd-entry-char-or-mouse input-ptr)
	(incf input-ptr 8)
	(setf (kbd-buffer-input struct)
	      (if (= input-ptr end-ptr) start-ptr input-ptr))))))



;
;   Mouse process
;


(defvar *end-mouse-process* nil)

(defun stop-mouse ()
  (setq *end-mouse-process* t))


(defun start-mouse-process ()
  (setq *end-mouse-process* nil)
  (process-run-function "mac-mouse"
    #'(lambda ()
	(loop with struct = (kbd-mouse-descriptor Header-Table)
	      while (not *end-mouse-process*) do
	  (process-sleep 1)
	  (setq si:mouse-x (kbd-mouse-x struct)
		si:mouse-y (kbd-mouse-y struct))))))



(comment
(defun si:kbd-hardware-char-available ()
  (or ( (%p-ldb %%q-pointer (+ 500 %unibus-channel-buffer-in-ptr))
	 (%p-ldb %%q-pointer (+ 500 %unibus-channel-buffer-out-ptr)))
      (and (equal Falcon-version-number (falcon-protocol-version Header-Table))
	   (share-kbd-hardware-char-available))))

(defun si:kbd-get-hardware-char (&aux p)
  "Returns the next character in the microcode interrupt buffer, and NIL if there is none"
  (if ( (%p-ldb %%q-pointer (+ 500 %unibus-channel-buffer-in-ptr))
	 (setq p (%p-ldb %%q-pointer (+ 500 %unibus-channel-buffer-out-ptr))))
    (prog1 (%p-ldb %%q-pointer p)
	   (incf p)
	   (when (= p (%p-ldb %%q-pointer (+ 500 %unibus-channel-buffer-end)))
	     (setq p (%p-ldb %%q-pointer (+ 500 %unibus-channel-buffer-start))))
	   (%p-dpb p %%q-pointer (+ 500 %unibus-channel-buffer-out-ptr)))
    (and (equal Falcon-version-number (falcon-protocol-version Header-Table))
	 (share-kbd-hardware-char-available)
	 (share-kbd-get-hardware-char))))

)


(defun falcon ()
  (let ((*standard-input* (make-instance 'key-stream))
	(*standard-output* (make-instance 'ascii-stream)))
    (loop while t (print (eval (read))))))



(defflavor key-stream
	 ()
	(si:input-stream))

(defmethod (key-stream :tyi) ()
  (or (share-kbd-hardware-char-available)
      (process-wait "Keyboard"
		    #'(lambda () (share-kbd-hardware-char-available))))
  (share-kbd-get-hardware-char))