Commit 7e6b2703 authored by David O'Toole's avatar David O'Toole

fix up window container

parent 475bf3dd
......@@ -522,8 +522,8 @@
(layout self))
(defmethod draw :before ((self frame))
(multiple-value-bind (top left right bottom) (bounding-box frame)
(draw-patch self left top right bottom :color "gray80" :style :rounded)))
(multiple-value-bind (top left right bottom) (bounding-box self)
(draw-patch self left top right bottom :color "gray30" :style :rounded)))
;; (defmethod as-drag ((self menu) x y)
;; (make-menu-frame self))
This diff is collapsed.
This diff is collapsed.
* Task list
** TODO general window container class
** TODO fix de-selecting objects when opening menubar
** TODO right click pop up menus
** TODO pinnable pop up menus
** TODO allow tear-off menus
;;; turtle.lisp --- turtle graphics example
(defpackage #:turtle
(:use #:cl #:xelf)
(:export turtle))
;; Copyright (C) 2011 David O'Toole
;; Author: David O'Toole <>
;; Keywords: games
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <>.
;;; Preamble
(setf *screen-width* 640)
(setf *screen-height* 480)
(setf *use-antialiased-text* t)
(setf *window-title* "turtle demo")
(setf *resizable* t)
(enable-key-repeat 9 2)
;;; Defining a turtle
(:name "turtle" :type :image :file "turtle.png")
(:name "dot" :type :image :file "dot.png"))
(defclass turtle (node)
((image :initform "turtle")
(lines :initform nil)
(states :initform nil)
(color :initform "black")
(drawing :initform t)
(methods '(:pen-down :pen-up :turn-left :turn-right
:go-forward :pen-ink :save-state :restore-state :clear-lines :sing))))
(defmethod click ((self turtle) x y)
(declare (ignore x y))
(setf *target* self))
(defun radian-angle (degrees)
"Convert DEGREES to radians."
(* degrees (float (/ pi 180))))
(defmethod (pen-down) turtle ()
(setf (slot-value self 'drawing) t))
(defmethod (pen-up) turtle ()
(setf (slot-value self 'drawing) nil))
(defmethod (pen-ink) turtle
((color string :default "black"
:documentation "test"))
(setf (slot-value self 'color) color))
(defmethod (turn-left) turtle ((degrees number :default 90))
(decf (slot-value self 'heading) (radian-angle degrees)))
(defmethod (turn-right) turtle ((degrees number :default 90))
(incf (slot-value self 'heading) (radian-angle degrees)))
(defmethod add-line ((self turtle) x0 y0 x y &key color)
(push (list x0 y0 x y :color color)
(slot-value self 'lines)))
(defmethod (clear-lines) turtle ()
(setf (slot-value self 'lines) nil))
(defmethod (go-forward) turtle ((distance number :default 40))
(with-slots (x y heading height width drawing color) self
(let ((x0 (+ x (/ width 2)))
(y0 (+ y (/ width 2))))
(let ((dx (* distance (cos heading)))
(dy (* distance (sin heading))))
(incf x dx)
(incf y dy)
(when drawing
(add-line self x0 y0
(+ x0 dx)
(+ y0 dy)
:color color))))))
(defmethod (save-state) turtle ()
(push (list (slot-value self 'x) (slot-value self 'y) (slot-value self 'heading) (slot-value self 'color))
(slot-value self 'states)))
(defresource (:name "turtle-theme" :type :music :file "turtle.xm"))
(defmethod (sing) turtle ((song string :default "turtle-theme"))
(if (zerop (length song))
(play-music song :loop t)))
(defmethod (restore-state) turtle ()
(destructuring-bind (x y heading color)
(pop (slot-value self 'states))
(setf (slot-value self 'x) x (slot-value self 'y) y (slot-value self 'color) color
(slot-value self 'heading) heading)))
(defmethod draw ((self turtle))
(dolist (line (slot-value self 'lines))
(apply #'draw-line line))
(super(slot-value self 'draw) self)
(let ((distance 6))
(with-slots (x y heading height width drawing color) self
(let ((x0 (floor (+ x (/ width 2))))
(y0 (floor (+ y (/ width 2)))))
(let ((dx (* distance (cos heading)))
(dy (* distance (sin heading))))
(draw-image "dot" (+ x0 dx -2) (+ y0 dy -2)))))))
;;; A ladybug
(defresource (:name "ladybug" :type :image :file "ladybug.png"))
(defresource (:name "wandering" :type :music :file "wandering.xm"))
(defclass ladybug (node)
(image :initform "ladybug")
(methods :initform '(:chirp :wander :sit-quietly :sing))
(moving :initform nil)
(speed :initform 0.5)
(direction :initform (random-direction)))
(defmethod update ((self ladybug))
(when (slot-value self 'moving)
(percent-of-time 0.1 (setf (slot-value self 'direction) (random-direction)))
(move self (slot-value self 'direction) (slot-value self 'speed))))
(defmethod wander ladybug ((speed number :default 0.15))
(setf (slot-value self 'moving) t (slot-value self 'speed) speed))
(defmethod sit-quietly ladybug ()
(setf (slot-value self 'moving) nil))
(defresource (:name "chirp" :type :sample :file "chirp.wav" :properties (:volume 80)))
(defmethod sing ((self ladybug) &optional (string "wandering"))
(when (> (length song)
(play-music song :loop t)))
(defmethod chirp ((self ladybug))
(play-sample "chirp"))
;;; A meadow for the ladybug
(defclass meadow (node)
((image :initform "meadow.png")))
(defmethod accept ((self meadow) other)
(defun turtle ()
(start (new shell (new block))))
;;; turtle.lisp ends here
(in-package :turtle)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment