rendered paste body;;;; $Id$
#|
Copyright (c) 2008, Matthew Mondor
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
THIS SOFTWARE IS PROVIDED BY MATTHEW MONDOR ``AS IS'' AND ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL MATTHEW MONDOR BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|#
#|
Implementation of a very simple widget kit library for SDL.
XXX
- Widget positions should probably be relative to a window.
- The way widget actions is to be dispatched to user code still
has to be defined.
- Functions to define easily widget sets like a menu should be written.
- Some widgets should be activated/deactivated like text widgets
via a mouse click. These should then grab key inputs which are not
menu or application key shortcuts.
- Some types of windows should be closed when a mouse click occurs outside
of them or at a particular key shortcut (i.e. menu windows).
|#
(require 'lispbuilder-sdl)
(require 'lispbuilder-sdl-gfx)
(defpackage :mm-widget
(:use :cl)
(:nicknames :widget)
(:export
#:widget))
(in-package :widget)
(declaim (optimize (speed 1) (safety 2) (debug 2)))
(defclass box-color ()
((background :reader background
:initarg :background
:type sdl:color)
(left :reader left
:initarg :left
:type sdl:color)
(top :reader top
:initarg :top
:type sdl:color)
(right :reader right
:initarg :right
:type sdl:color)
(bottom :reader bottom
:initarg :bottom
:type sdl:color)
(text :reader text
:initarg :text
:type sdl:color)))
;;; XXX Rework these colors
(defparameter *window-box*
(make-instance 'box-color
:background (sdl:color :r 160 :g 160 :b 160)
:left (sdl:color :r 255 :g 255 :b 255)
:top (sdl:color :r 200 :g 200 :b 200)
:right (sdl:color :r 0 :g 0 :b 0)
:bottom (sdl:color :r 60 :g 60 :b 60)
:text (sdl:color :r 0 :g 0 :b 100)))
(defparameter *shining-box*
(make-instance 'box-color
:background (sdl:color :r 180 :g 180 :b 180)
:left (sdl:color :r 255 :g 255 :b 255)
:top (sdl:color :r 200 :g 200 :b 200)
:right (sdl:color :r 0 :g 0 :b 0)
:bottom (sdl:color :r 60 :g 60 :b 60)
:text (sdl:color :r 0 :g 0 :b 0)))
(defparameter *shadowed-box*
(make-instance 'box-color
:background (sdl:color :r 100 :g 100 :b 100)
:left (sdl:color :r 0 :g 0 :b 0)
:top (sdl:color :r 60 :g 60 :b 60)
:right (sdl:color :r 220 :g 220 :b 220)
:bottom (sdl:color :r 200 :g 200 :b 200)
:text (sdl:color :r 0 :g 0 :b 0)))
(defparameter *disabled-color*
(sdl:color :r 0 :g 0 :b 0 :a 64))
(defun box-border (rectangle color)
(with-accessors ((x sdl:x) (y sdl:y) (w sdl:width) (h sdl:height)) rectangle
(let ((w (1- w)) (h (1- h)))
(declare (type fixnum w h))
(sdl-gfx:draw-line-* x
(+ y (1- h))
x
y
:color (left color))
(sdl-gfx:draw-line-* x
y
(+ x w)
y
:color (top color))
(sdl-gfx:draw-line-* (+ x w)
(1+ y)
(+ x w)
(+ y h)
:color (right color))
(sdl-gfx:draw-line-* (+ x (1- w))
(+ y h)
x
(+ y h)
:color (bottom color)))))
(defun box-thick (rectangle color thickness)
(declare (type fixnum thickness))
;;; Note: sdl-gfx:draw-box has a bug forgetting to -1 x+w and y+h.
(sdl:draw-box rectangle :color (background color))
(let ((r (sdl:rectangle)))
(sdl:set-rectangle r rectangle)
(with-accessors ((x sdl:x) (y sdl:y) (w sdl:width) (h sdl:height)) r
(loop
repeat thickness
do
(box-border r color)
(incf x)
(incf y)
(decf w 2)
(decf h 2)))))
(defclass window ()
((rectangle :accessor window-rectangle
:initarg :rectangle
:initform nil
:type sdl:rectangle)
(surface :accessor window-surface
:initarg :surface
:initform nil
:type sdl:surface)
(title :accessor window-title
:initarg :title
:initform "Anonymous"
:type string)
(close-p :reader window-close-p
:initarg :close-p
:initform nil
:type boolean)
(close-unfocused-p :reader window-closed-unfocused-p
:initarg :closed-unfocused-p
:initform nil
:type boolean)
(widgets :accessor window-widgets
:initarg :widgets
:initform nil
:type list)
(down-widget :accessor window-down-widget
:initform nil
:type widget)))
(defgeneric draw (object))
(defmethod draw ((window window))
(with-accessors ((rectangle window-rectangle)
(title window-title)
(widgets window-widgets)) window
(box-thick rectangle *window-box* 3)
(with-accessors ((bx sdl:x) (by sdl:y) (bw sdl:width)) rectangle
(sdl:draw-string-solid-* title
(+ bx (/ bw 2))
(+ by *widgets-font-width*)
:justify :center
:font *widgets-font*
:color (text *window-box*)))
(loop for w in widgets do
;;; XXX These need to be drawn relative to the window's position.
;;; It would be possible to have the constructor setup the positions
;;; by modifying the rectangles of the widgets, but unfortunately
;;; this would no longer work if we decide that windows may eventually
;;; be movable.
;;; Don't forget to add the new generic function for drawing widgets
;;; if we add window position information.
(draw w))
(sdl:update-display)))
(defgeneric event-down (object x y))
(defmethod event-down ((window window) (x fixnum) (y fixnum))
(loop for w in (window-widgets window) do
(unless (widget-disabled-p w)
(when (event-down w x y)
(setf (window-down-widget window) w)
(loop-finish)))))
(defgeneric event-drag (object x y))
(defmethod event-drag ((window window) (x fixnum) (y fixnum))
(with-accessors ((down window-down-widget)) window
(when down
(event-drag down x y))))
(defgeneric event-up (object x y))
(defmethod event-up ((window window) (x fixnum) (y fixnum))
(with-accessors ((down window-down-widget)) window
(when down
(event-up down x y)
(setf down nil))))
(defclass widget ()
((rectangle :accessor widget-rectangle
:initarg :rectangle
:initform nil
:type sdl:rectangle)
(disabled-p :accessor widget-disabled-p
:initarg :disabled-p
:initform nil
:type boolean)))
(defmethod draw ((widget widget)))
(defmethod event-down ((widget widget) (x fixnum) (y fixnum))
nil)
(defmethod event-drag ((widget widget) (x fixnum) (y fixnum)))
(defmethod event-up ((widget widget) (x fixnum) (y fixnum)))
(defclass box (widget)
((thickness :accessor box-thickness
:initarg :thickness
:initform 3
:type boolean)
(shadowed-p :accessor box-shadowed-p
:initarg :shadowed-p
:initform nil
:type boolean)))
(defmethod draw ((box box))
(with-accessors ((rectangle widget-rectangle)
(shadowed-p box-shadowed-p)
(thickness box-thickness)
(disabled-p widget-disabled-p)) box
(box-thick rectangle
(if shadowed-p *shadowed-box* *shining-box*)
thickness)
(when disabled-p
;;; sdl-gfx:draw-box is buggy...
(sdl:draw-box rectangle :color *disabled-color* :alpha t))))
(defgeneric update (box))
(defmethod update ((box box))
(sdl:update-surface (window-surface *active-window*)
(widget-rectangle box)))
(defgeneric toggle (box))
(defmethod toggle ((box box))
(setf (box-shadowed-p box) (not (box-shadowed-p box)))
(draw box)
(update box))
(defgeneric within (box x y))
(defmethod within ((box box) (x fixnum) (y fixnum))
(with-accessors ((bx sdl:x) (by sdl:y) (bw sdl:width) (bh sdl:height))
(widget-rectangle box)
(and (> x bx)
(> y by)
(< x (+ bx bw))
(< y (+ by bh)))))
(defclass panel (box)
((title :type string
:accessor panel-title
:initarg :title)))
(defmethod draw ((panel panel))
(call-next-method)
(with-accessors ((bx sdl:x) (by sdl:y) (bw sdl:width))
(widget-rectangle panel)
(sdl:draw-string-solid-* (panel-title panel)
(+ bx (/ bw 2))
(+ by *widgets-font-width*)
:justify :center
:font *widgets-font*
:color (text *window-box*))))
(defclass button (box)
((label :accessor button-label
:initarg :label
:type string
:initform "?")))
(defmethod draw ((button button))
(call-next-method)
(with-accessors ((bx sdl:x) (by sdl:y) (bw sdl:width) (bh sdl:height))
(widget-rectangle button)
(sdl:draw-string-solid-* (button-label button)
(+ bx (/ bw 2))
(+ by (- (/ bh 2) *widgets-font-height-half*))
:justify :center
:font *widgets-font*
:color (if (box-shadowed-p button)
(text *shadowed-box*)
(text *shining-box*)))))
(defmethod event-down ((button button) (x fixnum) (y fixnum))
(when (within button x y)
(toggle button)
t))
(defmethod event-drag ((button button) (x fixnum) (y fixnum)))
(defmethod event-up ((button button) (x fixnum) (y fixnum))
(when (within button x y)
(warn "hit!")) ; XXX
(toggle button))
;;;; The following consist of two test widgets catching drag events.
;;;; The first produces a box which may be moved around;
;;;; The second a box which may be resized.
(defclass dragbox (box) ())
(defmethod event-down ((dragbox dragbox) (x fixnum) (y fixnum))
(when (within dragbox x y)
(toggle dragbox)
t))
(defmethod event-drag ((dragbox dragbox) (x fixnum) (y fixnum))
(with-accessors ((px sdl:x) (py sdl:y)) (widget-rectangle dragbox)
(setf px x
py y))
;; XXX Redrawing all widgets is suboptimal.
(draw *active-window*))
(defmethod event-up ((dragbox dragbox) (x fixnum) (y fixnum))
(toggle dragbox))
(defclass sizebox (box) ())
(defmethod event-down ((sizebox sizebox) (x fixnum) (y fixnum))
(when (within sizebox x y)
(toggle sizebox)
t))
(defmethod event-drag ((sizebox sizebox) (x fixnum) (y fixnum))
(with-accessors ((px sdl:x) (py sdl:y) (pw sdl:width) (ph sdl:height))
(widget-rectangle sizebox)
(setf pw (max 16 (- x px))
ph (max 16 (- y py))))
;; XXX Redrawing all widgets is suboptimal.
(draw *active-window*))
(defmethod event-up ((sizebox sizebox) (x fixnum) (y fixnum))
(toggle sizebox))
(defparameter *active-window* nil)
(defparameter *widgets-font* (sdl:initialise-font sdl:*font-8x8*))
(defparameter *widgets-font-width* 8)
(defparameter *widgets-font-height* 8)
(defparameter *widgets-font-width-half* 4)
(defparameter *widgets-font-height-half* 4)
(defun window-loop (window)
(let ((*active-window* window))
(sdl:with-surface (surface (window-surface *active-window*))
(setf (sdl:frame-rate) 24)
(draw window)
(sdl:with-events ()
(:quit-event () t)
(:key-down-event (:key key)
(case key
(:sdl-key-escape
(sdl:push-quit-event))
(:sdl-key-space
(draw-widgets))))
(:mouse-button-down-event (:x x :y y)
(event-down *active-window* x y))
(:mouse-motion-event (:x x :y y)
(event-drag *active-window* x y))
(:mouse-button-up-event (:x x :y y)
(event-up *active-window* x y))
(:video-expose-event ()
(draw *active-window*))
(:idle ())))))
(defun test ()
(sdl:with-init ()
(let ((surface
(sdl:window 640 480
:bpp 32
:title-caption "Test"
:flags '(sdl:sdl-doublebuf
sdl:sdl-hw-surface
sdl:sdl-hw-accel))))
(window-loop
(make-instance
'window
:rectangle (sdl:rectangle :x 0 :y 0 :w 640 :h 480)
:title "Test window"
:surface surface
:widgets (list
(make-instance 'panel
:rectangle
(sdl:rectangle :x 0 :y 0 :w 320 :h 240)
:title "Test!")
(make-instance 'button
:rectangle
(sdl:rectangle :x 16 :y 32 :w 100 :h 32)
:label "Button 1!"
:disabled-p t)
(make-instance 'button
:rectangle
(sdl:rectangle :x 118 :y 32 :w 100 :h 32)
:thickness 6
:label "Button 2!")
(make-instance 'dragbox
:rectangle
(sdl:rectangle :x 200 :y 200 :w 32 :h 32)
:thickness 3)
(make-instance 'sizebox
:rectangle
(sdl:rectangle :x 250 :y 250 :w 32 :h 32)
:thickness 3)))))))