Commit 0ae564ed authored by Alastair Bridgewater's avatar Alastair Bridgewater
Browse files

Initial check-in.

  * This is a bit of a grab-bag of things intended to grow towards
being an implementation of the parts of the CLIM standard that
actually make sense to me.

  * Anything in the root directory is either a test driver program
or support code for the test driver, more to have something that
works to start from than to become part of the final system.

  * Anything in tests/ is stale test code for something that has
been swiped from another project (or earlier incarnation of
nq-clim).

  * There is an implementaion of SPACE-REQUIREMENTs in layout/,
not because we are anywhere near implementing the layout protocol
but because it was a convenient abstraction when setting up some
of the support code in its original context.

  * And the rest is a "spike" for drawing mediums, the most
fundamental output protocol in CLIM.  It's thin, but it works.
parents
*.fasl
*~
;;;
;;; nq-clim/backend/clx/medium
;;;
;;; CLX medium implementation
;;;
(cl:defpackage :nq-clim/backend/clx/medium
(:use :cl
:nq-clim/medium/drawing
:nq-clim/medium/basic-medium)
(:export
"CLX-MEDIUM"
"MAKE-CLX-MEDIUM"))
(cl:in-package :nq-clim/backend/clx/medium)
(defclass clx-medium (basic-medium)
((drawable :initarg drawable)
(gcontext :initarg gcontext)))
(defun make-clx-medium (drawable gcontext)
(make-instance 'clx-medium 'drawable drawable 'gcontext gcontext))
(defmethod medium-draw-line* ((medium clx-medium) x1 y1 x2 y2)
(with-slots (drawable gcontext)
medium
(xlib:draw-line drawable gcontext x1 y1 x2 y2)))
;;; EOF
;;;
;;; clx-interface.lisp
;;;
;;; Interface to CLX for gaming stuff.
;;;
(cl:defpackage :game-stuff/clx-interface
(:use :cl :nq-clim/layout/space-requirement)
(:export
"*DISPLAY*"
"*WINDOW*"
"WITH-X11-DISPLAY"
;; For some reason, these don't appear to be defind in CLX.
"+XK-UP+"
"+XK-DOWN+"
"+XK-LEFT+"
"+XK-RIGHT+"
"+XK-ESC+"
"+XK-ENTER+"))
(cl:in-package :game-stuff/clx-interface)
;;; Important external variables.
(defvar *display* nil "The X display connection.")
(defvar *window* nil "The X window we draw in.")
;; For some reason, CLX doesn't appear to have these keysyms defined.
(defconstant +xk-up+ #xff52)
(defconstant +xk-left+ #xff51)
(defconstant +xk-right+ #xff53)
(defconstant +xk-down+ #xff54)
(defconstant +xk-esc+ #xff1b)
(defconstant +xk-enter+ #xff0d)
;; Internal default values.
(defparameter *default-window-height* 240)
(defparameter *default-window-width* 256)
(defparameter *default-window-title* "CLX Interface Window")
#+(or)
(defun handle-glx-init-kludges (display)
;; GLX doesn't (yet) tell the server what it needs to know
;; automatically, so we need to tell it to do so now.
(glx::client-info display)
;; If the GLX context isn't destroyed properly then the context
;; information hangs around in a special variable to confuse things
;; when next a GLX connection is made.
(setf glx::*current-context* nil))
(defun init-display (&key display-name space-requirement window-title)
(setf *display* (xlib:open-default-display display-name))
#+(or)
(handle-glx-init-kludges *display*)
(let* ((screen (xlib:display-default-screen *display*))
(root (xlib:screen-root screen))
#+(or)
(visual (glx:choose-visual screen '(:glx-rgba
(:glx-red-size 1)
(:glx-green-size 1)
(:glx-blue-size 1)
:glx-double-buffer)))
#+(or)
(colormap (xlib:create-colormap (glx:visual-id visual) root))
#+(or)
(visual-depth (glx:visual-attribute visual :glx-depth-size))
(black-pixel (xlib:screen-black-pixel screen))
(white-pixel (xlib:screen-white-pixel screen))
(width (or (and space-requirement
(space-requirement-width space-requirement))
*default-window-width*))
(height (or (and space-requirement
(space-requirement-height space-requirement))
*default-window-height*))
(window (xlib:create-window :parent root
:x 0 :y 0 :width width :height height
:background white-pixel
:border black-pixel
;:visual (glx:visual-id visual)
;:depth visual-depth
;:colormap colormap
:event-mask '(:exposure))))
(setf *window* window)
(setf (xlib:wm-name window)
(or window-title *default-window-title*))
(when space-requirement
(multiple-value-bind
(width min-width max-width height max-height min-height)
(space-requirement-components space-requirement)
(setf (xlib:wm-normal-hints window)
(xlib:make-wm-size-hints
:width width :min-width min-width :max-width max-width
:height height :min-height min-height :max-height max-height))))
(xlib:map-window window)
;; Set up a GLX context for us to use.
#+(or)
(glx:make-current window
(glx:create-context screen
(glx:visual-id visual)))))
(defun close-display ()
;; It is sufficient to drop the reference to *window*, as closing
;; the display automatically releases all server resources.
(setf *window* nil)
(when *display*
(xlib:close-display *display*))
(setf *display* nil))
(defun call-with-x11-display (fun &key display-name space-requirement
window-title)
(unwind-protect
(progn
(init-display :display-name display-name
:space-requirement space-requirement
:window-title window-title)
(funcall fun))
(close-display)))
(defmacro with-x11-display ((&key display-name space-requirement window-title)
&body body)
`(call-with-x11-display (lambda () ,@body)
:display-name ,display-name
:space-requirement ,space-requirement
:window-title ,window-title))
;;; EOF
;;;
;;; layout/space-requirement.lisp
;;;
;;; The space-requirement class part of CLIM II 29.3.4 (layout protocol).
;;;
(cl:defpackage :nq-clim/layout/space-requirement
(:use :cl)
(:export
;; The protocol class
"SPACE-REQUIREMENT"
;; The constructor
"MAKE-SPACE-REQUIREMENT"
;; The accessors
"SPACE-REQUIREMENT-WIDTH"
"SPACE-REQUIREMENT-MIN-WIDTH"
"SPACE-REQUIREMENT-MAX-WIDTH"
"SPACE-REQUIREMENT-HEIGHT"
"SPACE-REQUIREMENT-MIN-HEIGHT"
"SPACE-REQUIREMENT-MAX-HEIGHT"
"SPACE-REQUIREMENT-COMPONENTS"
;; Manipulation functions
"SPACE-REQUIREMENT-COMBINE"
"SPACE-REQUIREMENT-+"
"SPACE-REQUIREMENT-+*"
))
(cl:in-package :nq-clim/layout/space-requirement)
;; The protocol class. Users are permitted to subclass this in order
;; to allow other objects to serve as space-requirement objects.
(defclass space-requirement () ())
;; The accessor functions. Forward-declared, as their methods are all
;; defined in defclass forms as slot readers.
(defgeneric space-requirement-width (space-req))
(defgeneric space-requirement-min-width (space-req))
(defgeneric space-requirement-max-width (space-req))
(defgeneric space-requirement-height (space-req))
(defgeneric space-requirement-min-height (space-req))
(defgeneric space-requirement-max-height (space-req))
;; The "other" accessor function, forward-declared for consistency.
(defgeneric space-requirement-components (space-req))
;; The implementation class.
(defclass standard-space-requirement (space-requirement)
((width :initarg width :reader space-requirement-width)
(max-width :initarg max-width :reader space-requirement-max-width)
(min-width :initarg min-width :reader space-requirement-min-width)
(height :initarg height :reader space-requirement-height)
(max-height :initarg max-height :reader space-requirement-max-height)
(min-height :initarg min-height :reader space-requirement-min-height)))
;; A standard way to grab all of the slots of a space-requirement at
;; one time.
(defmethod space-requirement-components
((space-req standard-space-requirement))
(with-slots (width min-width max-width
height min-height max-height)
space-req
(values width min-width max-width
height min-height max-height)))
;; The constructor. Returns an immutable space-requirement object.
(defun make-space-requirement (&key
(width 0) (max-width 0) (min-width 0)
(height 0) (max-height 0) (min-height 0))
(make-instance 'standard-space-requirement
'width width 'max-width max-width 'min-width min-width
'height height 'max-height max-height 'min-height min-height))
;; Combining two space requirements by some function. While this
;; doesn't seem particularly useful at first glance, a
;; vertical-stacking layout could obtain the space-requirements of its
;; children, combine with #'+ and #'MAX, destructure the two results,
;; take the width data from the MAX result and the height data from
;; the + result, and pass the mess off to make-space-requirement.
(defun space-requirement-combine (function sr1 sr2)
;; Rather than write anything out long-hand, why not be clever for
;; once? We have a list of slots-that-matter, a way to obtain a
;; list of the values of the slots from a space-requirement, and a
;; constructor that takes keyword arguments. Historically, I'd have
;; used a LOOP form, but for some reason the mapping functions
;; called to me this time...
(apply #'make-space-requirement
(mapcan (lambda (key sr1-value sr2-value)
(list key (funcall function sr1-value sr2-value)))
'(:width :min-width :max-width
:height :min-height :max-height)
(multiple-value-list (space-requirement-components sr1))
(multiple-value-list (space-requirement-components sr2)))))
;; Combine two space-requirements by adding each corresponding slot.
(defun space-requirement-+ (sr1 sr2)
(space-requirement-combine #'+ sr1 sr2))
;; Combine two space requirements, one of which is specified by the
;; keyword arguments (as if they were to MAKE-SPACE-REQUIREMENT).
;; This is supposed to somehow be more efficient than calling
;; MAKE-SPACE-REQUIREMENT on the caller-side, and it probably would be
;; if we inlined and unrolled SPACE-REQUIREMENT-COMBINE, but it also
;; probably would be lost in the noise due to space requirements not
;; changing all that often in normal operation.
(defun space-requirement-+* (space-req &rest args &key
width min-width max-width
height min-height max-height)
(declare (ignore width min-width max-width
height min-height max-height))
(space-requirement-+ space-req
(apply #'make-space-requirement args)))
;;; EOF
;;;
;;; nq-clim/medium/basic-medium
;;;
;;; The "abstract" medium class dealing with "user transformations".
;;;
(cl:defpackage :nq-clim/medium/basic-medium
(:use :cl
:nq-clim/medium/medium
:nq-clim/medium/drawing)
(:export
"BASIC-MEDIUM"))
(cl:in-package :nq-clim/medium/basic-medium)
(defclass basic-medium (medium)
;; FIXME: This is the hook for "user" transformations.
())
#+(or)
(defmethod medium-draw-line* :around ((medium basic-medium) x1 y1 x2 y2)
;; FIXME: Transform the points (x1,y1) and (x2,y2), then
;; call-next-method with the transformed points.
)
;;; EOF
;;;
;;; nq-clim/medium/drawing
;;;
;;; Medium drawing protocol functions.
;;;
(cl:defpackage :nq-clim/medium/drawing
(:use :cl)
(:export
"MEDIUM-DRAW-LINE*"))
(cl:in-package :nq-clim/medium/drawing)
(defgeneric medium-draw-line* (medium x1 y1 x2 y2))
;;; EOF
;;;
;;; nq-clim/medium/medium
;;;
;;; MEDIUM protocol class.
;;;
(cl:defpackage :nq-clim/medium/medium
(:use :cl)
(:export
"MEDIUM"
"MEDIUMP"))
(cl:in-package :nq-clim/medium/medium)
(defclass medium () ())
(defgeneric mediump (object))
(defmethod mediump ((object t))
nil)
(defmethod mediump ((object medium))
t)
;;; EOF
;;;
;;; rendering_1.lisp
;;;
;;; Sample implementation of the first rendering model
;;; for the Dungeon Crawl Project.
;;;
;;; Alastair Bridgewater, October 9th, 2004.
;;;
;;; Damaged again in may 2009.
;;;
;;; Damaged yet again in December, 2012.
;;;
(defpackage :rendering-1
(:use :common-lisp
:nq-clim/medium/drawing
:nq-clim/backend/clx/medium
:nq-clim/layout/space-requirement
:game-stuff/clx-interface)
(:export "START-EXAMPLE"))
(in-package :rendering-1)
(defparameter *raw-map-data*
'("xxxxxxxxxxxxxxxx"
"x.xxxxxxxxx...xx"
"x....x.....xx..x"
"x.xx...xxx.xxx.x"
"x.xxxxxxxx...x.x"
"x......xxxxx.x.x"
"xxxxxx.xxxxx.x.x"
"xxxxx....xx..x.x"
"xxxxx.xx.xx.x..x"
"xx....xxxxx.x.xx"
"xx.xx...xxx.x..x"
"xx.xxxx...x.xx.x"
"xx.xxxxxx...xx.x"
"xx.xx....xxx...x"
"xx....xx.....xxx"
"xxxxxxxxxxxxxxxx")
"The raw map data, in easily editable form.")
(declaim (type (simple-array t (#x100)) *map-data*))
(defvar *map-data* (make-array #x100)
"Map data. Each cell is either T for a wall or NIL for empty space.")
(defvar *position* #x11 "Position of player within *map-data*.")
(defvar *facing* :south "Direction player is facing.")
(defvar *frontstep* 0)
(defvar *leftstep* 0)
(defparameter *frontstep-list* '(:north -16 :south 16 :west -1 :east 1)
"alist from directions to index change within map data to move forward.")
(defparameter *leftstep-list* '(:north -1 :south 1 :west 16 :east -16)
"alist from directions to index change within map data to move left.")
(defparameter *leftturn-list* '(:north :west :west :south :south :east :east :north)
"alist from direction to direction for turning left.")
(defparameter *rightturn-list* '(:north :east :east :south :south :west :west :north)
"alist from direction to direction for turning right.")
(defvar *medium* nil "The CLIM MEDIUM we draw on.")
(defvar *context* nil "The X graphics context we draw with.")
(defun init-map-data ()
"Convert the raw map data in *raw-map-data* to the internal representation in *map-data*."
(let ((row-number 0))
(dolist (row-data *raw-map-data*)
(dotimes (i 16)
(setf (aref *map-data* (+ i (* 16 row-number)))
(char= (aref row-data i) #\x)))
(incf row-number)))
(values))
(defun set-facing (direction)
"Set the player to be facing in DIRECTION. Sets up *frontstep* and *leftstep* for rendering and motion control."
(setf *facing* direction)
(setf *frontstep* (getf *frontstep-list* direction))
(setf *leftstep* (getf *leftstep-list* direction)))
(defun turn-left ()
"Turn the player 90 degrees to the left."
(set-facing (getf *leftturn-list* *facing*)))
(defun turn-right ()
"Turn the player 90 degrees to the right."
(set-facing (getf *rightturn-list* *facing*)))
(defun move-forward ()
"Move the player one space forward if there is no wall ahead."
(if (not (aref *map-data* (+ *position* *frontstep*)))
(setf *position* (+ *position* *frontstep*))))
(defun draw-line (x1 y1 x2 y2)
#+(or)
(xlib:draw-line *window* *context* x1 y1 x2 y2)
(medium-draw-line* *medium* x1 y1 x2 y2))
(defun draw-left-side (position base size)
(if (aref *map-data* (+ position *leftstep*))
(progn
;; There is a wall to the left of this position, so we draw it.
(draw-line base base (+ base size) (+ base size))
(draw-line base (- 255 base) (+ base size) (- 255 base size)))
(progn
;; There is no wall to the left of this position, so there is one
;; ahead of it. We draw that one.
(draw-line base (+ base size) (+ base size) (+ base size))
(draw-line base (- 255 base size) (+ base size) (- 255 base size))))
;; Draw the vertical line for this wall segment.
(draw-line (+ base size) (+ base size) (+ base size) (- 255 base size)))
(defun draw-right-side (position base size)
(if (aref *map-data* (- position *leftstep*))
(progn
;; There is a wall to the right of this position, so we draw it.
(draw-line (- 255 base) base (- 255 base size) (+ base size))
(draw-line (- 255 base) (- 255 base) (- 255 base size) (- 255 base size)))
(progn
;; There is no wall to the right of this position, so there is one
;; ahead of it. We draw that one.
(draw-line (- 255 base) (+ base size) (- 255 base size) (+ base size))
(draw-line (- 255 base) (- 255 base size) (- 255 base size) (- 255 base size))))
;; Draw the vertical line for this wall segment.
(draw-line (- 255 base size) (+ base size) (- 255 base size) (- 255 base size)))
(defun draw-maze ()
"Draw the maze as seen from the player's current position and facing."
(let ((base 0)
(position *position*))
(dotimes (depth 4)
;; size values determined empirically.
(let ((size (elt '(10 50 40 15) depth)))
(draw-left-side position base size)
(draw-right-side position base size)
(incf position *frontstep*)
(incf base size)
;; Draw the facing wall if there is one.
(when (aref *map-data* position)
(draw-line base base (- 255 base) base)
(draw-line base (- 255 base) (- 255 base) (- 255 base))
(return-from draw-maze)))))
(values))
(defun force-redraw ()
(xlib:clear-area *window* :x 0 :y 0 :width 256 :height 256 :exposures-p t))
(defun create-gc (screen)
(setf *context* (xlib:create-gcontext :foreground (xlib:screen-black-pixel screen)
:background (xlib:screen-white-pixel screen)
:line-width 1 :cap-style :projecting
:drawable (xlib:screen-root screen))))
(defun run-event-loop ()
(xlib:event-case
(*display*)
(:exposure
()
(draw-maze)
nil)
(:button-release
()
t)
(:key-press
(code)
(let ((keysym (xlib:keycode->keysym *display* code 0)))
(declare (integer keysym))
(cond
;; For some reason, the keysyms I need aren't defined in CLX.
((= keysym +xk-left+) (turn-left) (force-redraw))
((= keysym +xk-right+) (turn-right) (force-redraw))
((= keysym +xk-up+) (move-forward) (force-redraw))))
nil)))
(defun start-example ()
"run the example renderer, connecting to an X display on HOST."
(init-map-data)
(setf *position* #x11)
(set-facing :south)
(with-x11-display (:space-requirement
(make-space-requirement
:width 256 :height 256
:min-width 256 :min-height 256
:max-width 256 :max-height 256)
:window-title "Dungeon Crawl -- Rendering 1")
(create-gc (xlib:display-default-screen *display*))
(setf *medium* (make-clx-medium *window* *context*))
(setf (xlib:window-event-mask *window*)
(xlib:make-event-mask :button-press :button-release
:exposure :key-press))
(run-event-loop))
(values))
;;; EOF
;;;
;;; space-requirement-tests.lisp
;;;
;;; Tests for space-requirement behavior.
;;;
(cl:defpackage :game-stuff/space-requirement$tests
(:use :cl :sb-rt :game-stuff/space-requirement))
(cl:in-package :game-stuff/space-requirement$tests)
;; Make sure that we can create a space-requirement and get values
;; from it.
(deftest value-holder
(let ((space-req (make-space-requirement
:width 1 :max-width 2 :min-width 3
:height 4 :max-height 5 :min-height 6)))
(assert (typep space-req 'space-requirement))
(assert (= 1 (space-requirement-width space-req)))
(assert (= 2 (space-requirement-max-width space-req)))
(assert (= 3 (space-requirement-min-width space-req)))
(assert (= 4 (space-requirement-height space-req)))
(assert (= 5 (space-requirement-max-height space-req)))
(assert (= 6 (space-requirement-min-height space-req)))
(assert (equal '(1 3 2 4 6 5)
(multiple-value-list
(space-requirement-components space-req))))
t)
t)
;; Make sure that the default values for make-space-requirement are
;; correct.
(deftest (make-space-requirement default-parameters)
(multiple-value-list
(space-requirement-components
(make-space-requirement)))
(0 0 0 0 0 0))
;; Make sure that combination basically works, and that the values
;; line up correctly.
(deftest (combination *)
(let ((sr1 (make-space-requirement :width 1 :max-width 2 :min-width 3
:height 4 :max-height 5 :min-height 6))
(sr2 (make-space-requirement
:width 10 :max-width 100 :min-width 1000
:height 10000 :max-height 100000 :min-height 1000000)))
(multiple-value-list
(space-requirement-components
(space-requirement-combine #'* sr1 sr2))))
(10 3000 200 40000 6000000 500000))
;; Make sure that combination is non-commutative in the correct direction.
(deftest (combination -)
(let ((sr1 (make-space-requirement :width 1 :max-width 2 :min-width 3
:height 4 :max-height 5 :min-height 6))
(sr2 (make-space-requirement
:width 10 :max-width 20 :min-width 30
:height 40 :max-height 50 :min-height 60)))