Fetching contributors…
Cannot retrieve contributors at this time
1090 lines (956 sloc) 32.6 KB
;;; worlds.lisp --- squeakish spaces
;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011, 2012 David O'Toole
;; Author: David O'Toole
;; Keywords:
;; 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 %
(in-package :blocky)
(defvar *listener* nil)
(defvar *listener-open-p* nil)
(define-block world
(variables :initform nil
:documentation "Hash table mapping values to values, local to the current world.")
(player :documentation "The player object, if any.")
(background-image :initform nil)
(background-color :initform "white")
(category :initform :data)
(x :initform 0)
(y :initform 0)
(paused :initform nil)
(heading :initform 0.0)
(height :initform 256)
(width :initform 256)
(depth :initform *z-far*)
(field-of-view :initform *field-of-view*)
(was-key-repeat-p :initform nil)
;; objects and collisions
(objects :initform nil :documentation "A hash table with all the world's objects.")
(quadtree :initform nil)
(quadtree-depth :initform nil)
;; viewing window
(window-x :initform 0)
(window-y :initform 0)
(window-z :initform 0)
(window-x0 :initform nil)
(window-y0 :initform nil)
(window-z0 :initform nil)
(horizontal-scrolling-margin :initform 1/4)
(vertical-scrolling-margin :initform 1/4)
(window-scrolling-speed :initform 5)
(window-scale-x :initform 1)
(window-scale-y :initform 1)
(window-scale-z :initform 1)
(projection-mode :initform :orthographic)
(rewound-selection :initform nil)
(future :initform nil)
(future-steps :initform 32)
(future-step-interval :initform 8)
(default-events :initform
'(((:tab) :tab)
((:tab :shift) :backtab)
((:x :alt) :enter-listener)
((:x :control) :cut)
((:c :control) :copy)
((:v :control) :paste)
((:v :control :shift) :paste-here)
((:g :control) :escape)
((:escape) :toggle-listener)
((:m :alt) :add-message)
((:s :alt) :add-statement)
((:v :alt) :add-variable)
((:l :alt) :add-self)
((:f :alt) :add-field)
((:e :alt) :add-expression)
;; prototype control
(excluded-fields :initform
'(:events :quadtree :click-start :click-start-block :drag-origin :drag-start :drag-offset :focused-block :listener :drag :hover :highlight)
:documentation "Don't serialize the menu bar.")
(field-collection-type :initform :hash)
;; dragging info
(drag :initform nil
:documentation "Block being dragged, if any.")
(drag-button :initform nil)
(hover :initform nil
:documentation "Block being hovered over, if any.")
(highlight :initform nil
:documentation "Block being highlighted, if any.")
(ghost :initform nil
:documentation "Dummy block to hold original place of currently dragged block onscreen.")
(focused-block :initform nil
:documentation "Block having current input focus, if any.")
(last-focus :initform nil)
(click-start :initform nil
:documentation "A cons (X . Y) of widget location at moment of click.")
(click-start-block :initform nil
:documentation "The block indicated at the beginning of a drag.")
(drag-origin :initform nil
:documentation "The parent block originally holding the dragged block.")
(object-p :initform nil
:documentation "When non-nil, the dragged object is in the world.")
(drag-start :initform nil
:documentation "A cons (X . Y) of widget location at start of dragging.")
(drag-offset :initform nil
:documentation "A cons (X . Y) of relative mouse click location on dragged block.")
;; For buffer page worlds
(prototype-name :initform nil)
(method :initform nil)
(modified :initform nil
:documentation "Non-nil when modified since last save."))
(defun selection ()
(get-selection (world)))
(defmacro with-world (world &rest body)
`(let* ((*world* (find-uuid ,world)))
(define-method transport-pause world ()
(setf %paused t)
(setf %rewound-selection
(mapcar #'duplicate
(get-selection self))))
(define-method transport-play world ()
(setf %paused nil)
(clear-future self)
(mapc #'destroy (get-selection self))
(dolist (each %rewound-selection)
(add-object (world) each))
(setf %rewound-selection nil))
(define-method show-future world ()
(prog1 nil
(let ((selection (get-selection self)))
(let (future)
(dolist (thing selection)
(remove-object self thing)
(let (trail)
(dotimes (i %future-steps)
(let ((ghost (duplicate thing)))
(with-world self
(with-quadtree %quadtree
(add-object self ghost)
(assert (%quadtree-node ghost))
(dotimes (j (* i %future-step-interval))
(update ghost)
(run-tasks ghost)
(quadtree-collide ghost))))
(remove-object self ghost)
(push ghost trail)))
(push trail future))
(add-object self thing)
(make-halo thing))
(setf %future future)))))
(define-method clear-future world ()
(setf %future nil))
(define-method update-future world ()
(when %future (show-future self)))
(defmacro define-world (name &body body)
`(define-block (,name :super "BLOCKY:WORLD")
(define-method get-objects world ()
(loop for object being the hash-values in %objects collect object))
(define-method has-object world (thing)
(gethash (find-uuid thing) %objects))
;; Defining and scrolling the screen viewing window
(define-method window-bounding-box world ()
(values %window-y
(+ %window-x *gl-screen-width*)
(+ %window-y *gl-screen-height*)))
(define-method move-window-to world (x y &optional z)
(setf %window-x x
%window-y y)
(when z (setf %window-z z)))
(define-method move-window world (dx dy &optional dz)
(incf %window-x dx)
(incf %window-y dy)
(when dz (setf %window-dz dz)))
(define-method glide-window-to world (x y &optional z)
(setf %window-x0 x)
(setf %window-y0 y)
(when z (setf %window-z z)))
(define-method glide-window-to-object world (object)
(multiple-value-bind (top left right bottom)
(bounding-box object)
(declare (ignore right bottom))
(max 0 (- left (/ *gl-screen-width* 2)))
(max 0 (- top (/ *gl-screen-width* 2))))))
(define-method glide-follow world (object)
(with-fields (window-x window-y width height) self
(let ((margin-x (* %horizontal-scrolling-margin *gl-screen-width*))
(margin-y (* %vertical-scrolling-margin *gl-screen-height*))
(object-x (field-value :x object))
(object-y (field-value :y object)))
;; are we outside the "comfort zone"?
(if (or
;; too far left
(> (+ window-x margin-x)
;; too far right
(> object-x
(- (+ window-x *gl-screen-width*)
;; too far up
(> (+ window-y margin-y)
;; too far down
(> object-y
(- (+ window-y *gl-screen-height*)
;; yes. recenter.
(glide-window-to self
(max 0
(min (- width *gl-screen-width*)
(- object-x
(truncate (/ *gl-screen-width* 2)))))
(max 0
(min (- height *gl-screen-height*)
(- object-y
(truncate (/ *gl-screen-height* 2))))))))))
(define-method update-window-glide world ()
(with-fields (window-x window-x0 window-y window-y0 window-scrolling-speed) self
(labels ((nearby (a b)
(> window-scrolling-speed (abs (- a b))))
(jump (a b)
(if (< a b) window-scrolling-speed (- window-scrolling-speed))))
(when (and window-x0 window-y0)
(if (nearby window-x window-x0)
(setf window-x0 nil)
(incf window-x (jump window-x window-x0)))
(if (nearby window-y window-y0)
(setf window-y0 nil)
(incf window-y (jump window-y window-y0)))))))
(define-method scale-window world (&optional (window-scale-x 1.0) (window-scale-y 1.0))
(setf %window-scale-x window-scale-x)
(setf %window-scale-y window-scale-y))
(define-method project-window world ()
(ecase %projection-mode
(:orthographic (project-orthographically))
(:perspective (project-with-perspective :field-of-view %field-of-view :depth %depth)))
(transform-window :x %window-x :y %window-y :z %window-z
:scale-x %window-scale-x
:scale-y %window-scale-y
:scale-z %window-scale-z))
(define-method emptyp world ()
(or (null %objects)
(zerop (hash-table-count %objects))))
(define-method initialize world (&key name)
(initialize%super self)
(setf %buffer-name name)
(when name
(setf %prototype-name (buffer-name-prototype name))
(setf %method (buffer-name-method name))
(add-buffer name self))
(setf %ghost (new 'block))
(setf %objects (make-hash-table :test 'equal)))
;;; The object layer.
(defvar *object-placement-capture-hook*)
(define-method add-object world (object &optional x y (z 0))
(with-world self
(with-quadtree %quadtree
(remove-thing-maybe self object)
(assert (not (contains-object self object)))
(setf (gethash (find-uuid object)
(find-uuid object))
(when (and (numberp x) (numberp y))
(setf (%x object) x
(%y object) y))
(when (numberp z)
(setf (%z object) z))
(clear-saved-location object)
(quadtree-insert-maybe object)
(after-place-hook object))))
(define-method remove-object world (object)
(remhash (find-uuid object) %objects)
(when (%quadtree-node object)
(quadtree-delete object)
(setf (%quadtree-node object) nil)))
(define-method remove-thing-maybe world (object)
(with-world self
(destroy-halo object)
(when (gethash (find-uuid object) %objects)
(remove-object self object))
(when (%parent object)
(unplug-from-parent object))))
(define-method add-block world (object &optional x y prepend)
(remove-thing-maybe self object)
(add-block%super self object x y))
(define-method drop-block world (object x y)
(add-object self object)
(move-to object x y))
(define-method add-at-pointer world (object)
(add-block self object *pointer-x* *pointer-y* :prepend)
(focus-on self object))
(define-method add-message world ()
(add-at-pointer self (new 'message)))
(define-method add-statement world ()
(add-at-pointer self (new 'statement)))
(define-method add-variable world ()
(add-at-pointer self (new 'variable)))
(define-method add-expression world ()
(add-at-pointer self (new 'expression)))
(define-method add-field world ()
(add-at-pointer self (new 'field)))
(define-method add-self world ()
(add-at-pointer self (new 'self)))
(define-method contains-object world (object)
(gethash (find-uuid object)
(define-method destroy-block world (object)
(remhash (find-uuid object) %objects))
;;; World-local variables
(define-method initialize-variables-maybe world ()
(when (null %variables)
(setf %variables (make-hash-table :test 'equal))
(setf (gethash "WORLD" %variables) self)))
(define-method set-variable world (var value)
(initialize-variables-maybe self)
(setf (gethash var %variables) value))
(define-method get-variable world (var)
(initialize-variables-maybe self)
(gethash var %variables))
(defun world-variable (var-name)
(get-variable (world) var-name))
(defun set-world-variable (var-name value)
(set-variable (world) var-name value))
(defsetf world-variable set-world-variable)
(defmacro with-world-variables (vars &rest body)
(labels ((make-clause (sym)
`(,sym (world-variable ,(make-keyword sym)))))
(let* ((symbols (mapcar #'make-non-keyword vars))
(clauses (mapcar #'make-clause symbols)))
`(symbol-macrolet ,clauses ,@body))))
;;; About the player
(define-method get-player world ()
(defun player ()
(get-player *world*))
(defun playerp (thing)
(object-eq thing (player)))
(define-method set-player world (player)
(setf %player (find-uuid player)))
;; (unless (contains-object self player)
;; (add-object self player)))
;;; Configuring the world's space and its quadtree indexing
(defparameter *world-bounding-box-scale* 1.01
"Actual size of bounding box used for quadtree. The world is bordered
around on all sides by a thin margin designed to prevent objects near
the edge of the universe piling up into the top quadrant and causing
slowdown. See also quadtree.lisp")
(define-method install-quadtree world ()
;; make a box with a one-percent margin on all sides.
;; this margin helps edge objects not pile up in quadrants
(let ((box (multiple-value-list
(multiple-value-list (bounding-box self))
(with-fields (quadtree) self
(setf quadtree (build-quadtree
(or %quadtree-depth
(assert quadtree)
(let ((objects (get-objects self)))
(when objects
(quadtree-fill objects quadtree))))))
(define-method resize world (new-height new-width)
(assert (and (plusp new-height)
(plusp new-width)))
(with-fields (height width quadtree objects) self
(setf height new-height)
(setf width new-width)
(when quadtree
(install-quadtree self))))
(define-method trim world ()
(prog1 self
(let ((objects (get-objects self)))
(when objects
(with-fields (quadtree height width) self
;; adjust bounding box so that all objects have positive coordinates
(multiple-value-bind (top left right bottom)
(find-bounding-box objects)
;; resize the world so that everything just fits
(setf %x 0 %y 0)
(resize self (- bottom top) (- right left))
;; move all the objects
(dolist (object objects)
(with-fields (x y) object
(with-quadtree quadtree
(move-to object (- x left) (- y top)))))))))))
;;; Cut and paste
(define-method get-selection world ()
(let ((all (append (get-objects self) %inputs)))
(remove-if-not #'%halo all)))
(define-method copy world (&optional objects0)
(let ((objects (or objects0 (get-selection self))))
(clear-halos self)
(when objects
(setf *clipboard* (new 'world))
(dolist (object objects)
(let ((duplicate (duplicate object)))
;; don't keep references to anything in the (world)
(clear-world-data duplicate)
(add-object *clipboard* duplicate))))))
(define-method cut world (&optional objects0)
(with-world self
(let ((objects (or objects0 (get-selection self))))
(when objects
(clear-halos self)
(setf *clipboard* (new 'world))
(dolist (object objects)
(with-quadtree %quadtree
(remove-thing-maybe self object))
(add-object *clipboard* object))))))
(define-method paste-from world ((source block) (dx number :default 0) (dy number :default 0))
(dolist (object (mapcar #'duplicate (get-objects source)))
(with-fields (x y) object
(clear-world-data object)
(with-world self
(with-quadtree %quadtree
(add-object self object)
(move-to object (+ x dx) (+ y dy)))))))
(define-method paste world ((dx number :default 0) (dy number :default 0))
(paste-from self *clipboard* dx dy))
(define-method paste-here world ()
(let ((temp (new 'world)))
(paste-from temp *clipboard*)
(send :trim temp)
(paste-from self temp
;; (define-method paste-cut
;;; Algebraic operations on worlds and their contents
(defvar *world-prototype* "BLOCKY:WORLD")
(defmacro with-world-prototype (world &rest body)
`(let ((*world-prototype* (find-super ,world)))
(define-method adjust-bounding-box-maybe world ()
(if (emptyp self)
(let ((objects-bounding-box
(find-bounding-box (get-objects self)))))
(destructuring-bind (top left right bottom)
;; are all the objects inside the existing box?
(prog1 self
(unless (bounding-box-contains
(multiple-value-list (bounding-box self))
(resize self bottom right)))))))
(defmacro with-new-world (&body body)
`(with-world (clone *world-prototype*)
(adjust-bounding-box-maybe (world))))
(defun translate (world dx dy)
(when world
(assert (and (numberp dx) (numberp dy)))
(paste (world) world dx dy))))
(defun combine (world1 world2)
(when (and world1 world2)
(dolist (object (nconc (get-objects world1)
(get-objects world2)))
(add-object (world) object)))))
(define-method scale world (sx &optional sy)
(let ((objects (get-objects self)))
(dolist (object objects)
(with-fields (x y width height) object
(move-to object (* x sx) (* y (or sy sx)))
(resize object (* width sx) (* height (or sy sx))))))
(trim self))
(define-method destroy-region world (bounding-box))
(defun vertical-extent (world)
(if (or (null world)
(emptyp world))
(multiple-value-bind (top left right bottom)
(bounding-box world)
(declare (ignore left right))
(- bottom top))))
(defun horizontal-extent (world)
(if (or (null world)
(emptyp world))
(multiple-value-bind (top left right bottom)
(bounding-box world)
(declare (ignore top bottom))
(- right left))))
(defun arrange-below (&optional world1 world2)
(when (and world1 world2)
(combine world1
(translate world2
(field-value :height world1)))))
(defun arrange-beside (&optional world1 world2)
(when (and world1 world2)
(combine world1
(translate world2
(field-value :width world1)
(defun stack-vertically (&rest worlds)
(reduce #'arrange-below worlds :initial-value (with-new-world)))
(defun stack-horizontally (&rest worlds)
(reduce #'arrange-beside worlds :initial-value (with-new-world)))
(define-method flip-horizontally world ()
(let ((objects (get-objects self)))
(dolist (object objects)
(with-fields (x y) object
(move-to object (- x) y))))
;; get rid of negative coordinates
(trim self))
(define-method flip-vertically world ()
(let ((objects (get-objects self)))
(dolist (object objects)
(with-fields (x y) object
(move-to object x (- y)))))
(trim self))
(define-method mirror-horizontally world ()
(flip-horizontally (duplicate self))))
(define-method mirror-vertically world ()
(flip-vertically (duplicate self))))
(defun with-border (border world)
(with-fields (height width) world
(paste (world) world border border)
(resize (world)
(+ height (* border 2))
(+ width (* border 2))))))
;;; The Shell is an optional layer of objects on top of the world
;; Including a system menu, editor, and controls for switching worlds
;; and pages in the system. Maybe zooming out on a mega virtual desktop.
(define-method add-listener-maybe world (&optional force)
(when (or force (null *listener*))
(setf *listener* (new 'listener))))
(define-method enter-listener world ()
(add-listener-maybe self)
(setf %last-focus %focused-block)
(focus-on self *listener* :clear-selection nil)
(when (null *listener-open-p*) (setf %was-key-repeat-p (key-repeat-p)))
(setf *listener-open-p* t)
(define-method exit-listener world ()
(when *listener-open-p*
(add-listener-maybe self)
(setf *listener-open-p* nil)
(focus-on self %last-focus)
(setf %last-focus nil)
(unless %was-key-repeat-p
(setf %was-key-repeat-p nil)))
(define-method toggle-listener world ()
(if *listener-open-p*
(exit-listener self)
(enter-listener self)))
(define-method grab-focus world ())
(define-method layout-shell-objects world ()
(mapc #'layout %inputs))
(define-method update-shell-objects world ()
(mapc #'update %inputs)
(update *listener*))
(define-method draw-shell-objects world ()
(with-world self
(with-fields (drag-start inputs drag focused-block
highlight inputs modified hover
ghost prompt) self
;; now start drawing the shell objects
(mapc #'draw inputs)
;; draw any future
(when %future
(let ((*image-opacity* 0.2))
(dolist (trail %future)
(mapc #'draw trail))))
;; during dragging we draw the dragged block.
(when drag
(layout drag)
(when (field-value :parent drag)
(draw-ghost ghost))
;; also draw any hover-over highlights
;; on objects you might drop stuff onto
(when hover
(draw-hover hover))
(draw drag))
(when *listener*
(draw *listener*))
;; draw focus
(when focused-block
(assert (blockyp focused-block))
(draw-focus focused-block))
(when highlight
(draw-highlight highlight)))))
(define-method draw-overlays world ())
(define-method draw world ()
(with-world self
(with-field-values (objects width height background-image background-color) self
(unless %parent
(project-window self))
;; (when %parent
;; (gl:push-matrix)
;; (gl:translate %x %y 0))
;; draw background
(if background-image
(draw-image background-image 0 0)
(when background-color
(draw-box 0 0 width height
:color background-color)))
;; now draw the object layer
(let ((box (multiple-value-list (window-bounding-box self))))
(loop for object being the hash-values in objects do
;; only draw onscreen objects
(when (colliding-with-bounding-box object box)
(draw object))))
;; (if %parent
;; (gl:pop-matrix)
;; possibly draw shell
(if *listener-open-p*
(draw-shell-objects self)
(draw-overlays self)))))
;;; Simulation update
(define-method update world ()
(with-field-values (objects drag player) self
;; build quadtree if needed
(when (null %quadtree)
(install-quadtree self))
(assert %quadtree)
(unless %paused
(with-world self
;; enable quadtree for collision detection
(with-quadtree %quadtree
;; possibly run the objects
(loop for object being the hash-values in %objects do
(update object)
(run-tasks object))
;; update window movement
(let ((thing (or
(when (holding-shift) drag)
(when thing
(glide-follow self thing)
(update-window-glide self)))
;; detect collisions
(loop for object being the hash-values in objects do
(unless (eq :passive (field-value :collision-type object))
(quadtree-collide object))))))
;; now outside the quadtree,
;; possibly update the shell layer
(with-world self
(when *listener-open-p*
(with-quadtree nil
(layout self)
(layout-shell-objects self)
(update-shell-objects self))))))
;;; Running a world as a script
(define-method evaluate world ()
(prog1 self
(with-world self
(mapc #'evaluate %inputs))))
(define-method layout world ()
;; take over the entire GL window
(with-world self
;; (setf %x 0 %y 0)
;; %width *gl-screen-width*
;; %height *gl-screen-height*)
(mapc #'layout %inputs)
(when *listener*
(layout *listener*))))
(define-method handle-event world (event)
(with-field-values (player quadtree focused-block) self
(with-world self
(or (block%handle-event self event)
(let ((thing
(if *listener-open-p*
(prog1 t
(when thing
(with-quadtree quadtree
(handle-event thing event)))))))))
;;; Hit testing
(define-method hit world (x y)
;; return self no matter where mouse is, so that we get to process
;; all the events.
(declare (ignore x y))
(define-method hit-inputs world (x y)
"Recursively search the blocks in this world for a block
intersecting the point X,Y. We have to search the top-level blocks
starting at the end of `%INPUTS' and going backward, because the
blocks are drawn in list order (i.e. the topmost blocks for
mousing-over are at the end of the list.) The return value is the
block found, or nil if none is found."
(with-world self
(with-quadtree %quadtree
(labels ((try (b)
(when b
(hit b x y))))
;; check listener and inputs first
(let* ((object-p nil)
(when *listener-open-p*
(try *listener*))
(let ((parent
(find-if #'try
:from-end t)))
(when parent
(try parent)))
;; try world objects
(block trying
(loop for object being the hash-values of %objects
do (let ((result (try object)))
(when result
(setf object-p t)
(return-from trying result))))))))
(values result object-p))))))
(defparameter *minimum-drag-distance* 6)
(define-method clear-halos world ()
(mapc #'destroy-halo (get-objects self)))
(define-method focus-on world (block &key (clear-selection t))
;; possible to pass nil
(with-fields (focused-block) self
(with-world self
(let ((last-focus focused-block))
;; there's going to be a new focused block.
;; tell the current one it's no longer focused.
(when (and clear-selection last-focus
;; don't do this for same block
(not (object-eq last-focus block)))
(lose-focus last-focus))
(when clear-selection
(when (not (holding-control))
(clear-halos self)))
;; now set up the new focus (possibly nil)
(setf focused-block (when block
(pick-focus block))))
;; sanity check
(assert (or (null focused-block)
(blockyp focused-block)))
;; now tell the block it has focus, but only if not the same
(when (and focused-block
(not (object-eq last-focus focused-block)))
(focus block))))))
(define-method begin-drag world (mouse-x mouse-y block)
(with-fields (drag drag-origin inputs drag-start ghost drag-offset) self
(with-world self
(setf drag (as-drag block mouse-x mouse-y))
(setf drag-origin (find-parent drag))
(when drag-origin
;; parent might produce a new object
(unplug-from-parent block))
(let ((dx (field-value :x block))
(dy (field-value :y block))
(dw (field-value :width block))
(dh (field-value :height block)))
(with-fields (x y width height) ghost
;; remember the relative mouse coordinates from the time the
;; user began dragging, so that the block being dragged is not
;; simply anchored with its top left corner located exactly at
;; the mouse pointer.
(let ((x-offset (- mouse-x dx))
(y-offset (- mouse-y dy)))
(when (null drag-start)
(setf x dx y dy width dw height dh)
(setf drag-start (cons dx dy))
(setf drag-offset (cons x-offset y-offset)))))))))
(define-method drag-maybe world (x y)
;; require some actual mouse movement to initiate a drag
(with-world self
(with-fields (focused-block drag-button click-start click-start-block) self
(when click-start
(destructuring-bind (x1 . y1) click-start
(when (and focused-block click-start-block
(> (distance x y x1 y1)
(can-pick click-start-block))
(let ((drag
(if (and drag-button (= 3 drag-button))
;; right-drag means "grab whole thing"
(topmost click-start-block)
(pick click-start-block))))
(when drag
(begin-drag self x y drag)
;; clear click data
(setf click-start nil)
(setf click-start-block nil)))))))))
(define-method handle-point-motion world (mouse-x mouse-y)
(with-fields (inputs hover highlight click-start drag-offset quadtree
drag-start drag) self
(with-world self
(with-quadtree quadtree
(setf hover nil)
(drag-maybe self mouse-x mouse-y)
(if drag
;; we're in a mouse drag.
(destructuring-bind (ox . oy) drag-offset
(let ((target-x (- mouse-x ox))
(target-y (- mouse-y oy)))
(let ((candidate (hit-inputs self target-x target-y)))
;; obviously we dont want to plug a block into itself.
(setf hover (if (object-eq drag candidate) nil
(find-uuid candidate)))
;; keep moving along with the mouse
(drag drag target-x target-y))))
;; not dragging, just moving
(setf highlight (find-uuid (hit-inputs self mouse-x mouse-y)))))))))
;; (when (null highlight)
;; (when *listener*
;; (with-world self (close-menus *listener*))))))))
(define-method press world (x y &optional button)
(with-world self
(with-fields (click-start drag-button click-start-block
focused-block) self
;; now find what we're touching
(assert (or (null focused-block)
(blockyp focused-block)))
(multiple-value-bind (block object-p)
(hit-inputs self x y)
(setf %object-p object-p)
(if (null block)
(focus-on self nil)
;; (when *listener-open-p*
;; (exit-listener self)))
(setf click-start (cons x y))
(setf click-start-block (find-uuid block))
(setf drag-button button)
;; now focus; this might cause another block to be
;; focused, as in the case of the Listener
(focus-on self block)))))))
(define-method clear-drag-data world ()
(setf %drag-start nil
%drag-offset nil
%object-p nil
%drag-origin nil
%drag-button nil
%drag nil
%hover nil
%highlight nil
%last-focus nil
%click-start-block nil
%click-start nil))
(define-method release world (x y &optional button)
(with-world self
(drag-offset drag-start hover drag click-start drag-button
click-start-block drag-origin focused-block modified) self
(if drag
;; we're dragging
(destructuring-bind (x0 . y0) drag-offset
(setf drag-button nil)
(let ((drag-parent (get-parent drag))
(drop-x (- x x0))
(drop-y (- y y0)))
(if (not (can-escape drag))
;; put back in halo or wherever
(when drag-origin
(add-block drag-origin drag drop-x drop-y))
;; ok, drop. where are we dropping?
(when drag-parent
(unplug-from-parent drag))
(if %object-p
(move-to drag drop-x drop-y)
(if (null hover)
;; dropping on background. was it in %OBJECTS?
(if (has-object self drag)
nil ;; do nothing, leave it where it is
;; otherwise move it back to the listener layer
(add-block self drag drop-x drop-y))
;; dropping on another block
(when (not (accept hover drag))
;; hovered block did not accept drag.
;; drop it back in the shell.
(add-block self drag drop-x drop-y))))))
;; select the dropped block
; (select self drag)
; (toggle-halo drag)
(setf focused-block (find-uuid drag)))))
;; we were clicking instead of dragging
(when focused-block
; (select self focused-block)
(with-world self
;; right click and alt click are equivalent
((or (= button 3)
(and (holding-alt) (= button 1)))
(alternate-tap focused-block x y))
;; scroll wheel click and shift click are equivalent
((or (= button 2)
(and (holding-shift) (= button 1)))
(scroll-tap focused-block x y))
;; vertical scrolling
((= button 4)
(scroll-up focused-block))
((= button 5)
(scroll-down focused-block))
;; hold shift for horizontal scrolling
((and (= button 4)
(scroll-left focused-block))
((and (= button 5)
(scroll-right focused-block))
;; plain old click
(tap focused-block x y))))
;;(select self focused-block))
(setf click-start nil))))
;; close any ephemeral menus
(dolist (input %inputs)
(when (and (menup input)
(not (object-eq focused-block input)))
(destroy input)))
;; clean up bookeeping
(clear-drag-data self)
(invalidate-layout self))))
(define-method tab world (&optional backward)
(when %focused-block
(with-world self
(tab %focused-block backward))))
(define-method backtab world ()
(tab self :backward))
(define-method escape world ()
(with-world self
(focus-on self nil)
(setf %selection nil)))
(define-method start world ()
(with-world self
(unless (emptyp self)
(trim self))
(start%super self)))
(defun on-screen-p (thing)
(multiple-value-list (window-bounding-box (world)))))
;;; Serialization of worlds
;; (define-method before-serialize world ()
;; (with-fields (objects) self
;; (loop for id being the hash-keys of objects do
;; ;; don't serialize the cached object
;; (setf (gethash id objects) t))))
;; (define-method after-serialize world ()
;; (loop for id being the hash-keys of %objects do
;; (setf (gethash id %objects) (find-object id))))
(define-method after-deserialize world ()
(after-deserialize%super self)
(add-listener-maybe self :force))
;;; worlds.lisp ends here