Commits

Anonymous committed 2f59191

First commit

Comments (0)

Files changed (12)

MDA9x14.png

Added
New image
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;;;;;;;;;;;;;;;80
+
+(defpackage #:dormouse-system
+	(:use #:cl #:asdf))
+
+(in-package #:dormouse-system)
+
+(defsystem dormouse
+    :description "GUI module for libtcod, a truecolour console library."
+    :author "Paul Sexton <eeeickythump@gmail.com>"
+    :components
+    ((:file "dormouse"))
+    :depends-on ("tcod" "iterate"))
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;;;;;;;;;;;;;;;80
+;;;;
+;;;; DORMOUSE
+;;;; "Graphical" user interface for the libtcod console library.
+;;;;
+;;;; TODO
+;;;; Finish assertions for all tcod wrapper functions.
+;;;; Colours don't return to default in log windows.
+;;;; REPL.
+;;;; Finish documentation.
+;;;;
+;;;; Table of contents
+;;;; =================
+;;;;
+;;;; (Emacs users: linkd-mode will allow you to navigate using these
+;;;; hyperlinks)
+;;;;
+;;;; (@> "Package definition")
+;;;; (@> "Utility functions")
+;;;; (@> "Constants")
+;;;; (@> "Global variables")
+;;;; (@> "Keys")
+;;;; (@> "Colourising strings")
+
+;;;; - (@> "Window")
+;;;;      - (@> "List-Window")
+;;;;           - (@> "Filtered-Window")
+;;;;           - (@> "Menu-Window")
+;;;;           - (@> "Log-Window")
+;;;;      - (@> "Modal-Window")
+;;;;           - (@> "Alert-Window")
+;;;;           - (@> "Yes/No-Window")
+;;;;      - (@> "Dialog-Window")
+;;;;           - (@> "Tooltip-Window")
+;;;;                uses (@> "Floating-Window")
+;;;;      - (@> "Background-Window")
+;;;;      - (@> "Ghost-Window")
+;;;;      - (@> "Window-With-Context-Menu")
+;;;;      - (@> "Viewport")
+;;;;
+;;;;
+;;;; The documentation for this package is generated using the CLDOC library.
+;;;;
+;;;; The following command is used: (dormouse and cldoc systems must be
+;;;; loaded into the running lisp image first)
+;;;;
+;;;; (cldoc:extract-documentation 'cldoc:html
+;;;;       "/home/paul/lisp/wormwood/src/tcod-gui/html" 
+;;;;       (asdf:find-system :dormouse)
+;;;;       :table-of-contents-title
+;;;;       "Dormouse, a graphical user interface using the Doryen library"
+;;;;       :section-names '("Arguments:" "Returns:" "Examples:" "See Also:"
+;;;;                        "Example:" "Notes:" "Description:"))
+;;;;
+
+;;;; (@> "Package definition") ================================================
+
+(in-package :cl-user)
+
+(declaim (optimize (speed 0) (safety 2) (debug 3)))
+
+(defpackage :dormouse
+  (:nicknames :dormouse :tcod-gui :tcod.gui)
+  (:use :cl :tcod ;;:util
+        :iterate)
+  (:documentation
+"DORMOUSE is a windowing `graphical' user interface library, built on top of
+the Doryen Library (libtcod).
+
+<b>What is the Doryen Library?</b>
+
+Libtcod is a library that implements a truecolour console. It can be thought of
+as a souped-up alternative to (n)curses. The console can be of any size that
+fits on the screen. Both keyboard and mouse events are handled. There is
+support for artibrarily large character sets, and font antialiasing. BMP and
+PNG images can be displayed alongside text.
+
+While libtcod is well-suited for any application where a console-based
+interface is desired, the author's motivation is to support the development of
+roguelike games (see {http://en.wikipedia.org/wiki/Roguelike_game}). As such,
+libtcod also provides line-of-sight calculations, pathfinding, perlin noise,
+height maps, BSP, parsing of configuration files, and other features.
+
+Libtcod is written in C and C++. Bindings for libtcod are currently available
+in the python, C#, D, and Common Lisp.
+
+<b>What is DORMOUSE?</b>
+
+Dormouse ('Doryen' + 'Mouse', groan) is a windowing `graphical' user interface
+built on top of libtcod. The programmer creates Window objects which are
+displayed on the root console. The mouse can be used to move, resize, and close
+windows. Keyboard and mouse events are sent to whichever window object has the
+focus.
+
+<b>Give me some details about DORMOUSE's features.</b>
+
+- Full mouse support, including drag and drop events from one window to another.
+- Move and resize windows with the mouse.
+- Each window's foreground, background, and text can be displayed in any 32-bit
+  colour.
+- Text strings can contain formatting directives, similar to HTML, which can
+  instruct the library about the colours in which parts of the string should be
+  displayed, compose accented characters, or define 'live' areas of the string
+  which generate special events when clicked with the mouse (acting like dialog
+  buttons).
+- Many subclasses of the base 'Window' class with specialised behaviour,
+  including:
+-- Viewports: windows which provide a view onto an underlying map (array),
+   which may be much larger. Dragging with the mouse moves the viewport around
+   the map. Intended for the main display area in roguelike games.
+-- List windows: browse and select from a list of values. Items can have
+   'hotkeys' defined for quick selection.
+-- Filtered windows: list windows that allow the user to type a 'filter
+   string', only displaying items which contain the string.
+-- Menu windows: simplified list window where a single mouse click selects and
+   closes the window.
+-- Log windows: a scrolling 'buffer' of text, with new messages added at the
+   bottom.
+-- Modal windows: prevent access to other windows, forcing the user to respond
+   to a message or dialog.
+-- Ghost windows: cannot be interacted with, useful for simply displaying some
+information in an area of the screen.
+-- Dialog windows: present strings containing 'dialog buttons' to the user.
+-- Tooltip windows: display a message when the mouse hovers over items within
+   the window.
+-- Context windows: window in which right-clicking on an item brings up a list
+   of commands which can be applied to the item, where the commands presented
+   will vary according to the characteristics of the right-clicked item.
+-- And any combination of the above, using multiple inheritance...
+- Windows can be created as 'children' of other windows, allowing hiding,
+  showing, creation and destruction of a complex group of windows as a unit
+
+The latest version of DORMOUSE can be found at:
+- {http://code.google.com/p/cl-dormouse/}
+
+The Doryen library can be found at:
+- {http://doryen.eptalys.net/libtcod/}
+
+<b>How do I install it?</b>
+
+- Make sure you have ASDF installed (common lisp library).
+- Install ITERATE (common lisp iteration library):
+-- {http://common-lisp.net/project/iterate/}
+- Download libtcod from the link above. Compile if necessary.
+- Get CL-TCOD (common lisp bindings to libtcod):
+-- {http://bitbucket.org/eeeickythump/cl-tcod/}
+- Get DORMOUSE from the link above.
+- Run your lisp and make sure you can load asdf, and asdf can load
+CL-TCOD and DORMOUSE.
+- The following is a minimal 'hello world' application:
+;;; (in-package :cl-user)
+;;; (defpackage :my-new-package
+;;;  (:use :cl :tcod :dormouse))
+;;;
+;;; (in-package :my-new-package)
+;;;
+;;; (defun my-test ()
+;;;    (let ((msgwin nil))
+;;;      (dormouse:start-gui :title \"Testing\")
+;;;      (setf msgwin
+;;;        (make-instance '<Log-Window> :tlx 30 :tly 10 :width 20 :height 6
+;;;			 :title \"log\" :foreground :cornsilk
+;;;			 :background :dark-blue))
+;;;      (add-message msgwin \"Press control-F1 or control-Esc to quit\")
+;;;      (main-gui-loop)))
+- Save it in a file, load it, and run (my-test) at the lisp prompt to try it.
+")
+  (:export #:start-gui
+	   #:main-gui-loop
+           #:resume-gui
+	   #:*shift*
+	   #:*ctrl*
+	   #:*alt*
+	   #:*exit-gui?*
+           #:+OPAQUE+
+	   #:screen-width
+	   #:screen-height
+	   #:colour
+	   #:destroy-window
+	   #:destroy-all-windows
+	   #:copy-windows-to-console
+	   #:prepare-window
+	   #:process-window
+	   #:redraw-window
+	   #:redraw-window-area
+	   #:redraw-all-windows
+	   #:prepare-windows-by-type
+	   #:do-for-windows-by-type
+	   #:hide-window
+	   #:raise-window
+	   #:move-window
+	   #:*window-stack*
+	   #:all-windows
+	   #:*mouse-x*
+	   #:*mouse-y*
+	   #:send-to-window
+	   #:send-key-to-window
+	   #:mouse-drag
+	   #:key->string
+	   #:<Window>
+	   #:<Modal-Window>
+	   #:<Ghost-Window>
+	   #:<Background-Window>
+	   #:<List-Window>
+	   #:<Menu-Window>
+	   #:<Alert-Window>
+	   #:<Yes/No-Window>
+	   #:<Tooltip-Window>
+	   #:<Filtered-Window>
+	   #:filter-string
+	   #:binding->key
+	   #:character->vk
+	   #:character->shift
+	   #:<Window-With-Context-Menu>
+	   #:get-menu-items-for-context
+	   #:command-from-context-menu
+	   #:tooltip-text
+	   #:calculate-floating-window-width
+	   #:<Dialog-Window>
+	   #:window-cursor
+	   #:move-cursor-to
+	   #:cursor-moved-to-item
+	   #:window-offset
+	   #:wrap-coloured-text
+	   #:coloured-string-length
+	   #:draw-string-at
+	   #:add-item
+	   #:window-items
+	   #:window-items-lines
+	   #:clear-items
+	   #:list-item
+	   #:list-item-item
+	   #:list-item-hotkey
+	   #:list-item-p
+	   #:move-cursor-to-end
+	   #:window-show-tail-by-default?
+           #:window-can-close?
+           #:window-can-drag?
+           #:window-can-resize?
+	   #:window-item-at-cursor
+	   ;; Log window
+	   #:<Log-Window>
+	   #:clear-messages
+	   #:add-message
+           #:add-message-and-redraw
+	   #:bottom-message
+	   ;; Viewports
+	   #:<Viewport>
+	   #:clear-map
+	   #:share-map
+	   #:unshare-map
+	   #:map-xdim
+	   #:map-ydim
+	   #:map-draw-char-at
+           #:map-char-at
+	   #:in-view?
+	   #:centre-viewport-on
+	   #:window-width
+	   #:window-height
+	   #:window-tlx
+	   #:window-tly
+           #:window-framed?
+	   #:window-children
+	   #:window-raise-children-with-parent?
+	   #:window-hidden?
+	   #:window-changed?
+	   #:window-auto-redraw?
+	   #:view-tlx
+	   #:view-tly
+	   #:view-brx
+	   #:view-bry
+	   #:viewport-width
+	   #:viewport-height
+	   #:in-view?
+	   #:in-viewport-map?
+	   #:winx->mapx
+	   #:winy->mapy
+	   #:winx->rootx
+	   #:winy->rooty
+	   #:bar-chart
+	   ))
+
+(in-package :dormouse)
+
+(defgeneric destroy-window (win)
+  (:documentation
+   "* Arguments: 
+- WIN: an instance of {defclass dormouse:<Window>}
+* Returns: None.
+* Description: Destroy the window object WIN, hiding it first if it is not
+already hidden.
+* See Also: "))
+(defgeneric touch-windows (win)
+  (:documentation
+   "* Arguments: 
+- WIN: an instance of {defclass dormouse:<Window>}
+* Returns: None.
+* Description: Internal function. Links up WIN with all other windows it is touching,
+i.e. overlapping."))
+(defgeneric untouch-windows (win)
+  (:documentation "TODO document."))
+(defgeneric move-window (win tlx tly)
+  (:documentation
+   "* Arguments: 
+- WIN: an instance of {defclass dormouse:<Window>}
+- TLX, TLY: coordinates on the screen where the top left corner of WIN
+is to be moved to.
+* Returns: None.
+* Description: Move the window WIN so that its top left corner is located
+at TLX, TLY relative to the top left corner of the screen.
+* See Also: "))
+(defgeneric window-touches-spot? (win x y)
+  (:documentation
+     "Does this window overlap the spot at X,Y ?"))
+(defgeneric windows-touching? (win other)
+  (:documentation
+     "Do these two windows overlap somewhere?"))
+(defgeneric window-parent (win)
+  (:documentation "TODO document."))
+(defgeneric windows-below (win)
+  (:documentation
+     "List of all windows 'under' WIN in the window stack."))
+(defgeneric windows-above (win)
+  (:documentation
+     "List of all windows 'above' WIN in the window stack."))
+(defgeneric windows-overlying (win)
+  (:documentation
+     "List of all windows that both overlap with WIN and are above it in
+the stack."))
+(defgeneric windows-underlying (win)
+  (:documentation
+     "List of all windows that both overlap with WIN and are below it in
+the stack."))
+(defgeneric copy-window-to-console (win con)
+  (:documentation "TODO document."))
+(defgeneric redraw-window (win)
+  (:documentation   "Force window to copy itself onto the terminal."))
+(defgeneric window-redraw-at (win rootx rooty)
+  (:documentation "TODO document."))
+(defgeneric redraw-window-in-area (win x1 y1 x2 y2)
+  (:documentation "TODO document."))
+(defgeneric redraw-window-intersection (win1 win2)
+  (:documentation "TODO document."))
+(defgeneric redraw-intersecting-windows-below (win)
+  (:documentation "TODO document."))
+(defgeneric redraw-intersecting-windows-above (win)
+  (:documentation "TODO document."))
+(defgeneric prepare-window (win)
+  (:documentation
+     "Redraw window contents, but don't actually copy the window console anywhere."))
+(defgeneric process-window (win)
+  (:documentation "TODO document."))
+(defgeneric resize-window (win width height)
+  (:documentation "TODO document."))
+(defgeneric mouse-drag-window (win rodent)
+  (:documentation
+   "* Arguments: 
+- WIN: an instance of {defclass dormouse:<Window>}
+- RODENT: a mouse object.
+* Returns: None.
+* Description: Internal function, called by {defun dormouse:main-gui-loop}
+when the user uses the mouse to move a window across the screen."))
+(defgeneric mouse-resize-window (win rodent)
+  (:documentation
+   "* Arguments: 
+- WIN: an instance of {defclass dormouse:<Window>}
+- RODENT: a mouse object.
+* 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)
+  (:documentation
+   "* Arguments: 
+- WIN: an instance of {defclass dormouse:<Window>}
+- REDRAW: boolean value indicating whether the area of the screen occupied
+by the window should be redrawn.
+* Returns: None.
+* Description: Put the window WIN at the top of the window stack, so that
+it is displayed as overlying any other overlapping windows.
+* Examples: 
+* See Also: "))
+(defgeneric hide-window (win &key redraw &allow-other-keys)
+  (:documentation
+   "* Arguments: 
+- WIN: an instance of {defclass dormouse:<Window>}
+- REDRAW: boolean value indicating whether the area of the screen occupied
+by the window should be redrawn.
+* Returns: None.
+* Description: Hide the window WIN, making it invisible and unable to
+receive events. The window is not destroyed.
+* Examples:
+;;; (hide-window mywin :redraw t)
+* See Also: "))
+(defgeneric send-to-window (win data parm winx winy)
+  (:documentation
+   "* Arguments: 
+- WIN: an instance of {defclass dormouse:<Window>}
+- DATA: A value of type {deftype dormouse:=window-event-type=}, to be passed
+to WIN as an event. 
+- PARM: Some additional value to passed to WIN to provide further information
+about the event. For key structs it is the value of the KEY-VK slot, or the
+KEY-C slot if KEY-VK is :CHAR.
+- WINX, WINY: the coordinates within the window where the event occurred,
+relative to the top left corner of WIN (not the screen).
+* Returns: None.
+* Description: Send an event to the window WIN. The event is described by
+DATA, with additional information in PARM when appropriate.
+* Examples:
+;;; (send-to-window mywin :lmouse nil *mouse-x* *mouse-y*)
+* See Also: "))
+(defgeneric send-key-to-window (win key winx winy)
+  (:documentation "Return non-nil if they key is handled, nil if
+not handled."))
+(defgeneric on-border? (win x y)
+  (:documentation
+   "* Arguments: 
+- WIN:
+- X, Y: Coordinates.
+* Returns: 
+* Description: 
+* Examples: 
+* See Also: "))
+(defgeneric on-lower-window-border? (win x y)
+  (:documentation "TODO document."))
+(defgeneric on-upper-window-border? (win x y)
+  (:documentation "TODO document."))
+(defgeneric window-draw-char-at (win cg winx winy
+				&key background-flag fg bg redraw
+				&allow-other-keys)
+  (:documentation "TODO document."))
+(defgeneric console-draw-char-at (con ch winx winy
+			     &key background-flag fg bg &allow-other-keys)
+  (:documentation "TODO document."))
+(defgeneric draw-string-at (win str x y
+			   &key fg bg redraw &allow-other-keys)
+  (:documentation
+   "* Arguments: 
+- WIN: an instance of {defclass dormouse:<Window>}
+- STR: A string, which may contain formatting directives (see below).
+- X, Y: coordinates where the string should be printed, relative to
+the top left corner of WIN.
+- FG, BG: foreground and background colours for the string.
+- REDRAW: Boolean. 
+* Returns: None.
+* Description: Draw the string STR on the window object WIN at
+position X,Y. The string STR can contain colour-changing directives - see the
+documentation for {defun dormouse:make-coloured-string} for details.
+* Examples:
+;;; (draw-string-at mywin ``Hello, {blue}world!{/}'' 1 1 :fg :green)
+* See Also:
+- {defun dormouse:make-coloured-string}"))
+(defgeneric colour->control-string (col background?)
+  (:documentation
+   "* Arguments:
+- COL: A colour specifier (keyword, number, or string.)
+- BACKGROUND?: Boolean.
+
+* Description:
+Given a colour, returns a string of control codes which will change a
+console's foreground colour (or background colour if BACKGROUND? is
+non-nil) to the specified colour, when printed to the console."))
+(defgeneric window-item-lines (win item)
+  (:documentation   "Returns the number of lines that the item ITEM takes up in
+the displayed list. Most items take up only 1 line."))
+(defgeneric window-items-lines (win)
+  (:documentation   "Returns the total number of lines needed to display all
+the items in the window's list."))
+(defgeneric add-item (win item str &optional k)
+  (:documentation   "Add an item to the end of the window's list.  ITEM is the
+'value' of the item itself. It can be any lisp value.  STR is a string
+representing ITEM, which is what is displayed in the window.  HOTKEY is an
+optional hotkey which quickly selects the item."))
+(defgeneric clear-items (win)
+  (:documentation   "Delete all items in the list belonging to WIN."))
+(defgeneric draw-item-at (win item x y cursor?)
+  (:documentation   "Draw list-item ITEM at WINX,WINY in the window WIN.  If
+CURSOR? is non-nil, make it visually apparent that the cursor is currently
+positioned over this item."))
+(defgeneric window-item-at-cursor (win)
+  (:documentation   "Return the list-item that is at the current cursor
+position in this window (the 'cursor' moves up and down the list and always
+points to one of the items in the list)."))
+(defgeneric move-cursor-to-end (win)
+  (:documentation "TODO document."))
+(defgeneric wrap-items (win)
+  (:documentation "TODO document."))
+(defgeneric add-message (win fmt &rest args)
+  (:documentation   "Adds the string produced by calling (APPLY #'FORMAT nil
+FMT ARGS) to the end of the message list, and moves the display so that the
+tail of the list is visible (including the new message)."))
+(defgeneric add-message-and-redraw (win fmt &rest args)
+  (:documentation   "Calls ADD-MESSAGE, then forces a redraw of WIN so
+that the message is immediately visible."))
+(defgeneric clear-messages (win)
+  (:documentation "TODO document."))
+(defgeneric calculate-floating-window-width (win)
+  (:documentation "TODO document."))
+(defgeneric tooltip-text (win datum winx winy)
+  (:documentation   "Accepts an arbitrary value. Returns nil if the datum
+should not be associated with a tooltip for this window. Otherwise returns a
+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 copy-map-to-viewport (win)
+  (:documentation "TODO document."))
+(defgeneric clear-map (win &key redraw &allow-other-keys)
+  (:documentation "TODO document."))
+(defgeneric centre-viewport-on (win mapx mapy)
+  (:documentation "TODO document."))
+(defgeneric share-map (receiver giver tlx tly)
+  (:documentation "TODO document."))
+(defgeneric unshare-map (receiver giver)
+  (:documentation "TODO document."))
+(defgeneric map-draw-char-at (win ch x y
+				&key background-flag fg bg redraw
+			     &allow-other-keys)
+  (:documentation   "Draw character with ASCII code CH at position MAPX, MAPY
+on the map console of WIN."))
+(defgeneric map-char-at (win mapx mapy)
+  (:documentation
+  "* Arguments:
+- WIN:
+- MAPX, MAPY: Coordinates on the map associated with WIN.
+* Returns: A character.
+* Description: Returns the character stored at (MAPX, MAPY) on the
+map that is 'viewed' by the viewport WIN."))
+(defgeneric get-context-at (win winx winy)
+  (:documentation "TODO document."))
+(defgeneric get-menu-items-for-context (win context-item)
+  (:documentation "TODO document."))
+(defgeneric command-from-context-menu (win command context-item)
+  (:documentation "TODO document."))
+(defgeneric mouse-drag (from-win to-win wfromx wfromy wtox wtoy)
+  (:method ((from-win t) (to-win t) wfromx wfromy wtox wtoy)
+    (declare (ignore wfromx wfromy wtox wtoy))
+    nil)
+  (:documentation "TODO document."))
+(defgeneric windows-overlapping (win &key)
+  (:documentation "TODO document."))
+(defgeneric window-item-at (win winx winy)
+  (:documentation   "Return the list-item that would be selected if the user
+clicked on position WINX, WINY in window WIN."))
+(defgeneric move-cursor-to (win cursor)
+  (:documentation   "Move cursor to point to item number CURSOR in the list."))
+(defgeneric cursor-moved-to-item (win item)
+  (:documentation "TODO document."))
+(defgeneric move-cursor-by (win increment)
+  (:documentation   "Move cursor by INCREMENT items in the list. A positive
+number moves further down the list, a negative number moves up."))
+(defgeneric item-matches-filter-string? (win item)
+  (:documentation "TODO document."))
+(defgeneric ok-to-show-tooltip? (win)
+  (:documentation "TODO document.")
+  (:method ((win t)) nil))
+
+
+;;;; ======================================================================
+;;;; (@> "User-defined types")
+;;;; ======================================================================
+
+(deftype =positive-integer= ()
+  "TODO document."
+  `(integer 0))
+(deftype =accent-specifier= ()
+  "TODO document."
+  `(member #\^ #\: #\` #\' #\0))
+(deftype =window-event-type= ()
+  "Type for the DATA argument to SEND-TO-WINDOW."
+  `(or (member :left :right :middle :wheel-up :wheel-down :select
+               :dialog)
+       tcod:key))
+
+;;;; ======================================================================
+;;;; (@> "Constants")
+;;;; ======================================================================
+
+(defconstant +OPAQUE+ 0
+  "Value of WINDOW-TRANSPARENCY for a window that is not at all
+transparent.")
+
+;;;; ======================================================================
+;;;; (@> "Global variables")
+;;;; ======================================================================
+
+;;;; Information about the default font file.
+(defparameter *default-font-file*  "MDA9x14.png"
+  "TODO document.")
+;; (defparameter *default-font-file-chars-in-columns?* t
+;;   "TODO document.")
+;; (defparameter *default-font-file-background-colour* :true-pink
+;;   "TODO document.")
+(defparameter *default-font-layout*  :font-layout-ascii-in-row
+  "* Description: Argument to pass to TCOD:CONSOLE-SET-CUSTOM-FONT, that
+describes the layout of the default font file. Can be either a single keyword,
+or a list of keywords.")
+
+(defvar *window-stack* (list)
+  "Stack of all existing non-hidden windows. The 'topmost' window is at the
+top of the stack.")
+(defvar *hidden-windows* (list)
+  "Stack of all existing hidden windows. The 'topmost' window is at the
+top of the stack.")
+(defvar *scratch* nil
+  "TCOD console used as a 'scratch' buffer.")
+(defvar *temp-con* nil
+  "TCOD console used as a 'scratch' buffer.")
+(defvar *shift* nil
+  "Global variable which is set to `t' while the shift key is being pressed,
+and `nil' when it is released.")
+(defvar *ctrl* nil
+  "Global variable which is set to `t' while the ctrl key is being pressed,
+and `nil' when it is released.")
+(defvar *alt* nil
+  "Global variable which is set to `t' while the alt/meta key is being pressed,
+and `nil' when it is released.")
+(defvar *mouse-x* 0
+  "Global variable set to the current absolute X-coordinate of the mouse
+cursor, relative to the top left corner of the root console.")
+(defvar *mouse-y* 0
+  "Global variable set to the current absolute Y-coordinate of the mouse
+cursor, relative to the top left corner of the root console.")
+(defvar *auto-redraw* t
+  "Do operations such as RAISE-WINDOW automatically copy the new window
+appearance to ROOT?")
+(defvar *drag-delay* 400
+  "Delay before a down-LMB becomes a drag, in milliseconds.")
+(defvar *text-format-start-char* #\{
+  "Character which, when found in a string that is an argument to draw-string,
+heralds the beginning of a formatting instruction. The end of the instruction
+is signalled by a second such character. The string between the characters must
+be the name of a colour, or two colours separated by a comma.")
+(defvar *text-format-end-char* #\}
+  "Character which, when found in a string that is an argument to draw-string,
+heralds the end of an instruction that began with *TEXT-FORMAT-START-CHAR*.")
+(defvar *exit-gui?* nil
+  "* Description: Setting this to non-nil will cause the GUI event-handling
+loop to exit, and control to return to wherever the event-handling loop was
+originally called from.")
+
+
+;;; ======================================================================
+;;; (@> "Utility functions")
+;;; ======================================================================
+
+(defmacro translate-negative-coordinates (x y)
+  "* Description: X and Y are PLACES holding X and Y screen coordinates. If
+either of them is negative, assume they are specified relative to the bottom
+right corner of the screen rather than the top left corner as is usual, and
+change the coordinates stored there into normal coordinates specified relative
+to the top left corner."
+  `(progn
+     (assert (and (integerp ,x) (integerp ,y)))
+     (if (< ,x 0)
+	 (incf ,x (screen-width)))
+     (if (< ,y 0)
+	 (incf ,y (screen-height)))))
+
+
+(defmacro do-for-windows-by-type ((win wtype &key (include-hidden? nil))
+				  &body body)
+  "* Description: Iterate through all existing windows that are of type WTYPE,
+which must be a non-quoted symbol naming a class. If INCLUDE-HIDDEN? is true,
+iterate through hidden as well as visible windows.
+
+Within the body of the iteration, the symbol given as WIN is bound to each
+successive window.
+*Examples:
+;;; (do-for-windows-by-type (win <Message-Window>)
+;;;   (draw-string-at win 1 1 ``Here is a message.''))"
+  `(dolist (,win (if ,include-hidden? (all-windows) *window-stack*))
+     (when (typep ,win ',wtype)
+       ,@body)))
+
+
+
+(defmacro push-end (item list-place)
+  "* Arguments:
+- ITEM: a value.
+- LIST-PLACE: a setf-able place, containing a list.
+* Returns: A list.
+* Destructively appends ITEM to the end of the list stored in LIST-PLACE.
+In other words, like PUSH, but adds to the end of the list rather than
+the start."
+    `(setf ,list-place (append ,list-place (list ,item))))
+
+
+
+(defun constrain (n lower-limit upper-limit)
+  "* Arguments:
+- N: a number.
+- LOWER-LIMIT: a number which is the lowest value that the function will return.
+- UPPER-LIMIT: a number which is the highest value that the function will return.
+
+* Description: Given a number N, Return N if the number is between LOWER-LIMIT
+and UPPER-LIMIT inclusive, otherwise return whichever of LOWER-LIMIT or
+UPPER-LIMIT is nearest to N.
+* See Also: {defmacro dormouse:constrain!}"
+  (cond
+    ((< n lower-limit)
+     lower-limit)
+    ((> n upper-limit)
+     upper-limit)
+    (t n)))
+
+
+
+(defmacro constrain! (place lower-limit upper-limit)
+  "* Arguments:
+- PLACE: a setf-able place that contains a number.
+- LOWER-LIMIT: a number which is the lowest value that the function will return.
+- UPPER-LIMIT: a number which is the highest value that the function will return.
+
+* Description: Destructively modifies PLACE, replacing its value with
+the value returned by (CONSTRAIN PLACE LOWER-LIMIT UPPER-LIMIT).
+* See Also: {defun dormouse:constrain}"
+  `(setf ,place (constrain ,place ,lower-limit ,upper-limit)))
+
+
+
+(defun keyword->string (kwd)
+  "Given :MY-KEYWORD, returns the string 'MY-KEYWORD'."
+  (string-trim '(#\:) (format nil "~A" kwd)))
+
+
+ (defun make-keyword (&rest parts)
+    "Concatenate the parts and intern as a symbol in the KEYWORD package,
+creating a keyword called :SYMBOL."
+    (intern (string-upcase (format nil "~{~A~}" parts)) :keyword))
+
+
+(defun string-tokenise (bag str)
+  "* Arguments:
+- BAG: list of characters.
+- STR: A string
+
+* Returns: A list of strings.
+
+* Description: Divides the string STR wherever any of the characters
+in BAG occur within it. The resulting substrings will not contain the
+characters in BAG. Returns the resulting list of substrings."
+  (let ((tokens nil)
+	(found-pos nil))
+    (check-type str string)
+    (setf str (string-trim bag str))
+    (iterate
+      (while (> (length str) 0))
+      (setf found-pos
+            (car
+             (sort
+              (remove nil
+                      (mapcar #'(lambda (c) (position c str)) bag))
+              #'<)))
+      (when found-pos
+        (push (subseq str 0 found-pos) tokens)
+                                        ;(setf found-ch t)
+        (setf str (string-left-trim bag
+                                    (subseq str found-pos nil))))
+      (unless (or found-pos
+                  (= 0 (length str)))
+        (push str tokens)
+        (setf str "")))
+    (nreverse tokens)))
+
+
+
+(defun spaces (n)
+  "* Arguments:
+- N: a positive integer.
+* Returns: A string of N spaces.
+* Description: Given an integer N, return a string of spaces N characters
+  long."
+  (make-sequence 'string n :initial-element #\space))
+
+
+(defun centre-string (str width)
+  "Returns string ST padded by spaces on either side, so that the length
+of the returned string is at least WIDTH."
+  (check-type str string)
+  (check-type width (integer 0))
+  (cond
+    ((>= (length str) width)
+     str)
+    (t
+     (concatenate 'string
+                  (spaces (floor (- width (length str)) 2))
+                  str
+                  (spaces (ceiling (- width (length str)) 2))))))
+
+
+
+
+(defun word-wrap (text &key (width 80) respect-newlines respect-hyphens
+		  exclude-start-char exclude-end-char)
+  "* Arguments:
+- TEXT: A string.
+- WIDTH: An integer. The width that TEXT should be wrapped to fit within.
+Default is 80.
+- RESPECT-NEWLINES: Boolean. Should newline characters within the string
+be treated as unbreakable?
+- RESPECT-HYPHENS: Boolean. Should we refrain from breaking hyphenated
+words?
+- EXCLUDE-START-CHAR: A character, or nil.
+- EXCLUDE-END-CHAR: A character, or nil.
+
+* Returns: A list of strings.
+
+* Description: Given a string TEXT, breaks the string into a series of
+smaller strings, none of which is longer than WIDTH. Returns the list of
+strings.
+
+If EXCLUDE-START-CHAR and EXCLUDE-END-CHAR are supplied, those characters
+will be treated as demarcating sections of the string whose length is to
+be ignored (treated as zero). This allows WORD-WRAP to correctly deal with
+strings that contain <hypertext>...</hypertext> metadata."
+  (iterate
+    (with counted = 0)
+    (with breakpoint = nil)
+    (with skipping = nil)
+    (for c :in-string text)
+    (for actual :upfrom 0)
+    (cond
+      ((eql c exclude-start-char)
+       (setf skipping t))
+      ((eql c exclude-end-char)
+       (setf skipping nil)))
+    (when (not skipping)
+      (incf counted)
+      (if (or (eql c #\space) (eql c #\tab)
+	      (and (eql c #\Newline) (not respect-newlines))
+	      (and (eql c #\-) (not respect-hyphens)))
+	  (setf breakpoint actual))
+      (when (and (eql c #\Newline) respect-newlines)
+	(setf breakpoint actual)
+	(setf counted (1+ width))))
+    (when (>= counted width)
+      (return (cons (substitute-if #\space
+				   #'(lambda (ch)
+				       (or (eql ch #\tab)
+					   (eql ch #\newline)))
+				   (subseq text 0
+					   (or breakpoint actual)))
+		    (word-wrap (subseq text (if breakpoint
+						(1+ breakpoint)
+						actual))
+			       :width width
+			       :respect-newlines respect-newlines
+			       :respect-hyphens respect-hyphens
+			       :exclude-start-char exclude-start-char
+			       :exclude-end-char exclude-end-char))))
+    (finally (return (list text)))))
+
+
+
+;;;; ======================================================================
+;;;;(@> "Keys")
+;;;; ======================================================================
+
+(defun character->vk (ch)
+  "Given a character CH, return the value of the 'VK' field that is expected
+when the key for that character is pressed by the user."
+  (case ch
+    (#\space
+     :space)
+    ((#\1 #\!)
+     :key-1)
+    ((#\2 #\@)
+     :key-2)
+    ((#\3 #\#)
+     :key-3)
+    ((#\4 #\$)
+     :key-4)
+    ((#\5 #\%)
+     :key-5)
+    ((#\6 #\^)
+     :key-6)
+    ((#\7 #\&)
+     :key-7)
+    ((#\8 #\*)
+     :key-8)
+    ((#\9 #\()
+     :key-9)
+    ((#\0 #\))
+     :key-0)
+    (otherwise
+     :char)))
+
+
+(defun character->shift (ch)
+  "Given a character CH, return the value of the 'SHIFT' field that is expected
+when the key for that character is pressed by the user."
+  (if (or (upper-case-p ch)
+	  (find ch '(#\~ #\! #\@ #\# #\$ #\% #\^ #\& #\*
+		     #\( #\) #\_ #\+ #\{ #\} #\| #\: #\"
+		     #\< #\> #\?)))
+ 
+      t nil))
+
+
+(defun binding->key (binding)
+  "BINDING is a list of the form:
+  (KEYCODE [:ctrl CTRL] [:alt ALT] [:shift SHIFT])
+Where:
+  -- KEYCODE is a character or a VK code
+  -- SHIFT, CTRL and ALT are boolean values
+Return the TCOD key structure that we expect to be produced when the key
+combination described by BINDING is pressed."
+  (destructuring-bind (keycode &key ctrl shift alt) binding
+      (tcod:make-key
+       :vk (if (characterp keycode)
+	       (character->vk keycode)
+	       keycode)
+       :c (if (characterp keycode)
+	      keycode
+	      #\null)
+       :pressed t
+       :shift (if (not (characterp keycode))
+		  shift
+		  (character->shift keycode ))
+       :lctrl ctrl :rctrl ctrl :lalt alt :ralt alt)))
+
+
+(defun key->string (k)
+  "Return a string that describes the key combination represented by the TCOD
+key structure, K, in human-readable form."
+  (check-type k key)
+  (concatenate 'string
+               (format nil "~A~A~A"
+                       (if (key-shift k) "shift-" "")
+                       (if (or (key-rctrl k) (key-lctrl k)) "ctrl-" "")
+                       (if (or (key-ralt k) (key-lalt k)) "alt-" ""))
+               (case (key-vk k)
+                 (:key-0 "0")
+                 (:key-1 "1")
+                 (:key-2 "2")
+                 (:key-3 "3")
+                 (:key-4 "4")
+                 (:key-5 "5")
+                 (:key-6 "6")
+                 (:key-7 "7")
+                 (:key-8 "8")
+                 (:key-9 "9")
+                 (:char
+                  (format nil "~C" (key-c k)))
+                 (otherwise
+                  (format nil "~A" (key-vk k))))))
+
+
+;;;; ======================================================================
+;;;; (@> "Colourising strings")
+;;;; ======================================================================
+
+(defun make-coloured-string (str &key (dialog? nil) (win nil))
+  "* Returns: a string.
+* Description:
+STR is a string that may contain formatting directives. Each directive is
+enclosed within pairs of the characters *TEXT-FORMAT-START-CHAR*
+... *TEXT-FORMAT-END-CHAR* (these are `{'and `}' by default.)
+
+The directives can be used to change the colour in which the string is printed.
+;;; {COLOURNAME} - set foreground colour to COLOURNAME.
+;;; {bg:COLOURNAME} - set background colour to COLOURNAME.
+;;; {fg:COLOURNAME,bg:COLOURNAME} - change foreground and background colours.
+
+Examples of colour directives:
+;;; {green} - change foreground colour to :GREEN
+;;; {fg:green,bg:dark-blue} - change foreground to :GREEN and background to
+;;;                          :DARK-BLUE
+;;; {bg:yellow} - change background to :YELLOW
+
+The delimiters can also be used to 'compose' accented characters:
+{:a} - output a lowercase a with diaeresis.
+{'a} - output a lowercase a with acute accent.
+{`a} - output a lowercase a with grave accent.
+{^a} - output a lowercase a with circumflex accent.
+{0a} - output a lowercase a with 'o' accent.
+
+The directives can be used to mark parts of the string as 'clickable', like dialog
+buttons:
+;;; {click:MYLABEL}Click me!{/}
+
+Finally:
+{/} - return to default foreground and background colours for this window.
+{{ - output a single `{'.
+}} - output a single `}'.
+
+Examples:
+   ``Lisp is the {red}red{/} pill.''
+   ``G{'i}mli, son of Glo{'i}n''
+"
+  (let ((pos@ nil)
+	(pos@@ 0))
+    (setf pos@ (position *text-format-start-char* str))
+    (cond
+      ((null pos@)
+       str)
+      ((and (> (length str) 1)
+	    (member (char str 0) (list *text-format-start-char*
+                                       *text-format-end-char*))
+	    (eql (char str 0) (char str 1)))
+       (format nil "~C~A" (char str 0)
+	       (make-coloured-string (subseq str 2)
+                                     :dialog? dialog? :win win)))
+      ((> pos@ 0)
+       (concatenate 'string (subseq str 0 pos@)
+                    (make-coloured-string (subseq str pos@)
+                                          :dialog? dialog? :win win)))
+      ((null (setf pos@@ (position *text-format-end-char*
+				   (subseq str 1))))
+       (warn "Missing format-end character `~C' in string ~s"
+	     *text-format-end-char* str)
+       str)
+      (t
+       (incf pos@@)
+       (concatenate 'string
+                    (if dialog?
+                        (string->dialog-codes (subseq str 1 pos@@))
+                        ;; else
+                        (string->tcod-colour-codes (subseq str 1 pos@@)
+                                                   win))
+                    (if (>= pos@@ (length str))
+                        ""
+                        (make-coloured-string
+                         (subseq str (+ 1 pos@@)) :dialog? dialog?
+                         :win win)))))))
+
+		       
+(defmethod colour->control-string ((col integer) background?)
+  (multiple-value-bind (r g b) (decompose-colour col)
+    (format nil "~C~C~C~C"
+            (colctrl->char (if background? :COLCTRL-BACK-RGB :COLCTRL-FORE-RGB))
+            (code-char (max r 1))
+            (code-char (max g 1))
+            (code-char (max b 1)))))
+
+(defmethod colour->control-string ((col symbol) background?)
+  (colour->control-string (colour col) background?))
+
+
+(defmethod colour->control-string ((col string) background?)
+  (colour->control-string (string->colournum col) background?))
+
+  
+(defun string->tcod-colour-codes (str &optional win)
+  "Given the contents of a formatting directive STR (a string), return the TCOD
+control codes that are needed to use the colours specified in the string.
+
+A formatting directive is a series of terms separated by commas. Each term is
+either the single character '/', or the name of a colour, or the name of a
+colour prefixed by one of the labels FOREGROUND:, BACKGROUND:, FG:, or BG:."
+  (with-output-to-string (s)
+    (cond
+      ((string= str "/")
+       (cond
+         (win
+         ;; Just outputting COLCTRL-STOP seems not to work if the stop code
+         ;; is a different function call from the original colour-changing
+         ;; codes. It seems that if the colours are changed within a string
+         ;; and not changed back, then the new colours become the new default
+         ;; colours for the console.
+         ;; Therefore, if WIN is supplied, reset the console colours to the
+         ;; remembered default colours for the window object, prior to
+         ;; outputting COLCTRL-STOP.
+          (format s (colour->control-string (window-foreground win) nil))
+          (format s (colour->control-string (window-background win) t)))
+         (t
+          (format s "~C" (colctrl->char :COLCTRL-STOP)))))
+       ;;   (console-set-foreground-colour (window-console win)
+       ;;                                  (colour (window-foreground win)))
+       ;;   (console-set-background-colour (window-console win)
+       ;;                                  (colour (window-background win))))
+       ;; (format s "~C" (colctrl->char :COLCTRL-STOP)))
+      ((and (= 2 (length str))
+	    (member (char str 0) '(#\^ #\: #\' #\`))
+	    (member (char str 1) '(#\A #\E #\I #\O #\U #\a #\e #\i #\o #\u)))
+       (format s "~C" (compose-accented-char (char str 1) (char str 0))))
+      (t
+       (let* ((props (string->properties str :foreground))
+              (foreground (or (getf props :foreground)
+                              (getf props :fg)))
+              (background (or (getf props :background)
+                              (getf props :bg))))
+	 (when foreground
+           (format s (colour->control-string foreground nil)))
+	   ;; (multiple-value-bind
+           ;;       (fr fg fb) (decompose-colour (string->colournum foreground))
+	   ;;   (format s "~C~C~C~C"
+	   ;;           (colctrl->char :COLCTRL-FORE-RGB)
+	   ;;           (code-char (max fr 1))
+	   ;;           (code-char (max fg 1))
+	   ;;           (code-char (max fb 1)))))
+	 (when background
+           (format s (colour->control-string background t))))))))
+	   ;; (multiple-value-bind
+           ;;       (br bg bb) (decompose-colour (string->colournum background))
+	   ;;   (format s "~C~C~C~C"
+	   ;;           (colctrl->char :COLCTRL-BACK-RGB)
+	   ;;           (code-char (max br 1))
+	   ;;           (code-char (max bg 1))
+	   ;;           (code-char (max bb 1))))))))))
+
+
+(defun compose-accented-char (ch accent)
+  "* Arguments:
+- CH -- an alphabetic character.
+- ACCENT -- another character which must be a member of the set #\^, #\:, #\`,
+#\', #\0.
+-- #\^ -- circumflex
+-- #\: -- diaeresis
+-- #\` -- grave
+-- #\' -- acute
+-- #\0 -- ring (small 'o' as seen above Scandinavian 'a')
+
+* Returns:
+The ASCII character for CH accented according to ACCENT.
+
+* Examples:
+;;; (compose-accented-char #\a #\')  ; returns a with acute accent (ASCII 160)."
+  (declare (character ch) (type =accent-specifier= accent))
+  ;; todo this may break with some other character sets.
+  (case accent
+    (#\^
+     ;; ^a 131 ^e 136 ^i 140 :A 142 ^o 147 ^u 150
+     (case ch
+       (#\a (code-char 131))
+       (#\e (code-char 136))
+       (#\i (code-char 140))
+       (#\o (code-char 147))
+       (#\u (code-char 150))
+       (#\A (code-char 142))
+       (otherwise ch)))
+    (#\:
+     ;; :u 129 :a 132 :e 137 :i 139 :o 148 :O 153 :U 154
+     (case ch
+       (#\a (code-char 132))
+       (#\e (code-char 137))
+       (#\i (code-char 139))
+       (#\o (code-char 148))
+       (#\u (code-char 129))
+       (#\O (code-char 153))
+       (#\U (code-char 154))
+       (otherwise ch)))
+    (#\`  ;; \
+     ;; `a 133 `e 138 `i 141 `o 149 `u 151
+     (case ch
+       (#\a (code-char 133))
+       (#\e (code-char 138))
+       (#\i (code-char 141))
+       (#\o (code-char 149))
+       (#\u (code-char 151))
+       (otherwise ch)))
+    (#\'  ;; /
+     ;; 'e 130 'E 144 'a 160 'i 161 'o 162 'u 163
+     (case ch
+       (#\a (code-char 160))
+       (#\e (code-char 130))
+       (#\i (code-char 161))
+       (#\o (code-char 162))
+       (#\u (code-char 163))
+       (#\E (code-char 144))
+       (otherwise ch)))
+    (#\0
+     ;; 0a 134 0A 143
+     (case ch
+       (#\a (code-char 134))
+       (#\A (code-char 143))
+       (otherwise ch)))
+    (otherwise
+     ch)))
+
+
+(defun string->dialog-codes (str)
+  "Similar to {defun dormouse:string->tcod-colour-codes}, but deals only with
+the directives that create clickable 'dialog buttons' within a string.
+
+STR is a string containing a series of terms separated by commas. Each term
+is either the single character '/', or the name of a colour, or the name of a
+colour prefixed by one of the labels FOREGROUND:, BACKGROUND:, FG:, or BG:, or
+a label prefixed by one of the labels BUTTON:, BTN: or CLICK:."
+  (with-output-to-string (s)
+    (cond
+      ((string= str "/")
+       (format s "~C" (colctrl->char :COLCTRL-STOP)))
+      (t
+       (let* ((props (string->properties str :foreground))
+              (click-label (or (getf props :button)
+                               (getf props :btn)
+                               (getf props :click))))
+	 (when click-label
+	   (multiple-value-bind
+                 (fr fg fb) (decompose-colour
+                             (string->dialog-colour click-label))
+	     (format s "~C~C~C~C"
+		     (colctrl->char :COLCTRL-FORE-RGB)
+		     (code-char (max fr 1))
+		     (code-char (max fg 1))
+		     (code-char (max fb 1))))))))))
+
+
+(defun string->properties (str &optional (default-label :unlabelled))
+  "Given a string found within a pair of TEXT-FORMAT-CHARs, break it
+down into a property list.
+The string is considered to be a list of terms separated by commas.
+Each term may be prefixed with a label and ':', in which case the label
+becomes the keyword associated with the rest of the term in the returned
+property list."
+  (declare (string str))
+  (let ((properties nil))
+    (dolist (term (string-tokenise '(#\,) str))
+      (cond
+	((and (position #\: term)
+	      (> (position #\: term) 0))
+	 (setf (getf properties
+		     (make-keyword (subseq term 0 (position #\: term))))
+	       (subseq term (1+ (position #\: term)))))
+	(t				; default - no label given
+	 (setf (getf properties default-label) term))))
+    properties))
+
+
+  
+(defun string->colournum (str)
+  "Given a string STR, return the colournum that is associated with the
+corresponding keyword."
+  (or (colour (make-keyword str))
+      0))
+
+
+(defun coloured-string-length (str)
+  "Return the number of printable characters in the string STR. In other words,
+return the length of STR when formatting directives are excluded."
+  (iterate
+    (with cnt = 0)
+    (with counting = t)
+    (for c :in-string str)
+    (cond
+      (counting
+       (if (eql c *text-format-start-char*)
+	   (setf counting nil)
+	   ;; else
+	   (incf cnt)))
+      ((eql c *text-format-end-char*)
+       (setf counting t))
+      (t nil))
+    (finally (return cnt))))
+
+
+(defun right-trim-coloured-string (str n)
+  "Return the N rightmost characters of string STR, ignoring fields
+surrounded by { and }."
+  (let ((len (coloured-string-length str)))
+    (cond
+      ((<= len n)
+       str)
+      (t
+       (iterate
+	 (with cnt = 0)
+	 (with c = nil)
+	 (with counting = t)
+	 (for actual :from (1- (length str)) :downto 0)
+	 (setf c (char str actual))
+	 (cond
+	   (counting
+	    (cond
+	      ((eql c *text-format-end-char*)
+	       (setf counting nil))
+	      ;; else
+	      (t
+	       (incf cnt))))
+	   ((eql c *text-format-start-char*)
+	    (setf counting t))
+	   (t nil))
+	 (when (and counting (>= cnt (- len n)))
+	   (return (subseq str actual)))
+	 (finally (return str)))))))
+
+
+(defun left-trim-coloured-string (str n)
+  "Return the N leftmost characters of string STR, ignoring fields
+surrounded by { and }."
+  (let ((len (coloured-string-length str)))
+    (cond
+      ((<= len n)
+       str)
+      (t
+       (iterate
+	 (with cnt = 0)
+	 (with counting = t)
+	 (for c :in-string str)
+	 (for actual :from 0)
+	 (cond
+	   (counting
+	    (cond
+	      ((eql c *text-format-start-char*)
+	       (setf counting nil))
+	      ;; else
+	      (t
+	       (incf cnt))))
+	   ((eql c *text-format-end-char*)
+	    (setf counting t))
+	   (t nil))
+	 (when (and counting (>= cnt n))
+	   (return (subseq str 0 (1+ actual))))
+	 (finally (return str)))))))
+
+
+
+(defun colourise (val fg &optional bg)
+  "Given a value, return it as a string wrapped in directives for 
+  {defgeneric dormouse:write-to-window-at} which will make the value appear in 
+  colours FG[,BG] when written to the screen."
+  (cond
+    (bg
+     (format nil "{fg:~A,bg:~A}~A{/}"
+	     (keyword->string fg)
+	     (keyword->string bg)
+	     val))
+    (t
+     (format nil "{fg:~A}~A{/}"
+	     (keyword->string fg)
+	     val))))
+
+
+
+(defun bar-chart (width num denom
+		  &key (text nil) 
+		  (bar-colour :red) (empty-bar-colour :black)
+		  (text-colour :white))
+  "Returns a colourised string which, when printed using 
+  draw-string-at, will produce a string of solid blocks 
+  WIDTH characters long, coloured BAR-COLOUR for NUM/DENOM * the string's 
+  length, and EMPTY-BAR-COLOUR for the rest of the string.
+
+If TEXT is supplied, then some text will appear in the centre of the bar chart,
+with a foreground colour of TEXT-COLOUR. Possible values for TEXT are:
+
+- A string
+- :FRACTION - ``NUM/DENOM''
+- :PERCENT - a percentage calculated from NUM/DENOM * 100
+- nil (default) - no text.
+
+* Example:
+;;; (bar-chart 20 (hit-points *player*) (max-hit-points *player*)
+;;;    :text :fraction :text-colour :cornsilk) "
+  (declare (type (integer 1) width) (real num denom))
+  (when (zerop denom)
+    (setf denom 1))
+  (let ((bar 
+	 (cond
+           ((eql text :fraction)
+	    (centre-string (format nil "~D/~D" num denom) width))
+           ((eql text :percent)
+	    (centre-string (format nil "~D%" (floor (* num 100) denom)) width))
+           ((stringp text)
+            (centre-string text width))
+           (t   ;; just a bar
+            (spaces width))))
+	(filled-spaces (round (* width (/ (constrain num 0 denom) denom)))))
+    (concatenate 'string
+                 "{fg:" (keyword->string text-colour)
+                 ",bg:" (keyword->string bar-colour) "}"
+                 (subseq bar 0 filled-spaces)
+                 (colourise (subseq bar filled-spaces) text-colour
+                            empty-bar-colour))))
+
+
+
+;;;; ======================================================================
+;;;; (@> "Window")
+;;;; ======================================================================
+
+(defclass <Window> ()
+  ((window-tlx :initform 0 :accessor window-tlx :type integer
+               :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.")
+   (window-tly :initform 0 :accessor window-tly :type integer
+               :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.")
+   (window-width :initform 0 :accessor window-width :type =positive-integer=
+                 :initarg :width :documentation "Width of the window in
+                 columns.")
+   (window-height :accessor window-height :initform 0 :type =positive-integer=
+                  :initarg :height :documentation "Height of the window in
+                  rows.")
+   (window-console :accessor window-console :initform nil :initarg :console
+                   :documentation "Contains the external C console pointer for
+                   the window.")
+   (window-foreground :accessor window-foreground :initform :white :type keyword
+                      :initarg :foreground
+                      :documentation "Default foreground colour for the window.")
+   (window-background :accessor window-background
+                      :initform :dark-grey :type keyword
+                      :initarg :background
+                      :documentation "Default background colour for the window.")
+   (window-children :accessor window-children :initform nil
+                    :type list :initarg :children
+                    :documentation "List of windows which are
+'dependent' on this window. They are hidden, unhidden and
+destroyed along with the window. Also see `WINDOW-RAISE-CHILDREN-WITH-PARENT?'
+below.")
+   (window-raise-children-with-parent?
+    :accessor window-raise-children-with-parent? :initform t
+    :type boolean :documentation  "Are child windows to be raised and
+hidden when the same is done to the parent?")
+   (window-auto-redraw? :accessor window-auto-redraw? :initform nil :type boolean
+                        :documentation "Should this window automatically redraw
+itself if it finds WINDOW-CHANGED? is non-nil?")
+   (window-framed? :accessor window-framed? :initform t
+                   :type boolean :initarg :framed?
+                   :documentation "Should a frame be drawn in the edges of the
+                   window?")
+   (window-can-resize? :accessor window-can-resize? :initform t :type boolean
+                       :initarg :can-resize? :documentation "Can window be
+resized by dragging on the lower right corner with the mouse?")
+   (window-can-drag? :accessor window-can-drag? :initform t :type boolean
+                     :initarg :can-drag?
+                     :documentation "Can the window be dragged around
+the screen with the mouse?")
+   (window-can-close? :accessor window-can-close? :initform t :type boolean
+                      :initarg :can-close?
+                      :documentation "Can the window be closed by clicking on
+an 'X' in its top right corner?")
+   (window-ephemeral? :accessor window-ephemeral? :initform nil
+                      :type boolean :initarg :ephemeral?
+                      :documentation "Ephemeral windows are destroyed
+upon being hidden.")
+   (window-draw-function :accessor window-draw-function :initform nil
+                         :type (or null function) :initarg :draw
+                         :documentation "Function that is called to
+'fill in' the interior of the window when it is drawn or redrawn.")
+   (window-title :accessor window-title :initform nil
+                 :type (or null string) :initarg :title
+                 :documentation "Title of the window.")
+   (window-transparency :accessor window-transparency :initform 25
+                        :initarg :transparency
+                        :documentation "Amount of transparency of the window,
+from 0-100, where 100 = invisible.")
+   ;; Internal bookkeeping slots, usually not accessed by the user.
+   (window-hidden? :accessor window-hidden? :initform nil :type boolean
+                   :documentation "Is this window hidden?")
+   (window-changed? :accessor window-changed? :initform nil :type boolean
+                    :documentation "Can be set to T if the window needs to be
+updated, as a signal to process-window.")
+   (window-alive? :accessor window-alive? :initform t :type boolean
+                  :documentation "Set to nil when a window has been destroyed.")
+   (window-touching :accessor window-touching :initform (list) :type list
+		    :documentation "List of windows that overlap this window."))
+  (:documentation   "* Description: Class whose instances represent windows on
+the screen.
+* Examples: TODO
+* See Also: "))
+	
+
+
+(defun screen-width ()
+  "* Arguments: None.
+* Returns: Integer.
+* Description: Returns the width of the screen (root console) in columns."
+  (tcod:console-get-width tcod:*root*))
+
+
+(defun screen-height ()
+  "* Arguments: None.
+* Returns: Integer.
+* Description: Returns the height of the screen (root console) in rows."
+  (tcod:console-get-height tcod:*root*))
+
+
+
+(defmethod initialize-instance :after ((win <Window>) &key (hidden? nil)
+				       &allow-other-keys)
+  (setf (window-console win) 
+	(console-new (window-width win) (window-height win)))
+  (console-set-foreground-colour (window-console win)
+				 (colour (window-foreground win)))
+  (console-set-background-colour (window-console win)
+				 (colour (window-background win)))
+  ;; Translate negative numbers for TLX,TLY to be relative to the
+  ;; bottom right corner of the screen.
+  (translate-negative-coordinates (window-tlx win) (window-tly win))
+  (cond
+    (hidden?
+     (setf (window-hidden? win) t)
+     (push win *hidden-windows*))
+    (t
+     (touch-windows win)
+     ;; put WIN onto stack
+     (push win *window-stack*))))
+
+
+
+(defmethod process-window ((win <Window>))
+  (unless (window-hidden? win)
+    (when (and (window-auto-redraw? win)
+	     (window-changed? win))
+	(prepare-window win)
+	(redraw-window-area win :draw-window t)
+	(console-flush)
+	(setf (window-changed? win) nil))))
+
+
+
+(defmethod window-parent ((win <Window>))
+  ;; TODO inefficient
+  (find-if #'(lambda (parent) (member win (window-children parent)))
+		(all-windows)))
+
+
+(defmethod destroy-window ((win <Window>))
+  (if (find win *window-stack*)
+      (hide-window win))
+  (when (and (window-console win)
+	     (not (equal *root* (window-console win)))))
+  ;; If it has a parent, remove it from parent's list.
+  (let ((parent (window-parent win)))
+    (if parent
+        (setf (window-children parent)
+              (remove win (window-children parent)))))
+  ;; If it has children, remove them
+  (when (window-children win)
+    (dolist (child (window-children win))
+      (destroy-window child)))
+  (setf *hidden-windows* (remove win *hidden-windows*))
+  (setf (window-alive? win) nil))
+
+
+
+
+(defun destroy-all-windows ()
+  "* Arguments: None.
+* Returns: None.
+* Description: Destroy all existing window objects."
+  (iterate
+    (with wins = nil)
+    (while (setf wins (all-windows)))
+    (destroy-window (car wins))))
+
+
+
+(defmethod touch-windows ((win <Window>))
+  (dolist (other *window-stack*)
+    (when (and (not (equal other win))
+	     (windows-touching? win other))
+	(pushnew other (window-touching win))
+	(pushnew win (window-touching other)))))
+
+
+(defmethod untouch-windows ((win <Window>))
+	(dolist (other (window-touching win))
+		(setf (window-touching other) 
+			(remove win (window-touching other) :test #'equal)))
+	(setf (window-touching win) (list)))
+
+	
+(defmethod move-window ((win <Window>) tlx tly)
+  (translate-negative-coordinates tlx tly)
+  (untouch-windows win)
+  (setf (window-tlx win) tlx)
+  (setf (window-tly win) tly)
+  (touch-windows win))
+
+
+
+(defun window-areas-overlap? (a-tlx a-tly a-brx a-bry
+		       b-tlx b-tly b-brx b-bry)
+  "* Arguments: 
+- A-TLX, A-TLY: coordinates of top left corner of the first area.
+- A-BRX, A-BRY: coordinates of bottom right corner of the first area.
+- B-TLX, B-TLY: coordinates of top left corner of the second area.
+- B-BRX, B-BRY: coordinates of bottom right corner of the second area.
+* Returns: Boolean.
+* Description: Do the two rectangular areas A-TLX,A-TLY==>A-BRX,A-BRY and
+B-TLX,B-TLY==>B-BRX,B-BRY overlap?"
+  (translate-negative-coordinates a-tlx a-tly)
+  (translate-negative-coordinates a-brx a-bry)
+  (translate-negative-coordinates b-tlx b-tly)
+  (translate-negative-coordinates b-brx b-bry)
+  (not (or (< a-brx b-tlx)
+	   (< a-bry b-tly)
+	   (> a-tlx b-brx)
+	   (> a-tly b-bry))))
+
+
+(defmethod window-touches-spot? ((win <Window>) x y)
+  (translate-negative-coordinates x y)
+  (and (<= (window-tlx win) x (window-brx win))
+       (<= (window-tly win) y (window-bry win))))
+
+
+(defmethod windows-touching? ((win <Window>) (other <Window>))
+  (window-areas-overlap?
+   (window-tlx win)  (window-tly win)
+   (window-brx win) (window-bry win)
+   (window-tlx other)  (window-tly other)
+   (window-brx other) (window-bry other)))
+
+
+(defmethod windows-below ((win <Window>))
+  (rest (member win *window-stack*)))
+
+
+(defmethod windows-above ((win <Window>))
+  (subseq *window-stack* 0 (position win *window-stack*)))
+
+
+(defmethod windows-overlying ((win <Window>))
+  (remove-if-not #'(lambda (w) (member w (window-touching win)))
+		 (windows-above win)))
+
+
+(defmethod windows-underlying ((win <Window>))
+  (remove-if-not #'(lambda (w) (member w (window-touching win)))
+		 (windows-below win)))
+
+
+(defmethod windows-overlapping ((win <Window>) &key (include-window? t))
+  (remove-if #'(lambda (win2)
+		 (or (and (not include-window?) (eql win win2))
+		     (not (windows-touching? win win2))))
+	     *window-stack*))
+
+
+(defmethod copy-window-to-console ((win <Window>) con)
+      ;; (warn "xsrc: ~D ysrc: ~D wsrc: ~D hsrc: ~D xdest: ~D ydest: ~D srcw: ~D srch: ~D destw: ~D desth: ~D~%"
+      ;;     0 0 (window-width win) (window-height win)
+      ;;     (window-tlx win) (window-tly win) 
+      ;;     (console-get-width (window-console win))
+      ;;     (console-get-height (window-console win))
+      ;;     (console-get-width con)
+      ;;     (console-get-height con)
+      ;;     )
+      ;; (break)
+  (console-blit (window-console win) 0 0 (window-width win) (window-height win)
+		con (window-tlx win) (window-tly win) 
+		(window-transparency->fade win) (window-transparency->fade win)))
+
+
+
+(defmethod redraw-window ((win <Window>))
+  (copy-window-to-console win *root*))
+
+
+(defun redraw-all-windows ()
+  "* Arguments: None.
+* Returns: None.
+* Description: Copy all visible windows onto the root console."
+  (dolist (win *window-stack*)
+    (prepare-window win))
+  (console-clear *root*)
+  (copy-windows-to-console *window-stack* *root*)
+  (console-flush))
+
+
+(defun copy-windows-to-console (window-list con)
+  "* Arguments: 
+- WINDOW-LIST: a list of instances of {defclass dormouse:<Window>}
+- CON: a C console pointer.
+* Returns: None.
+* Description: Copy (draw) each window in WINDOW-LIST onto the console CON.
+The FIRST window in the list is treated as the 'topmost' window and so
+is copied LAST."
+  (dolist (win (reverse window-list))
+    (copy-window-to-console win con)))
+
+
+(defun copy-console-to-console (src dest)
+  "* Arguments: 
+- SRC, DEST: C console pointers.
+* Returns: None.
+* Description: Copy the entire contents of console SRC onto console DEST."
+  (console-blit src 0 0
+		(console-get-width src) (console-get-height src)
+		dest 0 0 1.0 1.0))
+
+
+(defun window-transparency->fade (win)
+  "* Arguments: 
+- WIN: an instance of {defclass dormouse:<Window>}
+* Returns: A real number between 0 and 1, representing a TCOD 'fade' value.
+* Description: Given a window WIN, convert the value of its WINDOW-TRANSPARENCY
+slot (0-100) to a FADE value (0-1) accepted by the TCOD library."
+  (- 1.0 (/ (window-transparency win) 100.0)))
+
+
+
+(defmethod prepare-window ((win <Window>))
+  (cond
+    ((window-framed? win)
+     
+     (if (eql win (car *window-stack*))
+	 (console-print-double-frame
+	  (window-console win) 0 0
+	  (window-width win) (window-height win) 
+	  t :set (or (window-title win) +NULL+))
+	 ;; else
+	 (console-print-frame
+	  (window-console win) 0 0
+	  (window-width win) (window-height win) 
+	  t :set (or (window-title win) +NULL+)))
+     (when (window-can-close? win)
+       (console-set-char (window-console win) (1- (window-width win))
+			 0 (char-code #\X)))
+     (if (window-can-resize? win)
+	 (console-set-char (window-console win) (1- (window-width win))
+			   (1- (window-height win)) 188)))
+    (t
+     (console-rect (window-console win) 0 0
+		   (window-width win) (window-height win) t :set)))
+  (if (window-draw-function win)
+       (funcall (window-draw-function win) win))
+  (if (window-children win)
+      (dolist (child (window-children win))
+	(when (or (window-raise-children-with-parent? win)
+		  (not (window-hidden? child)))
+	  (prepare-window child)))))
+
+
+
+(defun prepare-windows-by-type (winclass)
+  "* Arguments: 
+- WINCLASS: A symbol naming a subclass of {defclass dormouse:<Window>}.
+* Returns: None.
+* Description: Calls {defgeneric dormouse:prepare-window} for each existing
+window object that inherits from WINCLASS.
+* Examples:
+;;; (prepare-windows-by-type '<Message-Window>)"
+  (dolist (win *window-stack*)
+    (when (typep win winclass)
+      (prepare-window win))))
+
+
+(defun top-window-at (x y &key (windows *window-stack*)
+		      (override-modal? nil))
+  "* Arguments:
+- X, Y: Coordinates of a point on the screen (root console).
+- WINDOWS: List of window objects to consider (default is to consider
+all non-hidden windows).
+- OVERRIDE-MODAL?: Boolean.
+* Returns: A window object or nil.
+* Description:
+Return the window nearest the top of *WINDOW-STACK* which touches X,Y.
+If OVERRIDE-MODAL? is true, then disregard whether a window is modal or
+not in deciding which window to return. If this parameter is nil (default)
+then whenever a modal window is at the top of WINDOW-STACK we can only
+return that window from this function. If that window does not touch X,Y
+then NIL is returned."
+  (translate-negative-coordinates x y)
+  (let ((top (car windows)))
+    (cond
+      ((and (not override-modal?) (modal? top))
+       (if (window-touches-spot? top x y)
+	   top
+	   ;; else
+	   nil))
+      (t
+       (find-if #'(lambda (win) (and (window-touches-spot? win x y)
+				     (not (ghost-window? win))))
+		windows)))))
+
+
+
+(defun windows-at (x y)
+  "* Arguments:
+- X, Y: Coordinates of a point on the screen (root console).
+* Returns: A list of window objects, or nil.
+* Description:
+Return a list of all non-hidden windows that overlie the point at X,Y."
+  (translate-negative-coordinates x y)
+  (remove-if-not #'(lambda (win) (window-touches-spot? win x y))
+		 *window-stack*))
+
+
+(defun window-brx (win)
+  "* Arguments: 
+- WIN: an instance of {defclass dormouse:<Window>}
+* Returns: An X-coordinate.
+* Description:
+Return the X-coordinate of the bottom right corner of the window.
+* See Also: {defun dormouse:window-bry}"
+  (+ (window-tlx win) (1- (window-width win))))
+
+
+(defun window-bry (win)
+  "* Arguments: 
+- WIN: an instance of {defclass dormouse:<Window>}
+* Returns: A Y-coordinate.
+* Description:
+Return the Y-coordinate of the bottom right corner of the window.
+* See Also: {defun dormouse:window-brx}"
+  (+ (window-tly win) (1- (window-height win))))
+
+
+(defmethod resize-window ((win <Window>) width height)
+  "Change the dimensions of window WIN to WIDTH x HEIGHT."
+  (untouch-windows win)
+  (setf (window-console win) (console-new width height))
+  (console-set-foreground-colour (window-console win)
+				 (colour (window-foreground win)))
+  (console-set-background-colour (window-console win)
+				 (colour (window-background win)))
+  (setf (window-width win) width)
+  (setf (window-height win) height)
+  (touch-windows win))
+
+
+
+(defmethod mouse-drag-window ((win <Window>) (rodent mouse))
+  (let ((offsetx (- (mouse-cx rodent) (window-tlx win)))
+	(offsety (- (mouse-cy rodent) (window-tly win)))
+	(tlx 0) (tly 0)
+	(width (window-width win))
+	(height (window-height win))
+	(root-width (console-get-width *root*))
+	(root-height (console-get-height *root*)))
+    ;; draw everything but the window
+    (raise-window win)
+    ;; Draw all windows but this one onto SCRATCH.
+    ;; SCRATCH now represents ROOT "minus" WIN.
+    (copy-windows-to-console (remove win *window-stack*) *scratch*)
+    (console-flush)
+    ;; Save part of root console covered by WIN
+    (console-blit *scratch* (window-tlx win) (window-tly win)
+		  width height
+		  *temp-con* 0 0 1.0 1.0)
+    (copy-console-to-console *scratch* *root*)
+    (copy-window-to-console win *root*)
+    (console-flush)
+    (iterate
+      (while (mouse-lbutton (setf rodent (mouse-get-status))))
+      ;; Update position of WIN based on mouse position
+      (setf tlx (constrain (- (mouse-cx rodent) offsetx)
+			   0 (- root-width width 1)))
+      (setf tly (constrain (- (mouse-cy rodent) offsety)
+			   0 (- root-height height 1)))
+      (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
+		      width height
+		      *root* (window-tlx win) (window-tly win) 1.0 1.0)
+	;; "move" WIN to the new position
+	(move-window win tlx tly)
+	;; save the part of the root console which WIN covers
+	(console-blit *scratch* tlx tly
+		      width height
+		      *temp-con* 0 0 1.0 1.0)
+	;; copy WIN to root
+	(copy-window-to-console win *root*))
+      ;; Refresh root console
+      (console-flush))))
+
+
+(defmethod mouse-resize-window ((win <Window>) (rodent mouse))
+  (let ((brx 0) (bry 0))
+    ;; draw everything but the window
+    (raise-window win)
+    (copy-windows-to-console (remove win *window-stack*) *scratch*)
+    ;; Save part of root console covered by WIN
+    (console-blit *scratch* (window-tlx win) (window-tly win)
+		  (window-width win) (window-height win)
+		  *temp-con* 0 0 1.0 1.0)
+    (copy-console-to-console *scratch* *root*)
+    (copy-window-to-console win *root*)
+    (console-flush)
+    (iterate
+      (while (mouse-lbutton (setf rodent (mouse-get-status))))
+      ;; Update position of WIN based on mouse position.  Don't allow the mouse
+      ;; to go above or to left of the top left corner of the window.
+      (setf brx (constrain (mouse-cx rodent) (window-tlx win) 
+			   (1- (console-get-width *root*))))
+      (setf bry (constrain (mouse-cy rodent) (window-tly win) 
+			   (1- (console-get-height *root*))))
+      (unless (and (= brx (window-brx win)) (= bry (window-bry win)))
+	;; copy saved win to root  at WIN's old position (erasing WIN)
+	(console-blit *temp-con* 0 0
+		      (window-width win) (window-height win)
+		      *root* (window-tlx win) (window-tly win) 1.0 1.0)
+	;; Resize WIN (might be smaller)
+	(resize-window win (1+ (- brx (window-tlx win))) 
+		       (1+ (- bry (window-tly win))))
+	(prepare-window win)
+	;; save the part of the root console which WIN now covers
+	(console-blit *scratch* (window-tlx win) (window-tly win)
+		      (window-width win) (window-height win)
+		      *temp-con* 0 0 1.0 1.0)
+	;; copy WIN to root
+	(copy-window-to-console win *root*))
+      ;; Refresh root console
+      (console-flush))))
+
+
+(defmethod raise-window ((win <Window>) &key (redraw *auto-redraw*)
+			 (simple-redraw? nil) &allow-other-keys)
+  (setf *window-stack* (remove win *window-stack* :test #'equal))
+  (setf *hidden-windows* (remove win *hidden-windows* :test #'equal))
+  (setf (window-hidden? win) nil)
+  (setf (window-changed? win) t)
+  (push win *window-stack*)
+  (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?))))
+  (when redraw
+    (if simple-redraw?
+	(copy-window-to-console win *root*)
+	;; else
+	(redraw-window-area win))))
+
+
+
+(defmethod hide-window ((win <Window>) &key (redraw *auto-redraw*))
+  (when redraw
+    (redraw-window-area win :draw-window nil))
+  (untouch-windows win)
+  (setf *window-stack* (remove win *window-stack* :test #'equal))
+  (if (and (window-raise-children-with-parent? win)
+	   (window-children win))
+      (dolist (child (window-children win))
+	(hide-window child)))
+  (cond
+    ((window-ephemeral? win)
+     (destroy-window win))
+    (t
+     (setf (window-hidden? win) t)
+     (pushnew win *hidden-windows* :test #'equal))))
+
+
+
+(defmethod send-key-to-window :before ((win <Window>) (k key) winx winy)
+  ;; Ctrl-Esc and Ctrl-F1 are defined here as universal "shut down the
+  ;; gui loop" keys.
+  (declare (ignore winx winy))
+  (when (key-pressed k)
+    (when (and (member (key-vk k) (list :escape :f1))
+               (or (key-lctrl k)
+                   (key-rctrl k))
+               (not (key-shift k))
+               (not (key-lalt k))
+               (not (key-ralt k)))
+      (setf *exit-gui?* t)
+      k)))
+
+
+
+
+(defmethod on-border? ((win <Window>) winx winy)
+  (or (= winx 0)
+      (= winx (1- (window-width win)))
+      (= winy 0)
+      (= winy (1- (window-height win)))))
+
+
+
+(defmethod on-lower-window-border? ((win <Window>) winx winy)
+  (and (= winy (1- (console-get-height (window-console win))))
+       (> winx 0)
+       (< winx (1- (console-get-width (window-console win))))))
+
+
+
+(defmethod on-upper-window-border? ((win <Window>) winx winy)
+  (and (= winy 0)
+       (> winx 0)
+       (< winx (1- (console-get-width (window-console win))))))
+
+
+
+(defmethod window-draw-char-at ((win <Window>) (ch integer) winx winy
+				&key (background-flag :set)
+				(fg nil) (bg nil) (redraw *auto-redraw*))
+  (console-draw-char-at (window-console win) ch winx winy
+			:background-flag background-flag
+			:fg fg :bg bg)
+  (when redraw
+    (redraw-all-at (winx->rootx win winx) (winy->rooty win winy))))
+;;    (window-redraw-at win (winx->rootx winx) (winy->rooty winy))))
+
+
+
+(defmethod console-draw-char-at (con (ch integer) winx winy
+			     &key (background-flag :set)
+				(fg nil) (bg nil))
+  (cond
+    ((and fg bg)
+     ;; New in libtcod 1.4.3
+     (console-put-char-ex con winx winy ch (colour fg) (colour bg)))
+    ((or fg bg)
+     (console-set-char con winx winy ch)
+     (if fg
+	 (console-set-fore con winx winy (colour fg)))
+     (if bg
+	 (console-set-back con winx winy (colour bg) background-flag)))
+    (t
+     (console-put-char con winx winy ch background-flag)))
+  ;; todo restore old values after printing
+  )
+
+
+(defmethod window-draw-char-at ((win <Window>) (ch character) winx winy
+				&key (background-flag :set) (fg nil) (bg nil)
+				(redraw *auto-redraw*))
+  (window-draw-char-at win (char-code ch) winx winy
+		       :background-flag background-flag :fg fg :bg bg
+		       :redraw redraw))
+
+
+(defmethod draw-string-at ((win <Window>) str winx winy
+			   &key (fg nil) (bg nil) (redraw *auto-redraw*))
+  (declare (ignorable redraw))
+  (cond
+    ((or fg bg)
+     (if fg
+	 (console-set-foreground-colour (window-console win) (colour fg)))
+     (if bg
+	 (console-set-background-colour (window-console win) (colour bg)))
+     (console-print-left (window-console win) winx winy :set
+			 (make-coloured-string str :win win))
+     (if fg
+	 (console-set-foreground-colour (window-console win)
+					(colour (window-foreground win))))
+     (if bg
+	 (console-set-background-colour (window-console win)
+					(colour (window-background win)))))
+    (t
+     (console-print-left (window-console win) winx winy :set
+			 (make-coloured-string str :win win)))))
+
+
+
+
+(defun rootx->winx (win rootx)
+  "* Arguments: 
+- WIN: an instance of {defclass dormouse:<Window>}.
+- ROOTX: An X-coordinate on the screen (root console).
+* Returns: Integer. 
+* Description: Given the screen X-coordinate ROOTX, return the X-coordinate
+of the same screen point relative to the top left corner of the window WIN.
+* Examples:
+;;; (rootx->winx mywin 10)  ; if top left corner of mywin is at (8,8)
+;;;                         ; then this returns 2
+* See Also:
+- {defun dormouse:rooty->winy}"
+  (- rootx (window-tlx win)))
+
+(defun rooty->winy (win rooty)
+  "* Arguments: 
+- WIN: an instance of {defclass dormouse:<Window>}.
+- ROOTY: A Y-coordinate on the screen (root console).
+* Returns: Integer. 
+* Description: Given the screen Y-coordinate ROOTY, return the Y-coordinate
+of the same screen point relative to the top left corner of the window WIN.
+* Examples:
+;;; (rooty->winy mywin 10)  ; if top left corner of mywin is at (8,8)
+;;;                         ; then this returns 2
+* See Also:
+- {defun dormouse:rootx->winx}"
+  (- rooty (window-tly win)))`<
+
+(defun winx->rootx (win winx)
+  "* Arguments: 
+- WIN: an instance of {defclass dormouse:<Window>}.
+- WINX: An X-coordinate relative to the top left corner of WIN.
+* Returns: Integer.
+* Description: Given the X-coordinate WINX, which is relative to the top left
+corner of WIN, return the absolute X-coordinate of the same screen point, i.e.
+its console X-coordinate.
+* Examples:
+;;; (winx->rootx mywin 5)  ; if top left corner of mywin is at (8,8)
+;;;                         ; then this returns 13
+* See Also:
+- {defun dormouse:winy->rooty}"
+  (+ winx (window-tlx win)))
+
+(defun winy->rooty (win winy)
+  "* Arguments: 
+- WIN: an instance of {defclass dormouse:<Window>}.
+- WINY: A Y-coordinate relative to the top left corner of WIN.
+* Returns: Integer.
+* Description: Given the Y-coordinate WINY, which is relative to the top left
+corner of WIN, return the absolute Y-coordinate of the same screen point, i.e.
+its console Y-coordinate.
+* Examples:
+;;; (winy->rooty mywin 5)  ; if top left corner of mywin is at (8,8)
+;;;                         ; then this returns 13
+* See Also:
+- {defun dormouse:winx->rootx}"
+  (+ winy (window-tly win)))
+
+
+
+(defmethod window-redraw-at ((win <Window>) rootx rooty)
+  (translate-negative-coordinates rootx rooty)
+  (if (window-touches-spot? win rootx rooty)
+      (console-blit (window-console win)
+		    (rootx->winx win rootx)
+		    (rooty->winy win rooty)
+		    1 1 *root* rootx rooty
+		    (window-transparency->fade win)
+                    (window-transparency->fade win))))
+
+
+
+(defmethod redraw-window-in-area (win1 rootx1 rooty1 rootx2 rooty2)
+  "Redraw that portion of WIN which lies within the rectangle X1,Y1 -> X2,Y2
+on the root console."
+  (translate-negative-coordinates rootx1 rooty1)
+  (translate-negative-coordinates rootx2 rooty2)
+  (let* ((tlx (max (window-tlx win1) rootx1))
+	 (tly (max (window-tly win1) rooty1))
+	 (brx (min (window-brx win1) rootx2))
+	 (bry (min (window-bry win1) rooty2)))
+    (console-blit (window-console win1)
+		  (rootx->winx win1 tlx)
+		  (rooty->winy win1 tly)
+		  (- brx (1- tlx)) (- bry (1- tly))
+		  *root* tlx tly (window-transparency->fade win1)
+                  (window-transparency->fade win1))))
+
+
+(defmethod redraw-window-intersection (win1 win2)
+  (redraw-window-in-area win1 (window-tlx win2) (window-tly win2)
+			 (window-brx win2) (window-bry win2)))
+
+
+(defmethod redraw-intersecting-windows-below ((win <Window>))
+  (dolist (w (reverse (windows-underlying win)))
+    (redraw-window-intersection w win)))
+
+
+(defmethod redraw-intersecting-windows-above ((win <Window>))
+  (dolist (w (reverse (windows-overlying win)))
+    (redraw-window-intersection w win)))
+
+
+(defun redraw-window-area (win &key (draw-window t))
+  "* Arguments: 
+- WIN: an instance of {defclass dormouse:<Window>}
+- DRAW-WINDOW: Boolean (default: T)
+* Returns: None.
+* Description: Force the area of the screen covered by WIN to be redrawn.
+If DRAW-WINDOW is non-nil, also redraw WIN itself; otherwise just redraw
+all the other windows underlying WIN."
+  (unless draw-window
+    (console-set-background-colour *root* (colour :true-black))  ; needed?
+    (console-rect *root* (window-tlx win) (window-tly win)
+		  (window-width win) (window-height win) t :set))
+  (when (and draw-window (window-children win)) ;
+    (dolist (child (window-children win))
+      (unless (window-hidden? child)
+	(redraw-window-area child)) :draw-window t))
+  (dolist (w (nreverse (windows-overlapping win :include-window? draw-window)))
+    (redraw-window-intersection w win))
+  (console-flush))
+
+
+(defun redraw-all-at (rootx rooty)
+  "* Arguments: 
+- ROOTX, ROOTY: Coordinates of a point on the screen (root console).
+* Returns: None.
+* Description: Force all windows which touch the screen at ROOTX, ROOTY
+to be redrawn."
+  (dolist (w (reverse *window-stack*))
+    (window-redraw-at w rootx rooty)))
+
+
+
+(defmethod send-to-window ((win <Window>) data parm winx winy)
+  (declare (ignore data parm winx winy))
+  nil)
+
+
+
+(defmethod send-to-window ((win <Window>) (data (eql :left-drag))
+			   rodent winx winy)
+  (let ((topwin nil))
+    ;; draw everything but the window
+    (raise-window win)
+    (iterate
+      (while (mouse-lbutton (setf rodent (mouse-get-status))))
+      (setf topwin (top-window-at (mouse-cx rodent) (mouse-cy rodent)))
+      (when topwin
+	(raise-window topwin :redraw t))
+      (console-flush))
+    ;; Stopped dragging.
+    (when topwin
+      (mouse-drag win topwin