Commits

Paul Sexton committed 75a9d8e

Mouse movement now generates <Mouse-Move-Event> events, via
'send-mouse-move-event'.

A distinction is now drawn between 'raising' and 'unhiding' windows.
'raise-window' raises a visible window to the top, but causes an error if
called on a hidden window. 'unhide-window' unhides a hidden window and then
raises it.

Events now cannot be sent to hidden windows (more precisely, they have no
effect on such windows).

New utility function 'string->key': given a string representing a key press,
return the equivalent tcod:key structure. For example, "^x" or "C-x" represent
control+x, "shift-alt-F1" or "S-M-F1" represent shift+alt+F1, et cetera.

Log windows have a new boolean slot 'window-use-borders?'. If non-nil then the
entire window, including its borders (line 0, column 0 and so on) will be
used to display window contents.

'in-view?' renamed to 'in-viewport-bounds?'.

Comments (0)

Files changed (3)

 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; coding: utf-8-unix -*- ;;;;;;;;80
 
-(defpackage #:dormouse-system
-	(:use #:cl #:asdf))
 
-(in-package #:dormouse-system)
-
-(defsystem dormouse
+(asdf:defsystem "dormouse"
     :description "GUI module for libtcod, a truecolour console library."
     :author "Paul Sexton <eeeickythump@gmail.com>"
     :components
     ((:file "dormouse"))
-    :depends-on ("tcod" "iterate" "alexandria" "cl-ppcre"))
+    :depends-on ("tcod"
+                 "iterate"
+                 "alexandria"
+                 "cl-ppcre"))
+
+
+;;;; dormouse.asd ends here ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
            #:<GUI-Event>
            #:<Key-Event>
            #:<Mouse-Event>
+           #:<Mouse-Move-Event>
            #:<Mouse-Hover-Event>
            #:<Mouse-Double-Click-Event>
            #:<GUI-Dialog-Event>
            #:key-pressed-event?
            #:mouse-drag
            #:key->string
+           #:string->key
            #:<Window-Theme>
            #:*window-theme*
            #:<Window>
            #:<Window-With-Context-Menu>
            #:get-menu-items-for-context
            #:command-from-context-menu
+           #:ok-to-show-tooltip?
            #:tooltip-text
+           #:floating-window-foreground
+           #:floating-window-background
            #:calculate-floating-window-width
            #:<Dialog-Window>
            #:button
            #:window-draw-char-at  ;;
            #:draw-string-at  ;;
            #:format-at  ;;
+           #:window-use-borders?
            #:add-item  ;;
            #:window-items
            #:window-items-lines
            #:map-char-at
            #:map-set-foreground-at   ;; if visible
            #:map-set-background-at   ;; if visible
-           #:in-view?
+           #:in-viewport-bounds?
            #:centre-viewport-on   ;;
            #:window-foreground
            #:window-background
            #:view-bry
            #:viewport-width
            #:viewport-height
-           #:in-view?
            #:in-viewport-map?
            #:winx->mapx
            #:winy->mapy
            #:winy->rooty
            #:rootx->winx
            #:rooty->winy
+           #:window-transparency
+           #:window-transparency-unfocussed
            #:bar-chart
            ))
 
 * Returns: None.
 * Description: Internal function, called by {defun dormouse:main-gui-loop}
 when the user uses the mouse to resize a window."))
-(defgeneric raise-window (win &key redraw &allow-other-keys)
+(defgeneric raise-window (win &key redraw simple-redraw? &allow-other-keys)
   (:documentation
    "* Arguments:
 - WIN: an instance of {defclass dormouse:<Window>}
 * Examples:
 ;;; (hide-window mywin :redraw t)
 * See Also: "))
+(defgeneric unhide-window (win &key redraw simple-redraw? &allow-other-keys)
+  (:documentation
+   "* Arguments:
+- WIN: an instance of <Window>
+- REDRAW: boolean value indicating whether the area of the screen occupied
+by the window should be redrawn.
+* Returns: None.
+* Description: Unhide the hidden window WIN, and raise it to the top of
+the window stack.
+* Examples:
+* See Also: "))
 (defgeneric send-to-window (win event)
   (:documentation "* Arguments:
 - WIN: an instance of [[<Window>]]
 list of strings, which can contain colour fields.  Each string can be an
 arbitrary length, as they are treated as separate messages by the floating
 window."))
+(defgeneric in-viewport-bounds? (win mapx mapy))
 (defgeneric copy-map-to-viewport (win)
   (:documentation "TODO document."))
 (defgeneric clear-map (win &key redraw &allow-other-keys)
 layout of the [[*default font file*]]. Can be either a single keyword, or a
 list of keywords.")
 
+(defvar *gui-initialised?* nil)
 (defvar *window-stack* (list)
   "Stack (list) of all existing non-hidden windows. The 'topmost' window is at
 the top of the stack.")
             (gui-event-winx event) (gui-event-winy event))))
 
 
+(defclass <Mouse-Move-Event> (<Mouse-Event>)
+  ((gui-event-type :initform :mouse-move)))
+
+
 (defclass <Mouse-Double-Click-Event> (<Mouse-Event>)
   ((gui-event-type :initform :mouse-double-click)))
 
                   (format nil "~A" (key-vk k))))))
 
 
+
+(defparameter *keycode->string-alist*
+  '((:escape "escape" "esc")
+    (:backspace "backspace")
+    (:tab "tab")
+    (:enter "enter" "return" "ret")
+    (:pause "pause")
+    (:capslock "capslock")
+    (:pageup "pageup" "pgup")
+    (:pagedown "pagedown" "pgdown" "pagedn" "pgdn")
+    (:end "end")
+    (:home "home")
+    (:up "up")
+    (:left "left")
+    (:right "right")
+    (:down "down")
+    (:printscreen "printscreen" "prtscr" "printscr" "prtscrn")
+    (:insert "insert" "ins")
+    (:delete "delete" "del")
+    (:lwin "lwin" "lwindows")
+    (:rwin "rwin" "rwindows")
+    (:apps "apps")
+    (:kp0 "keypad0" "kp0" "numpad0" "np0")
+    (:kp1 "keypad1" "kp1" "numpad1" "np1")
+    (:kp2 "keypad2" "kp2" "numpad1" "np2")
+    (:kp3 "keypad3" "kp3" "numpad1" "np3")
+    (:kp4 "keypad4" "kp4" "numpad1" "np4")
+    (:kp5 "keypad5" "kp5" "numpad1" "np5")
+    (:kp6 "keypad6" "kp6" "numpad1" "np6")
+    (:kp7 "keypad7" "kp7" "numpad1" "np7")
+    (:kp8 "keypad8" "kp8" "numpad1" "np8")
+    (:kp9 "keypad9" "kp9" "numpad1" "np9")
+    (:kpadd "kpadd" "kp+" "keypadadd" "numpadadd" "numpad+" "np+")
+    (:kpsub "kpsub" "kpminus" "keypadsub" "numpadsub" "numpadminus" "npminus")
+    (:kpdiv "kpdiv" "kp/" "keypaddiv" "numpaddiv" "numpad/" "np/")
+    (:kpmul "kpmul" "kp*" "keypadmul" "numpadmul" "numpad*" "np*")
+    (:kpdec "kpdec" "kp." "keypaddec" "numpaddec" "numpad." "np.")
+    (:kpent "kpenter" "keypadenter" "numpadenter" "npenter")
+    (:f1 "f1")
+    (:f2 "f2")
+    (:f3 "f3")
+    (:f4 "f4")
+    (:f5 "f5")
+    (:f6 "f6")
+    (:f7 "f7")
+    (:f8 "f8")
+    (:f9 "f9")
+    (:f10 "f10")
+    (:f11 "f11")
+    (:f12 "f12")
+    (:numlock "numlock")
+    (:scrolllock "scrolllock")))
+
+
+(defun string->key (str)
+  "STR is a string describing a keypress.
+The string should contain zero or more modifiers followed by the base key,
+all separated by spaces or hyphens.
+
+The base key is either a single character, or a string contained
+in `*keycode->string-alist*' (which see). Note that the character '-' must
+be spelled out as 'minus', and the character ' ' must be spelled out
+as 'space' or 'SPC'.
+
+Order of modifiers is unimportant. Case is unimportant unless the base key
+is a letter.
+
+Recognised modifiers:
+  - Control, Ctrl, Ctl, C
+  - Alt, Meta, M
+  - Shift, S
+
+Examples: 'a', 'A', 'f1', 'Esc', 'Ctrl PgDn', 'ctrl alt M', 'C-x',
+'C-S-A-F12', 'shift-kp0'"
+  (let* ((parts (cl-ppcre:split "[- ]" str))
+         (modifiers (mapcar #'string-downcase (butlast parts)))
+         (base (last-elt parts))
+         (ch (cond
+               ((= 1 (length base)) (aref base 0))
+               ((string= base "minus") #\-)
+               ((or (string= base "space")
+                    (string= base "spc"))
+                #\space)
+               (t nil))))
+    (tcod:make-key :c (or ch #\nul)
+                   :vk (cond
+                         (ch
+                          (dormouse:character->vk ch))
+                         (t
+                          (iterate
+                            (with s = (string-downcase base))
+                            (for (vk . strings) in *keycode->string-alist*)
+                            (if (find s strings :test #'string=)
+                                (return vk))
+                            (finally
+                             (error "In key string ~S, unknown base key ~S"
+                                    str base)))))
+                   :pressed t
+                   :lalt (if (or (find "a" modifiers :test #'string=)
+                                 (find "alt" modifiers :test #'string=)
+                                 (find "m" modifiers :test #'string=)
+                                 (find "meta" modifiers :test #'string=))
+                             t nil)
+                   :lctrl (if (or (find "c" modifiers :test #'string=)
+                                  (find "ctrl" modifiers :test #'string=)
+                                  (find "ctl" modifiers :test #'string=)
+                                  (find "control" modifiers :test #'string=))
+                              t nil)
+                   :shift (cond
+                            ((or (find "s" modifiers :test #'string=)
+                                 (find "shift" modifiers :test #'string=))
+                             (if ch
+                                 (tcod-gui:character->shift ch)
+                                 t))
+                            (t nil)))))
+
+
 (let ((key-event nil))
   (defun send-key-to-window (win key winx winy)
     "Return non-nil if the key is handled, nil if not handled."
+    (assert (not (window-hidden? win)))
     (unless key-event
       (setf key-event (make-instance '<Key-Event>)))
     (setf (gui-event-keypress key-event) key
 
 
 (defclass <Window> ()
-  ((window-tlx :initform 0 :accessor window-tlx :type (or integer (member :centred))
+  ((window-tlx :initform 0 :accessor window-tlx
+               :type (or integer (member :centred))
                :initarg :tlx :documentation "X-coordinate of top left corner of
 the window. If a negative number is given, then the coordinate is calculated
 relative to the bottom right corner of the screen. If the value is :CENTRED,
 the window will be placed so it is centred horizontally on the screen.")
-   (window-tly :initform 0 :accessor window-tly :type (or integer (member :centred))
+   (window-tly :initform 0 :accessor window-tly
+               :type (or integer (member :centred))
                :initarg :tly :documentation "Y-coordinate of top left corner of
 the window. If a negative number is given, then the coordinate is calculated
 relative to the bottom right corner of the screen. If the value is :CENTRED,
 
 
 (defmethod send-to-window :around ((win <Window>) (event t))
-  (if (or (null (window-event-handler win))
-          (not (funcall (window-event-handler win) win event)))
-      (call-next-method)))
+  (cond
+    ((window-hidden? win)
+     nil)
+    ((or (null (window-event-handler win))
+         (not (funcall (window-event-handler win) win event)))
+     (call-next-method))))
 
 
 (defmethod dirty-window ((win <Window>))
         (root-width (console-get-width *root*))
         (root-height (console-get-height *root*)))
     ;; draw everything but the window
+    (assert (not (window-hidden? win)))
     (raise-window win)
     ;; Draw all windows but this one onto SCRATCH.
     ;; SCRATCH now represents ROOT "minus" WIN.
                            0 (- root-width width 1)))
       (setf tly (constrain (- (mouse-cy rodent) offsety)
                            0 (- root-height height 1)))
-      ;;(format t "~A ~A ~A ~A~%" tlx tly width height)
       (unless (and (= tlx (window-tlx win)) (= tly (window-tly win)))
         ;; copy saved win to root  at WIN's old position (erasing WIN)
         (console-blit *temp-con* 0 0
 (defmethod mouse-resize-window ((win <Window>) (rodent mouse))
   (let ((brx 0) (bry 0))
     ;; draw everything but the window
+    (assert (not (window-hidden? win)))
     (raise-window win)
     (copy-windows-to-console (remove win *window-stack*) *scratch*)
     ;; Save part of root console covered by WIN
       (console-flush))))
 
 
-(defmethod raise-window ((win <Window>) &key (redraw *auto-redraw*)
+(defmethod unhide-window ((win <Window>) &key (redraw *auto-redraw*)
                          (simple-redraw? nil) &allow-other-keys)
+  (assert (window-hidden? win))
   (setf *window-stack* (remove win *window-stack* :test #'equal))
   (setf *hidden-windows* (remove win *hidden-windows* :test #'equal))
   (setf (window-hidden? win) nil)
+  (push win *window-stack*)
   (window-changed! win)
+  (dirty-window win)
+  (raise-window win :redraw redraw :simple-redraw? simple-redraw?))
+
+
+(defmethod raise-window :around ((win <Window>) &key)
+  (assert (not (window-hidden? win)))
+  (call-next-method))
+
+
+(defmethod raise-window :before ((win <Window>) &key)
+  (when (window-changed? win)
+    (prepare-window win)))
+
+
+(defmethod raise-window ((win <Window>) &key (redraw *auto-redraw*)
+                                             (simple-redraw? nil)
+                                        &allow-other-keys)
+  (setf *window-stack* (remove win *window-stack* :test #'equal))
   (push win *window-stack*)
+  (window-changed! win)
   (dirty-window win)
   (when (window-children win)
     (dolist (child  (window-children win))
       (when (or (window-raise-children-with-parent? win)
                 (not (window-hidden? child)))
-      (raise-window child :redraw redraw :simple-redraw? simple-redraw?))))
+        (raise-window child :redraw redraw :simple-redraw? simple-redraw?))))
   (when redraw
     (if simple-redraw?
         (copy-window-to-console win *root*)
         (redraw-window-area win))))
 
 
-;;; XXX new
-(defmethod raise-window :before ((win <Window>) &key)
-  (when (window-changed? win)
-    (prepare-window win)))
-
-
-
 (defmethod hide-window ((win <Window>) &key (redraw *auto-redraw*))
   (when redraw
     (redraw-window-area win :draw-window nil))
 
 
 (defmethod raise-window ((win <Background-Window>) &key &allow-other-keys)
-  (unless (find win *window-stack* :test #'equal)
-    (push-end win *window-stack*)))
+  (let ((pos (position win *window-stack* :test #'equal)))
+    (cond
+      ((null pos)
+       (push-end win *window-stack*))
+      ((= pos (1- (length *window-stack*)))
+       nil)
+      (t
+       (setf *window-stack* (remove win *window-stack*))
+       (push-end win *window-stack*)))))
 
 
 
   ((window-items :accessor window-items :initform nil :type list)
    (window-offset :accessor window-offset :initform 0
                   :initarg :offset :type integer)
-   (window-cursor :accessor window-cursor :initform 0 :type integer))
+   (window-cursor :accessor window-cursor :initform 0 :type integer)
+   (window-use-borders? :initform nil :accessor window-use-borders?
+                        :type boolean))
   (:documentation
    "Window that displays a list of strings which can be scrolled.
 
 
 
 (defmethod window-page-length ((win <List-Window>))
-  (- (window-height win) 2))
+  (if (window-use-borders? win)
+      (window-height win)
+      (- (window-height win) 2)))
 
 
 (defmethod prepare-window :after ((win <List-Window>))
        when (and (<= 0 i (1- (length (window-items win))))
                  (nth i (window-items win)))
        do (draw-item-at win (nth i (window-items win))
-                        1 (1+ (- i offset))
+                        (if (window-use-borders? win) 0 1)
+                        (+ (- i offset) (if (window-use-borders? win) 0 1))
                         (= i (window-cursor win))))))
 
 
 
 (defmethod draw-item-at ((win <List-Window>) (item list-item) winx winy cursor?)
-  (let ((pagewidth (- (window-width win) 2)))
+  (let ((pagewidth (- (window-width win) (if (window-use-borders? win) 0 2))))
     (draw-string-at win
                     (format nil "~vA"
                             pagewidth
 (defmethod move-cursor-to ((win <List-Window>) (cursor integer))
   (let ((oldcursor (window-cursor win)))
     (setf (window-cursor win)
-          (constrain cursor 0 (max 0 (1- (length (window-items win))))))
+          (clamp cursor 0 (max 0 (1- (length (window-items win))))))
     (when (and (/= oldcursor (window-cursor win))
                (window-item-at-cursor win))
       (cursor-moved-to-item win (window-item-at-cursor win)))))
   (with-slots ((winx gui-event-winx) (winy gui-event-winy)
                (k gui-event-keypress)) event
     (when (key-pressed k)
-      (let ((pagelen (- (window-height win) 2))
+      (let ((pagelen (window-page-length win))
             (num-items (length (window-items win))))
         (case (key-vk k)
           (:up
 
 (defmethod move-cursor-to-end ((win <List-Window>))
   (let ((num-items (length (window-items win)))
-        (pagelen (- (window-height win) 2)))
+        (pagelen (window-page-length win)))
     (setf (window-offset win) (- num-items pagelen))
     (move-cursor-to win (1- num-items))
     ;;(constrain! (window-cursor win) 0 (max 0 (1- num-items)))
          ;; (warn "Menu - selected item ~S"
          ;;            (list-item-item
          ;;             (window-item-at-cursor win)))
-         (hide-window win)
          (send-to-window win (make-instance
                               '<GUI-Select-Event>
                               :focus (list-item-item (window-item-at-cursor win))
-                              :winx winx :winy winy)))))))
+                              :winx winx :winy winy))
+         (hide-window win))))))
 
 
 (defmethod send-to-window :after ((win <Menu-Window>) (event <Key-Event>))
                (window-item-at-cursor win)
                (list-item-hotkey (window-item-at-cursor win))
                (same-keys? k (list-item-hotkey (window-item-at-cursor win))))
-      (hide-window win)
       (send-to-window win (make-instance
                            '<GUI-Select-Event>
                            :focus (list-item-item (window-item-at-cursor win))
-                           :winx winx :winy winy)))))
+                           :winx winx :winy winy))
+      (hide-window win))))
 
 
 (defmethod send-to-window ((win <Menu-Window>) (event <GUI-Select-Event>))
         ((window-hidden? (context-menu win))
          (move-window-beside-mouse (context-menu win))
          (prepare-window (context-menu win))
-         (raise-window (context-menu win) :redraw t))
+         (unhide-window (context-menu win) :redraw t))
         (t
          (hide-window (context-menu win) :redraw t))))))
 
               (while (plusp (length str)))
               (for line = (subseq str 0 (min width (length str))))
               (setf str (subseq str (min width (length str))))
-              ;;(format t "~S ~S~%" line str)
               (if (find (code-char 1) line)
                   (setf line (concatenate
                               'string
 
 (defclass <Tooltip-Window> (<Dialog-Window>)
   ((window-raise-children-with-parent? :initform nil)
+   (floating-window-foreground :accessor floating-window-foreground
+                               :initform (window-foreground *window-theme*))
+   (floating-window-background :accessor floating-window-background
+                               :initform (window-background *window-theme*))
    (floating-window :accessor floating-window :initform nil))
   (:documentation
    "Window which displays floating 'tooltips' next to the mouse when hovering over
                        :tlx 0 :tly 0
                        :width (calculate-floating-window-width win)
                        :height 3
-                       :title "Tip" :foreground :white :background :dark-grey
+                       :title "Tip"
+                       :foreground (floating-window-foreground win)
+                       :background (floating-window-background win)
                        :window-owner win
                        :hidden? t))
   (push (floating-window win) (window-children win)))
            ((equal text (last-text (floating-window win)))
             (when (window-hidden? (floating-window win))
               (move-window-beside-mouse (floating-window win))
-              (raise-window (floating-window win) :simple-redraw? nil)))
+              (unhide-window (floating-window win) :simple-redraw? nil)))
            (t
             (unless (window-hidden? (floating-window win))
               (hide-window (floating-window win)))
             (prepare-window (floating-window win))
             ;; move the floating window to an appropriate spot beside the mouse
             (move-window-beside-mouse (floating-window win))
-            (raise-window (floating-window win) :simple-redraw? nil))))))))
+            (unhide-window (floating-window win) :simple-redraw? nil))))
+        (t                              ; not ok to show tooltip
+         (unless (window-hidden? (floating-window win))
+              (hide-window (floating-window win))))))))
 
 
 
   (+ (view-tly win) (1- (viewport-height win))))
 
 
-(defun in-view? (win mapx mapy)
-  "TODO document."
+(defmethod in-viewport-bounds? ((win <Viewport>) mapx mapy)
+  "Is the position (MAPX, MAPY) within the bounds of the viewport?"
   (and (<= (view-tlx win) mapx (view-brx win))
        (<= (view-tly win) mapy (view-bry win))))
 
                         :background-flag background-flag
                         :fg fg :bg bg)
   (dolist (w (cons win (window-map-shared win)))
-    (when (in-view? w mapx mapy)
+    (when (in-viewport-bounds? w mapx mapy)
       (console-blit (map-console win) mapx mapy
                     1 1
                     (window-console w)
   (assert (map-console win))
   (console-set-char-foreground (map-console win) mapx mapy colour)
   (dolist (w (cons win (window-map-shared win)))
-    (when (in-view? w mapx mapy)
+    (when (in-viewport-bounds? w mapx mapy)
       (console-blit (map-console win) mapx mapy
                     1 1
                     (window-console w)
   (assert (map-console win))
   (console-set-char-background (map-console win) mapx mapy colour :set)
   (dolist (w (cons win (window-map-shared win)))
-    (when (in-view? w mapx mapy)
+    (when (in-viewport-bounds? w mapx mapy)
       (console-blit (map-console win) mapx mapy
                     1 1
                     (window-console w)
         (console-new width height))     ; must be same size as ROOT
   (setf *scratch*
         (console-new width height))     ; must be same size as ROOT
-  (console-clear *root*))
+  (console-clear *root*)
+  (setf *gui-initialised?* t))
 
 
 (defun legal-window-coordinates? (win x y)
 (defvar *topwin* nil)
 (defvar *last-topwin* nil)
 (defvar *last-mouse-click-event* nil)
+(defvar *last-mouse-move-event* nil)
 (defvar *mouse-double-click-speed* 500
   "If two clicks occur with a delay of <= this many milliseconds between them,
 a double-click event is created.")
 
 
 
+(defun send-mouse-move-event (rodent)
+  (when-let (win (window-with-mouse-focus))
+    (unless *last-mouse-move-event*
+      (setf *last-mouse-move-event*
+            (make-instance '<Mouse-Move-Event>)))
+    (setf (gui-event-winx *last-mouse-move-event*)
+          (- *mouse-x* (window-tlx win)))
+    (setf (gui-event-winy *last-mouse-move-event*)
+          (- *mouse-y* (window-tly win)))
+    (setf (gui-event-mouse-state *last-mouse-move-event*) rodent)
+    (send-to-window win *last-mouse-move-event*)
+    *last-mouse-move-event*))
+
+
+
 (let ((mouse-hover-event (make-instance '<Mouse-Hover-Event>)))
   (defun main-gui-loop-aux ()
     (let ((k nil) (mouse nil))
       (process-windows)
       (when (or *exit-gui?*
                 (console-is-window-closed?))
-         (return-from main-gui-loop-aux nil))
+        (return-from main-gui-loop-aux nil))
       ;; Process all pending keyboard and mouse events
       (iterate
         (with events = (sys-get-events))
         (case event-type
           (:event-none nil)
           ;; === mouse movement and clicks ===
-          ((:event-mouse-move :event-mouse-press :event-mouse-release)
+          ((:event-mouse-move)
+           (setf *rodent* mouse
+                 *mouse-x* (mouse-cx mouse)
+                 *mouse-y* (mouse-cy mouse))
+           (setf *focus-changed?* (not (eql (window-with-mouse-focus)
+                                            *last-topwin*)))
+           (send-mouse-move-event mouse))
+          ((:event-mouse-press :event-mouse-release)
            (setf *rodent* mouse
                  *mouse-x* (mouse-cx mouse)
                  *mouse-y* (mouse-cy mouse)
                  *topwin* (window-with-mouse-focus))
            (setf *focus-changed?* (not (eql *topwin* *last-topwin*)))
-           (if (eql event-type :event-mouse-press)
-               (send-mouse-click-event mouse)))
+           (cond
+             ((eql event-type :event-mouse-press)
+              (send-mouse-click-event mouse))
+             ((eql event-type :event-mouse-move)
+              (send-mouse-move-event mouse))))
           ;; === key pressed or released ===
           ((:event-key-press :event-key-release)
            (case (key-vk k)
-             (format t "key press: ~S~%" (key-c k))
+             ;;(format t "key press: ~S~%" (key-c k))
              (:shift (setf *shift* (key-pressed k)))
              (:control (setf *ctrl* (key-pressed k)))
              (:alt (setf *alt* (key-pressed k)))
                 (send-key-to-window *topwin* k
                                     (- *mouse-x* (window-tlx *topwin*))
                                     (- *mouse-y* (window-tly *topwin*)))))))
-        (otherwise (format t "unknown event: ~S~%" event-type)))
+          (otherwise (format *debug-io* "Unknown event: ~S~%" event-type)))
         (finally
          (if events (console-flush))))
       ;; We have processed all events. Now look at what state the mouse is in.
       (cond
         ((and (mouse-lbutton *rodent*)
               *topwin*)
-                (raise-window *topwin*)
-                (let ((start (get-internal-real-time))
-                      (dragged? nil))
-                  (declare (ignorable dragged?))
-                  (iterate
-                    (while (mouse-lbutton (setf *rodent* (mouse-get-status t))))
-                    (unless (and (< (get-internal-real-time)
-                                    (+ start (/ (* *drag-delay* 1000)
-                                                internal-time-units-per-second)))
-                                 (zerop (mouse-dx *rodent*))
-                                 (zerop (mouse-dy *rodent*)))
-                      (setf dragged? t)
-                      (cond
-                        ((and (window-can-drag? *topwin*)
-                              (on-upper-window-border?
-                               *topwin*
-                               (- *mouse-x* (window-tlx *topwin*))
-                               (- *mouse-y* (window-tly *topwin*))))
-                         ;; Dragging on title bar - move the window
-                         (mouse-drag-window *topwin* *rodent*))
-                        ((and (window-can-resize? *topwin*)
-                              (= *mouse-y* (+ (window-tly *topwin*)
-                                              (1- (window-height *topwin*))))
-                              (= *mouse-x* (+ (window-tlx *topwin*)
-                                              (1- (window-width *topwin*)))))
-                         ;; Dragging on bottom right corner
-                         (mouse-resize-window *topwin* *rodent*))
-                        (t
-                         (send-to-window
-                          *topwin*
-                          (make-instance '<GUI-Mouse-Drag-Event>
-                                         :winx (- *mouse-x* (window-tlx *topwin*))
-                                         :winy (- *mouse-y* (window-tly *topwin*))
-                                         :mouse-state *rodent*))))
-                      (return)))))
-             (t                         ; mouse "just hovering"
-              (when *topwin*
-                (setf (gui-event-winx mouse-hover-event)
-                      (constrain (- *mouse-x* (window-tlx *topwin*))
-                                 0 (1- (window-width *topwin*))))
-                (setf (gui-event-winy mouse-hover-event)
-                      (constrain (- *mouse-y* (window-tly *topwin*))
-                                 0 (1- (window-height *topwin*))))
-                (setf (gui-event-mouse-state mouse-hover-event) *rodent*)
-                (setf (gui-event-focus mouse-hover-event) nil)
-                ;;(format t "hover: ~S~%" mouse-hover-event)
-                (send-to-window *topwin* mouse-hover-event))))
+         (raise-window *topwin*)
+         (let ((start (get-internal-real-time))
+               (dragged? nil))
+           (declare (ignorable dragged?))
+           (iterate
+             (while (mouse-lbutton (setf *rodent* (mouse-get-status t))))
+             (unless (and (< (get-internal-real-time)
+                             (+ start (/ (* *drag-delay* 1000)
+                                         internal-time-units-per-second)))
+                          (zerop (mouse-dx *rodent*))
+                          (zerop (mouse-dy *rodent*)))
+               (setf dragged? t)
+               (cond
+                 ((and (window-can-drag? *topwin*)
+                       (on-upper-window-border?
+                        *topwin*
+                        (- *mouse-x* (window-tlx *topwin*))
+                        (- *mouse-y* (window-tly *topwin*))))
+                  ;; Dragging on title bar - move the window
+                  (mouse-drag-window *topwin* *rodent*))
+                 ((and (window-can-resize? *topwin*)
+                       (= *mouse-y* (+ (window-tly *topwin*)
+                                       (1- (window-height *topwin*))))
+                       (= *mouse-x* (+ (window-tlx *topwin*)
+                                       (1- (window-width *topwin*)))))
+                  ;; Dragging on bottom right corner
+                  (mouse-resize-window *topwin* *rodent*))
+                 (t
+                  (send-to-window
+                   *topwin*
+                   (make-instance '<GUI-Mouse-Drag-Event>
+                                  :winx (- *mouse-x* (window-tlx *topwin*))
+                                  :winy (- *mouse-y* (window-tly *topwin*))
+                                  :mouse-state *rodent*))))
+               (return)))))
+        (t                              ; mouse "just hovering"
+         (when *topwin*
+           (setf (gui-event-winx mouse-hover-event)
+                 (constrain (- *mouse-x* (window-tlx *topwin*))
+                            0 (1- (window-width *topwin*))))
+           (setf (gui-event-winy mouse-hover-event)
+                 (constrain (- *mouse-y* (window-tly *topwin*))
+                            0 (1- (window-height *topwin*))))
+           (setf (gui-event-mouse-state mouse-hover-event) *rodent*)
+           (setf (gui-event-focus mouse-hover-event) nil)
+           (send-to-window *topwin* mouse-hover-event))))
       )))
 
 
 
 The loop runs until the global variable [[*exit-gui?*]] is non-nil.
 "
+  (assert *gui-initialised?*)
   (let ((*rodent* (mouse-get-status t))
         ;;(*last-rodent* (make-mouse))
         (*topwin* nil) (*last-topwin* nil))
   "* Arguments: None.
 * Returns: None.
 * Description: Resume running the currently defined window system."
+  (assert *gui-initialised?*)
   (console-flush)
   (main-gui-loop))
 
     (dotimes (y (window-height win))
       (dotimes (x (window-width win))
         (push (code-char (console-get-char (window-console win) x y)) line))
-      (format t "~3D: ~S~%" y (concatenate 'string (reverse line)))
+      (format *debug-io* "~3D: ~S~%" y (concatenate 'string (reverse line)))
       (setf line nil))))
 
 
                  (if (mouse-wheel-down mouse) #\D #\space)
                  (tcod::sdl-get-mouse-state +null+ +null+)))
         (:event-key-press
-         (format t "key press: ~S~%" (key-c key))
+         (format t "key press: c:~S vk:~S shift:~S lalt:~S lctrl:~S ralt:~S rctrl:~S~%"
+                 (key-c key) (key-vk key) (key-shift key)
+                 (key-lalt key) (key-lctrl key) (key-ralt key) (key-rctrl key))
          (if (eql #\q (key-c key))
              (return-from test-events nil)))
         (:event-key-release (format t "key release~%"))
 (defvar *termwin* nil)
 (defvar *htwin* nil)
 (defvar *custom-colours*
-  `((:green 		68 158 53)
-    (:red 		151 26 26)
-    (:magenta		255 110 87)
-    (:light-grey	185 192 162)
-    (:grey		185 192 162)
-    (:dark-grey		88 83 86)
-    (:light-blue	145 202 255)
-    (:light-green	131 212 82)
-    (:light-cyan	176 223 215)
-    (:light-red		255 34 34)
-    (:light-magenta	255 167 246)
-    (:yellow		255 218 90)
-    (:brown	 	120 94 47))
+  `((:green             68 158 53)
+    (:red               151 26 26)
+    (:magenta           255 110 87)
+    (:light-grey        185 192 162)
+    (:grey              185 192 162)
+    (:dark-grey                 88 83 86)
+    (:light-blue        145 202 255)
+    (:light-green       131 212 82)
+    (:light-cyan        176 223 215)
+    (:light-red                 255 34 34)
+    (:light-magenta     255 167 246)
+    (:yellow            255 218 90)
+    (:brown             120 94 47))
   "* Description: List of lists. Each sublist has the form (COLOURNAME R G B).
 COLOURNAME is a keyword that will be associated with the new colour.
 R, G and B are byte values (0-255) that define the new colour.")
              (collecting line)))))
     (loop for x from 0 below (map-xdim win)
        do (loop for y from 0 below (map-ydim win) do
-	       (let ((it (char (nth (mod (1+ y) maze-ydim) maze)
+               (let ((it (char (nth (mod (1+ y) maze-ydim) maze)
                                (mod (1+ x) maze-xdim))))
-		 (cond
-		   ((equal #\# it)
-		    (map-draw-char-at win #\# x y :fg :light-blue
-				      :redraw nil))))))
+                 (cond
+                   ((equal #\# it)
+                    (map-draw-char-at win #\# x y :fg :light-blue
+                                      :redraw nil))))))
     (map-draw-char-at win (cursor-char win)
                       (cursorx win) (cursory win)
                       :fg :yellow)))
      (call-next-method))
     (t
      (list "Here is the tip:"
-	   (format nil "{fg:red}~S{/}" datum)
+           (format nil "{fg:red}~S{/}" datum)
            "Don't swim in shark-infested waters."))))
 
 
 
 (defmethod prepare-window :after ((win <Statistics-Window>))
   (draw-string-at win (bar-chart (- (window-width win) 2)
-				 (hit-points *player*) (max-hit-points *player*)
+                                 (hit-points *player*) (max-hit-points *player*)
                                  :text :percent
-				 :bar-colour :light-red
-				 :empty-bar-colour :dark-red)
-		  1 1 )
+                                 :bar-colour :light-red
+                                 :empty-bar-colour :dark-red)
+                  1 1 )
   (draw-string-at win (bar-chart (- (window-width win) 2)
-				 (stamina *player*)
-				 (max-stamina *player*)
+                                 (stamina *player*)
+                                 (max-stamina *player*)
                                  :text :fraction
-				 :bar-colour :light-blue
-				 :empty-bar-colour :dark-blue)
-		  1 2 ))
+                                 :bar-colour :light-blue
+                                 :empty-bar-colour :dark-blue)
+                  1 2 ))
 
 
 
 
 (defun gui-demo ()
   (let ((width 0)
-	(height 0))
+        (height 0))
     (setf *window-theme*
           (make-instance '<Window-Theme>
                          :foreground :white
                :font-file *font-file* :antialiased? t)
     (dolist (col *custom-colours*)
       (destructuring-bind (name r g b) col
-	(tcod:make-colour name r g b)))
+        (tcod:make-colour name r g b)))
 
     (setf width (tcod:console-get-width tcod:*root*))
     (setf height (tcod:console-get-height tcod:*root*))
     ;; Make viewport. Make it slightly shorter than HEIGHT to
     ;; allow messages on the bottom line of the root console.
     (setf *viewport* (make-instance '<MyViewport>
-				    :foreground :light-blue
-				    :background :black
-				    :width width :height (1- height)))
+                                    :foreground :light-blue
+                                    :background :black
+                                    :width width :height (1- height)))
     (setf *smallvp* (make-instance '<Viewport> :tlx 58 :tly 1 :width 12
                                                :height 12))
     (share-map *smallvp* *viewport* 15 13)
                                   :transparency +OPAQUE+))
     ;; Make windows
     (setf *dlgwin*
-	  (make-instance '<Dialog-Window>
+          (make-instance '<Dialog-Window>
                          :tlx 8 :tly 3 :width 25 :height 8
-			 :title "Dialog" :foreground :grey :background :red
+                         :title "Dialog" :foreground :grey :background :red
                          :transparency +OPAQUE+
                          :draw
                          (lambda (win)
                          :title "Terminal" :foreground :white :background
                          :dark-slate-gray :prompt "==>"))
     (setf *alertwin*
-	  (make-instance '<Alert-Window>
+          (make-instance '<Alert-Window>
                          :tlx 6 :tly 15 :width 20 :height 8
                          :title "Alert!" :foreground :yellow :background :red
                          :hidden? t :transparency +OPAQUE+ :text
                          "Your path is blocked by a wall! Click 'X' to close."))
     (setf *listwin*
-	  (make-instance '<Filtered-Window>
+          (make-instance '<Filtered-Window>
                          :tlx 21 :tly 18 :width 20 :height 9
                          :title "list" :transparency +OPAQUE+))
     (add-item *listwin* "a" "a. '{fg:green}apples{/}'" (make-simple-key #\a))
     (add-item *listwin* "d" "d. '{fg:brown}potatoes{/}'" (make-simple-key #\d))
     (add-item *listwin* "e" "e. '{fg:pink}yams{/}'" (make-simple-key #\e))
     (setf *msgwin*
-	  (make-instance '<Log-Window> :tlx 55 :tly 5 :width 33 :height 28
+          (make-instance '<Log-Window> :tlx 55 :tly 5 :width 33 :height 28
                                        :title "Messages" :foreground :light-blue
                                        :background :dark-blue :transparency +OPAQUE+
                                        :transparency-unfocussed 50))
     (setf *menuwin*
-	  (make-instance '<Menu-Window>
+          (make-instance '<Menu-Window>
                          :tlx 40 :tly 10 :width 15 :height 7
                          :title "list"
                          :items