diff options
| -rw-r--r-- | Makefile.am | 4 | ||||
| -rw-r--r-- | chickadee/data/quadtree.scm | 338 | ||||
| -rw-r--r-- | doc/api.texi | 111 | ||||
| -rw-r--r-- | examples/quadtree.scm | 178 |
4 files changed, 630 insertions, 1 deletions
diff --git a/Makefile.am b/Makefile.am index 9a108d5..6bcc25a 100644 --- a/Makefile.am +++ b/Makefile.am @@ -50,6 +50,7 @@ SOURCES = \ chickadee/data/heap.scm \ chickadee/data/array-list.scm \ chickadee/data/queue.scm \ + chickadee/data/quadtree.scm \ chickadee/data/grid.scm \ chickadee/data/path-finding.scm \ chickadee/math.scm \ @@ -99,7 +100,8 @@ SOURCES = \ chickadee/cli/bundle.scm TESTS = \ - tests/math/vector.scm + tests/math/vector.scm \ + tests/data/quadtree.scm TEST_EXTENSIONS = .scm SCM_LOG_COMPILER = $(top_builddir)/test-env $(GUILE) diff --git a/chickadee/data/quadtree.scm b/chickadee/data/quadtree.scm new file mode 100644 index 0000000..731faf2 --- /dev/null +++ b/chickadee/data/quadtree.scm @@ -0,0 +1,338 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2021 David Thompson <davet@gnu.org> +;;; +;;; Chickadee 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. +;;; +;;; Chickadee is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 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 +;;; <http://www.gnu.org/licenses/>. + +(define-module (chickadee data quadtree) + #:use-module (chickadee math rect) + #:use-module (ice-9 format) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:export (make-quadtree + quadtree? + quadtree-leaf? + quadtree-bounds + quadtree-max-depth + quadtree-max-size + quadtree-depth + quadtree-size + quadtree-q1 + quadtree-q2 + quadtree-q3 + quadtree-q4 + quadtree-clear! + quadtree-insert! + quadtree-delete! + quadtree-find + quadtree-fold + quadtree-for-each)) + +;; The quadrants: +;; +;; *------*------* +;; | | | +;; | Q2 | Q1 | +;; | | | +;; *------*------* +;; | | | +;; | Q3 | Q4 | +;; | | | +;; *------*------* +(define-record-type <quadtree> + (%make-quadtree bounds max-depth max-size depth size objects leaf?) + quadtree? + (bounds quadtree-bounds) + (max-depth quadtree-max-depth) + (max-size quadtree-max-size) + (depth quadtree-depth) + (size quadtree-size set-quadtree-size!) + (objects quadtree-objects set-quadtree-objects!) + (leaf? quadtree-leaf? set-quadtree-leaf!) + (q1 quadtree-q1 set-quadtree-q1!) + (q2 quadtree-q2 set-quadtree-q2!) + (q3 quadtree-q3 set-quadtree-q3!) + (q4 quadtree-q4 set-quadtree-q4!)) + +(define (display-quadtree quadtree port) + (format port "#<quadtree bounds: ~s depth: ~d size: ~d>" + (quadtree-bounds quadtree) + (quadtree-depth quadtree) + (quadtree-size quadtree))) + +(set-record-type-printer! <quadtree> display-quadtree) + +(define* (make-quadtree bounds #:key (max-size 5) (max-depth 4)) + "Return a new quadtree that covers the area BOUNDS. Each node will +try to hold at maximum MAX-SIZE objects and the tree depth will be +restricted to MAX-DEPTH." + (%make-quadtree bounds max-depth max-size 0 0 (make-vector max-size #f) #t)) + +(define (quadtree-empty? quadtree) + "Return #t if QUADTREE has no objects." + (= (quadtree-size quadtree) 0)) + +(define (quadtree-empty-leaf? quadtree) + "Return #t if QUADTREE is an empty leaf node." + (and (quadtree-empty? quadtree) (quadtree-leaf? quadtree))) + +(define (quadtree-full? quadtree) + "Return #t if QUADTREE is at or over desired maximum capacity." + (>= (quadtree-size quadtree) (quadtree-max-size quadtree))) + +(define (quadtree-max-depth? quadtree) + "Return #t if QUADTREE is at the maximum allowed depth." + (= (quadtree-depth quadtree) (quadtree-max-depth quadtree))) + +(define (quadtree-clear! quadtree) + "Clear QUADTREE." + (vector-fill! (quadtree-objects quadtree) #f) + (set-quadtree-size! quadtree 0) + (unless (quadtree-leaf? quadtree) + (set-quadtree-leaf! quadtree #t) + (quadtree-clear! (quadtree-q1 quadtree)) + (quadtree-clear! (quadtree-q2 quadtree)) + (quadtree-clear! (quadtree-q3 quadtree)) + (quadtree-clear! (quadtree-q4 quadtree)))) + +(define (quadtree-split! quadtree) + "Split QUADTREE region into 4 smaller child nodes." + (let* ((max-depth (quadtree-max-depth quadtree)) + (max-size (quadtree-max-size quadtree)) + (depth (+ (quadtree-depth quadtree) 1)) + (length (vector-length (quadtree-objects quadtree))) + (bounds (quadtree-bounds quadtree)) + (x (rect-x bounds)) + (y (rect-y bounds)) + (hw (/ (rect-width bounds) 2.0)) + (hh (/ (rect-height bounds) 2.0))) + (define (make-node x y) + (%make-quadtree (make-rect x y hw hh) max-depth max-size depth 0 + (make-vector length #f) #t)) + (set-quadtree-leaf! quadtree #f) + (unless (quadtree-q1 quadtree) + (set-quadtree-q1! quadtree (make-node (+ x hw) (+ y hh))) + (set-quadtree-q2! quadtree (make-node x (+ y hh))) + (set-quadtree-q3! quadtree (make-node x y)) + (set-quadtree-q4! quadtree (make-node (+ x hw) y))))) + +(define (pick-node quadtree rect) + "Return the child node of QUADTREE that fully contains RECT, or +QUADTREE if RECT overlaps multiple child nodes." + (let* ((bounds (quadtree-bounds quadtree)) + (bx (rect-x bounds)) + (by (rect-y bounds)) + (bw (rect-width bounds)) + (bh (rect-height bounds)) + (mid-x (+ bx (/ bw 2.0))) + (mid-y (+ by (/ bh 2.0))) + (x (rect-x rect)) + (y (rect-y rect)) + (w (rect-width rect)) + (h (rect-height rect))) + (cond + ;; Rect does not overlap this node. + ((or (>= x (+ bx bw)) + (<= (+ x w) bx) + (>= y (+ by bh)) + (<= (+ y h) by)) + #f) + ((quadtree-leaf? quadtree) + quadtree) + ;; Rect is within the left two quadrants: Q2 and Q3. + ((and (< x mid-x) (< (+ x w) mid-x)) + (cond + ;; Rect is within Q3. + ((and (< y mid-y) (< (+ y h) mid-y)) + (quadtree-q3 quadtree)) + ;; Rect is within Q2. + ((> y mid-y) + (quadtree-q2 quadtree)) + ;; Rect spans both Q2 and Q3. + (else quadtree))) + ;; Rect is within the right two quadrants: Q1 and Q4. + ((and (> x mid-x)) + (cond + ;; Rect is within Q4. + ((and (< y mid-y) (< (+ y h) mid-y)) + (quadtree-q4 quadtree)) + ;; Rect is within Q1. + ((> y mid-y) + (quadtree-q1 quadtree)) + ;; Rect spans both Q1 and Q4. + (else quadtree))) + (else quadtree)))) + +(define (quadtree-add! quadtree rect object) + "Add OBJECT to the list of objets in QUADTREE." + (let ((objects (quadtree-objects quadtree)) + (size (quadtree-size quadtree))) + (when (= size (vector-length objects)) + (let* ((new-size (* size 2)) + (new-objects (make-vector new-size #f))) + (let loop ((i 0)) + (when (< i size) + (vector-set! new-objects i (vector-ref objects i)) + (loop (+ i 1)))) + (set-quadtree-objects! quadtree new-objects))) + (vector-set! (quadtree-objects quadtree) size (cons rect object)) + (set-quadtree-size! quadtree (+ size 1)))) + +(define (quadtree-merge-maybe! quadtree) + "Remove child nodes if they are all empty leaf nodes." + (when (and (quadtree-empty-leaf? (quadtree-q1 quadtree)) + (quadtree-empty-leaf? (quadtree-q2 quadtree)) + (quadtree-empty-leaf? (quadtree-q3 quadtree)) + (quadtree-empty-leaf? (quadtree-q4 quadtree))) + ;; We don't actually get rid of the child nodes. This means that + ;; the quadtree can take more memory than it has to, but it also + ;; means that the quadtree doesn't allocate needlessly when + ;; objects are constantly being added/removed. + (set-quadtree-leaf! quadtree #t))) + +(define (quadtree-insert! quadtree rect object) + "Insert OBJECT with bounding box RECT into QUADTREE." + (let ((node (pick-node quadtree rect))) + (cond + ;; The rect doesn't fit into the parent node. + ((not node) + #f) + ;; The rect fits completely within one of the child nodes, so + ;; descend into that node and repeat the process. + ((not (eq? quadtree node)) + (quadtree-insert! node rect object)) + ;; The node is a leaf node that is at or over the desired + ;; capacity, so we need to split it and redistribute the objects. + ;; Nodes that have reached the maximum allowed depth cannot be + ;; split. + ((and (quadtree-full? quadtree) + (quadtree-leaf? quadtree) + (not (quadtree-max-depth? quadtree))) + (let ((objects (quadtree-objects quadtree)) + (size (quadtree-size quadtree))) + (quadtree-split! quadtree) + (let loop ((i 0)) + (if (< i size) + (let ((obj (vector-ref objects i))) + (loop (+ i 1)) + (quadtree-insert! quadtree (car obj) (cdr obj))) + (begin + (set-quadtree-size! quadtree 0) + (vector-fill! objects #f)))) + (quadtree-insert! quadtree rect object) + (quadtree-merge-maybe! quadtree))) + ;; The node is either under the desired maximum objects threshold + ;; or has no choice but to accept another object because there is + ;; no child node that fully contains the rect or we have reached + ;; the maximum allowed tree depth. + (else + (quadtree-add! quadtree rect object))))) + +(define (quadtree-delete! quadtree rect object) + "Delete OBJECT, who occupies the space RECT, from QUADTREE." + (let ((node (pick-node quadtree rect))) + (cond + ((not node) + #f) + ((eq? quadtree node) + (let ((objects (quadtree-objects quadtree)) + (size (quadtree-size quadtree))) + (let loop ((i 0)) + (cond + ((= i size) + #f) + ((eq? (cdr (vector-ref objects i)) object) + (let ((new-size (- size 1))) + (vector-set! objects i (vector-ref objects new-size)) + (vector-set! objects new-size #f) + (set-quadtree-size! quadtree new-size) + #t)) + (else + (loop (+ i 1))))))) + (else + (and (quadtree-delete! node rect object) + (begin + (quadtree-merge-maybe! quadtree) + #t)))))) + +(define (quadtree-find quadtree rect pred) + "Return the first object in QUADTREE in the vicinity of RECT that +satisfies PRED." + (let ((objects (quadtree-objects quadtree)) + (size (quadtree-size quadtree)) + (next-node (pick-node quadtree rect))) + (if next-node + (let loop ((i 0)) + (if (< i size) + (let ((object (cdr (vector-ref objects i)))) + (if (pred object) + object + (loop (+ i 1)))) + (cond + ((and (eq? next-node quadtree) (not (quadtree-leaf? quadtree))) + (or (quadtree-find (quadtree-q1 quadtree) rect pred) + (quadtree-find (quadtree-q2 quadtree) rect pred) + (quadtree-find (quadtree-q3 quadtree) rect pred) + (quadtree-find (quadtree-q4 quadtree) rect pred))) + ((eq? next-node quadtree) + #f) + (else + (quadtree-find next-node rect pred))))) + #f))) + +(define (quadtree-fold quadtree rect init proc) + "Apply PROC to all objects in the vicinity of RECT in QUADTREE to +build a result and return that result. INIT is the initial result. +If there are no objects in the vicinity of RECT, just INIT is +returned." + (let ((objects (quadtree-objects quadtree)) + (size (quadtree-size quadtree)) + (next-node (pick-node quadtree rect))) + (if next-node + (let loop ((i 0) + (memo init)) + (if (< i size) + (loop (+ i 1) (proc (cdr (vector-ref objects i)) memo)) + (cond + ((and (eq? next-node quadtree) (not (quadtree-leaf? quadtree))) + (let* ((q1 (quadtree-fold (quadtree-q1 quadtree) rect memo proc)) + (q2 (quadtree-fold (quadtree-q2 quadtree) rect q1 proc)) + (q3 (quadtree-fold (quadtree-q3 quadtree) rect q2 proc))) + (quadtree-fold (quadtree-q4 quadtree) rect q3 proc))) + ((eq? next-node quadtree) + memo) + (else + (quadtree-fold next-node rect memo proc))))) + init))) + +(define (quadtree-for-each quadtree rect proc) + "Call PROC for all objects in the vicinity of RECT in QUADTREE." + (let ((objects (quadtree-objects quadtree)) + (size (quadtree-size quadtree)) + (next-node (pick-node quadtree rect))) + (when next-node + (let loop ((i 0)) + (when (< i size) + (proc (cdr (vector-ref objects i))) + (loop (+ i 1)))) + (cond + ((and (eq? next-node quadtree) (not (quadtree-leaf? quadtree))) + (quadtree-for-each (quadtree-q1 quadtree) rect proc) + (quadtree-for-each (quadtree-q2 quadtree) rect proc) + (quadtree-for-each (quadtree-q3 quadtree) rect proc) + (quadtree-for-each (quadtree-q4 quadtree) rect proc)) + ((eq? next-node quadtree) + *unspecified*) + (else + (quadtree-for-each next-node rect proc)))))) diff --git a/doc/api.texi b/doc/api.texi index 96803b8..f3b8013 100644 --- a/doc/api.texi +++ b/doc/api.texi @@ -5210,10 +5210,121 @@ Clear all messages and scripts awaiting messages in @var{channel}. @section Data Structures @menu +* Quadtrees:: Spatial partitioning with recursive subdivision. * Grids:: Spatial partitioning with a fixed grid. * Path Finding:: Generic A* path finding. @end menu +@node Quadtrees +@subsection Quadtrees + +The @code{(chickadee data quadtree)} module provides a 2D spatial +partitioning implementation known as a ``quadtree''. A quadtree +recursively subdivides the world into rectangular quadrants. This +data structure is very useful for handling broad-phase collision +detection because it can quickly determine the objects that may +possibly be colliding with another, resulting in fewer narrow-phase +collision tests that are typically much more expensive. + +@deffn {Procedure} make-quadtree bounds [#:max-size 5] [#:make-depth 4] +Return a new quadtree that covers the area @var{bounds}. Each node +will try to hold at maximum @var{max-size} objects and the tree depth +will be restricted to @var{max-depth}. +@end deffn + +@deffn {Procedure} quadtree? obj +Return @code{#t} if @var{obj} is a quadtree. +@end deffn + +@deffn {Procedure} quadtree-clear! quadtree +Clear all objects from @var{quadtree}. +@end deffn + +@deffn {Procedure} quadtree-insert! quadtree rect object +Insert @var{object} with bounding box @var{rect} into @var{quadtree}. +@end deffn + +@deffn {Procedure} quadtree-delete! quadtree rect object +Delete @var{object}, who occupies the space @var{rect}, from +@var{quadtree}. +@end deffn + +@deffn {Procedure} quadtree-find rect pred +Return the first object in @var{quadtree} in the vicinity of +@var{rect} that satisfies @var{pred}. +@end deffn + +@deffn {Procedure} quadtree-fold quadtree rect init proc +Apply @var{proc} to all objects in the vicinity of @var{rect} in +@var{quadtree} to build a result and return that result. @var{init} +is the initial result. If there are no objects in the vicinity of +@var{rect}, just @var{init} is returned. +@end deffn + +@deffn {Procedure} quadtree-for-each quadtree rect proc +Call @var{proc} for all objects in the vicinity of @var{rect} in +@var{quadtree}. +@end deffn + +@deffn {Procedure} quadtree-leaf? quadtree +Return @code{#t} if @var{quadtree} is a leaf node. +@end deffn + +@deffn {Procedure} quadtree-bounds quadtree +Return the bounding rectangle of @var{quadtree}. +@end deffn + +@deffn {Procedure} quadtree-max-depth quadtree +Return the maximum depth of @var{quadtree}. +@end deffn + +@deffn {Procedure} quadtree-max-size quadtree +Return the desired per-node maximum object count of @var{quadtree}. +@end deffn + +@deffn {Procedure} quadtree-depth quadtree +Return the depth of the node @var{quadtree}. +@end deffn + +@deffn {Procedure} quadtree-size quadtree +Return the number of objects stored in the node @var{quadtree}. +@end deffn + +Non-leaf nodes always have four child nodes, which correspond to the +quadrants of a Cartesian coordinate system: + +@verbatim +*------*------* +| | | +| Q2 | Q1 | +| | | +*------*------* +| | | +| Q3 | Q4 | +| | | +*------*------* +@end verbatim + +@deffn {Procedure} quadtree-q1 quadtree +Return the upper-right child node of @var{quadtree}, or @code{#f} if +@var{quadtree} is a leaf node. +@end deffn + +@deffn {Procedure} quadtree-q2 quadtree +Return the upper-left child node of @var{quadtree}, or @code{#f} if +@var{quadtree} is a leaf node. +@end deffn + +@deffn {Procedure} quadtree-q3 quadtree +Return the lower-left child node of @var{quadtree}, or @code{#f} if +@var{quadtree} is a leaf node. +@end deffn + +@deffn {Procedure} quadtree-q4 quadtree +Return the lower-right child node of @var{quadtree}, or @code{#f} if +@var{quadtree} is a leaf node. +@end deffn + @node Grids @subsection Grids diff --git a/examples/quadtree.scm b/examples/quadtree.scm new file mode 100644 index 0000000..31b8138 --- /dev/null +++ b/examples/quadtree.scm @@ -0,0 +1,178 @@ +(use-modules (chickadee) + (chickadee data quadtree) + (chickadee math) + (chickadee math matrix) + (chickadee math rect) + (chickadee math vector) + (chickadee graphics color) + (chickadee graphics font) + (chickadee graphics path) + (chickadee graphics sprite) + (chickadee graphics texture) + (chickadee scripting) + (ice-9 format) + (ice-9 match) + (srfi srfi-1) + (srfi srfi-9) + (statprof)) + +(define-record-type <actor> + (make-actor position velocity bounding-box) + actor? + (position actor-position) + (velocity actor-velocity) + (bounding-box actor-bounding-box)) + +(define texture #f) +(define batch #f) +(define start-time 0.0) +(define avg-frame-time 16) +(define actor-count 250) +(define actors + (list-tabulate actor-count + (lambda (n) + (let ((x (* (random:uniform) 624.0)) + (y (* (random:uniform) 464.0))) + (make-actor (vec2 x y) + (vec2 (* (- (random:uniform) 0.5) 3.0) + (* (- (random:uniform) 0.5) 3.0)) + (rect x y 16.0 16.0)))))) +(define quadtree (make-quadtree (make-rect 0.0 0.0 640.0 480.0) #:max-size 4 #:max-depth 4)) +(define canvas (make-empty-canvas)) +(define paused? #f) +(define matrix (make-identity-matrix4)) +(define stats-text-pos (vec2 4.0 464.0)) +(define stats-text #f) + +(for-each (lambda (actor) + (quadtree-insert! quadtree (actor-bounding-box actor) actor)) + actors) + +(define (quadtree-nodes quadtree) + (if (quadtree-leaf? quadtree) + (list quadtree) + (cons quadtree + (append (quadtree-nodes (quadtree-q1 quadtree)) + (quadtree-nodes (quadtree-q2 quadtree)) + (quadtree-nodes (quadtree-q3 quadtree)) + (quadtree-nodes (quadtree-q4 quadtree)))))) + +(define (paint-canvas) + (let ((painter (with-style ((stroke-color tango-scarlet-red)) + (apply superimpose + (map (lambda (node) + (let ((rect (quadtree-bounds node))) + (stroke + (rectangle (vec2 (rect-x rect) + (rect-y rect)) + (rect-width rect) + (rect-height rect))))) + (quadtree-nodes quadtree)))))) + (set-canvas-painter! canvas painter))) + +(define (stats-message) + (format #f " actors: ~d fps: ~1,2f" + actor-count (/ 1.0 avg-frame-time))) + +(define (load) + (set! *random-state* (random-state-from-platform)) + (set! texture (load-image "images/shot.png")) + (set! batch (make-sprite-batch texture #:capacity actor-count)) + (paint-canvas) + (script + (forever + (set! stats-text (stats-message)) + (sleep 60)))) + +(define (draw alpha) + (sprite-batch-clear! batch) + (for-each (lambda (actor) + (sprite-batch-add* batch (actor-bounding-box actor) matrix)) + actors) + (draw-canvas canvas) + (draw-sprite-batch batch) + (draw-text stats-text stats-text-pos #:color black) + (let ((current-time (elapsed-time))) + (set! avg-frame-time + (+ (* (- current-time start-time) 0.1) + (* avg-frame-time 0.9))) + (set! start-time current-time))) + +(define (clamp-x x) + (clamp 0.0 624.0 x)) + +(define (clamp-y y) + (clamp 0.0 464.0 y)) + +(define (update dt) + (update-agenda 1) + (unless paused? + ;; Move + (for-each (lambda (actor) + (let ((p (actor-position actor)) + (v (actor-velocity actor)) + (r (actor-bounding-box actor))) + (quadtree-delete! quadtree r actor) + ;; Move by velocity, clamping to the edge of the + ;; window. + (set-vec2-x! p (clamp-x (+ (vec2-x p) (vec2-x v)))) + (set-vec2-y! p (clamp-y (+ (vec2-y p) (vec2-y v)))) + (set-rect-x! r (vec2-x p)) + (set-rect-y! r (vec2-y p)) + ;; Check for and resolve collision. + (quadtree-find + quadtree r + (lambda (other) + ;; Calculate overlap. + (let* ((ro (actor-bounding-box other)) + (xo (max (- (min (rect-right r) (rect-right ro)) + (max (rect-left r) (rect-left ro))) + 0.0)) + (yo (max (- (min (rect-top r) (rect-top ro)) + (max (rect-bottom r) (rect-bottom ro))) + 0.0))) + (if (or (= xo 0.0) (= yo 0.0)) + #f ; no collision + (let ((vo (actor-velocity other))) + ;; Resolve the collsion with the least + ;; possible movement. Bounce the + ;; colliding actors off of each other by + ;; reversing the x or y component of the + ;; velocity vectors. + (if (< xo yo) + (let* ((xdiff (- (rect-x r) (rect-x ro))) + (xsign (/ xdiff (abs xdiff)))) + (set-vec2-x! p (clamp-x (+ (vec2-x p) (* xo xsign)))) + (set-vec2-x! v (* (vec2-x v) -1.0)) + (set-vec2-x! vo (* (vec2-x vo) -1.0))) + (let* ((ydiff (- (rect-y r) (rect-y ro))) + (ysign (/ ydiff (abs ydiff)))) + (set-vec2-y! p (clamp-y (+ (vec2-y p) (* yo ysign)))) + (set-vec2-y! v (* (vec2-y v) -1.0)) + (set-vec2-y! vo (* (vec2-y vo) -1.0)))) + (set-rect-x! r (vec2-x p)) + (set-rect-y! r (vec2-y p)) + #t))))) + ;; Bounce off the window edges. + (when (or (= (vec2-x p) 0.0) + (= (vec2-x p) 624.0)) + (set-vec2-x! v (* (vec2-x v) -1.0))) + (when (or (= (vec2-y p) 0.0) + (= (vec2-y p) 464.0)) + (set-vec2-y! v (* (vec2-y v) -1.0))) + (quadtree-insert! quadtree r actor))) + actors) + (paint-canvas))) + +(define (key-press key modifiers repeat?) + (case key + ((q) + (abort-game)) + ((space) + (set! paused? (not paused?))))) + +(run-game #:window-title "quadtree" + #:load load + #:draw draw + #:update update + #:key-press key-press) |