-
Notifications
You must be signed in to change notification settings - Fork 5
/
blocks.lisp
1946 lines (1616 loc) · 58.5 KB
/
blocks.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; blocks.lisp --- core visual language model for Xelf
;; Copyright (C) 2010, 2011, 2012, 2013 David O'Toole
;; Author: David O'Toole <dto@blocky.io>
;; Keywords: oop, languages, mouse, lisp, multimedia, hypermedia
;; 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 hopes 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/>
;;; Commentary:
;; Please see the included files README.org and guide.org for an
;; overview.
;;; Code:
(in-package :xelf)
(defun cfloat (f) (coerce f 'single-float))
(defun-memo pretty-string (thing)
(:key #'first :test 'equal :validator #'identity)
(let ((name (etypecase thing
(symbol (symbol-name thing))
(string thing))))
(coerce
(substitute #\Space #\-
(string-downcase
(string-trim " " name)))
'simple-string)))
(defun-memo ugly-symbol (string)
(:key #'first :test 'equal :validator #'identity)
(intern
(string-upcase
(substitute #\- #\Space
(string-trim " " string)))))
(define-prototype block ()
(excluded-fields :initform '(:quadtree-node))
(field-collection-type :initform :list)
;;
(cursor-clock :initform 0)
(hearing-distance :initform nil)
;; general information
(shell-only :initform nil)
(inputs :initform nil)
(focused-p :initform nil)
(buffer-name :initform nil)
(read-only :initform nil)
(input-names :initform nil)
(results :initform nil)
(category :initform :data)
(tags :initform nil)
(garbagep :initform nil)
(no-background :initform t)
(temporary :initform nil)
(methods :initform nil)
(parent :initform nil :documentation "Link to enclosing parent block, or nil if none.")
(events :initform nil :documentation "Event bindings, if any. See also `bind-event'.")
(default-events :initform nil)
(operation :initform :block)
;; visual layout
(x :initform (cfloat 0) :documentation "X coordinate of this block's position.")
(y :initform (cfloat 0) :documentation "Y coordinate of this block's position.")
(z :initform (cfloat 0) :documentation "Z coordinate of this block's position.")
(heading :initform 0.0 :documentation "Heading angle of this block, in radians. See also `radian-angle'.")
(quadtree-node :initform nil)
;;
(last-x :initform nil)
(last-y :initform nil)
(last-z :initform nil)
;; blending and image rotation
(blend :initform :alpha)
(opacity :initform 1.0)
(image-heading :initform nil)
;; collisions
(collision-type :initform :default)
;; dimensions
(width :initform 32 :documentation "Width of the block, in GL units.")
(height :initform 32 :documentation "Height of the block, in GL units.")
(depth :initform 32 :documentation "Depth of block, in GL units. Currently ignored.")
(pinned :initform nil) ;; when non-nil, do not allow dragging
(visible :initform t)
;; morphic style halo
(halo :initform nil)
(mode :initform nil)
(name :initform nil)
(needs-layout :initform t)
(label :initform nil)
(tasks :initform nil)
(image :initform nil :documentation "Name of texture to be displayed, if any."))
;;; Defining blocks
(defmacro define-block (spec &body args)
"Define a new block.
The first argument SPEC is either a
symbol naming the new block, or a list of the form
(SYMBOL . PROPERTIES) Where SYMBOL is similarly a name symbol but
PROPERTIES is a keyword property list whose valid keys
are :SUPER (specifying which prototype the newly defined block will
inherit behavior from) and :DOCUMENTATION (a documentation string.)
The remaining arguments ARGS are field specifiers, each of which is
either a symbol naming the field, or a list of the form (SYMBOL
. PROPERTIES) with :INITFORM and :DOCUMENTATION as valid keys."
(let ((name0 nil)
(super0 "XELF:BLOCK"))
(etypecase spec
(symbol (setf name0 spec))
(list (destructuring-bind (name &key super) spec
(setf name0 name)
(when super (setf super0 super)))))
;; ;; make fields accessible from Forth
;; (define-field-accessor-words
;; (etypecase (first args)
;; (keyword (mapcar #'first (plist-to-descriptors args)))
;; (cons (mapcar #'(lambda (x)
;; (if (consp x) (first x) x))
;; args))
;; (symbol args)))
;; install the definition.
`(define-prototype ,name0
(:super ,(make-prototype-id super0 *project* :create))
,@(if (keywordp (first args))
(plist-to-descriptors args)
args))))
(defun duplicate-safely (thing)
(let ((dupe (duplicate thing)))
(prog1 dupe
(setf (field-value :quadtree-node dupe) nil)
(setf (field-value :parent dupe) nil))))
(defparameter *block-categories*
'(:system :motion :event :message :looks :sound :structure :data :button
:expression :menu :hover :control :parameters :comment :sensing :operators :variables)
"List of keywords used to group blocks into different functionality
areas.")
(define-method new block (&rest args)
(apply #'clone self args))
(define-method create block ()
(new self))
(define-method forward-message block (method args)
(apply #'send method self args))
(define-method set-field block (field value)
(setf (field-value field (evaluate self)) value))
(define-method get-field block (field)
(field-value field (evaluate self)))
;;; Adding blocks to the simulation
(define-method start block ()
"Add this block to the simulation so that it receives update events."
(unless (find self *blocks* :test 'eq :key #'find-object)
(setf *blocks* (adjoin (find-uuid self) *blocks* :test 'equal))))
(define-method start-alone block ()
(setf *blocks* (list (find-uuid self))))
(define-method stop block ()
"Remove this block from the simulation so that it stops getting update
events."
(setf *blocks* (delete (find-uuid self) *blocks* :test #'equal)))
;;; Read-only status
(define-method toggle-read-only block ()
(setf %read-only (if %read-only nil t)))
(define-method read-only-p block () %read-only)
(define-method set-read-only block (&optional (read-only t))
(setf %read-only read-only))
(define-method child-updated block (child))
;;; Defining composite blocks more simply
;(declaim (inline input-block))
(defun input-block (object input-name)
(nth (position input-name
(%input-names object))
(%inputs object)))
(defmacro define-block-macro (name
(&key (super "XELF:BLOCK") fields documentation inputs)
&body body)
"Define a new block called NAME according to the given options.
The argument SUPER should be the name (a symbol or string) of the base
prototype to inherit traits (data and behavior) from. The default is
`block' so that if you don't specify a SUPER argument, you still
inherit all the inbuilt behaviors of blocks.
The argument FIELDS should be a list of field descriptors, the same as
would be given to `define-prototype'.
The INPUTS argument is a list of forms evaluated to produce argument
blocks.
DOCUMENTATION is an optional documentation string for the entire
macro.
The BODY forms are evaluated when the resulting block is evaluated;
they operate by invoking `evaluate' in various ways on the INPUTS.
The method `recompile' emits Lisp code that has the same result as
invoking `evaluate', but with zero or more blocks in the entire visual
expression subtree being replaced by (possibly shorter and more
efficient) 'plain' Lisp code. This is trivially true for the default
implementation of `recompile', which emits a statement that just
invokes `evaluate' when evaluated. When subsequently redefining the
`recompile' method on a block-macro, the 'equivalence' between the
results of invoking `recompile' and invoking `evaluate' depends solely
on the implementor, who can write a `recompile' method which operates
by invoking `recompile' in various ways on the macro-block's
`%inputs', and emitting Lisp code forms using those compiled code
streams as a basis.
"
(let ((input-names (remove-if-not #'keywordp inputs)))
`(progn
;; define input accessor functions
,@(mapcar #'make-input-accessor-defun-forms input-names)
(define-block (,name :super ,super)
(label :initform ,(pretty-string name))
(input-names :initform ',input-names)
,@fields)
(define-method initialize ,name ()
(apply #'initialize%super self %inputs)
(setf %inputs (list ,@(remove-if #'keywordp inputs)))
(update-parent-links self)
(mapc #'pin %inputs)
,@body)
(define-method recompile ,name () `(evaluate self)))))
;;; Block lifecycle
(define-method initialize block (&rest blocks)
"Prepare an empty block, or if BLOCKS is non-empty, a block
initialized with BLOCKS as inputs."
(setf %inputs
(or blocks (default-inputs self)))
(update-parent-links self)
(update-result-lists self)
(bind-any-default-events self)
(register-uuid self)
;; textures loaded here may be bogus; do this later
(when %image
(resize-to-image self))
(setf %x 0 %y 0))
(defun destroy-maybe (x)
(when (xelfp x) (destroy x)))
(define-method destroy block ()
"Throw away this block."
(mapc #'destroy-maybe %inputs)
(mapc #'destroy-maybe %tasks)
(when %halo (destroy %halo))
(when %parent
(unplug-from-parent self))
(destroy-events self)
(remove-thing-maybe (current-buffer) self)
(setf %garbagep t)
(when %quadtree-node
(quadtree-delete self %quadtree-node))
(setf %quadtree-node nil)
(let (uuid (find-uuid self))
(remove-object-from-database self)
(prog1 t
(assert (not (find-object uuid :no-error))))))
(define-method dismiss block ()
;; (if (windowp %parent)
;; (dismiss %parent)
(destroy self))
(define-method exit block ()
(remove-object *buffer* self))
(define-method make-duplicate block ()
(duplicate self))
(define-method make-clone block ()
(find-uuid (clone (find-super self))))
(define-method register-uuid block ()
(add-object-to-database self))
;;; Block tags, used for categorizing blocks
(define-method has-tag block
((tag symbol :default nil :label ""))
"Return non-nil if this block has the specified TAG.
Blocks may be marked with tags that influence their processing by the
engine. The field `%tags' is a set of keyword symbols; if a symbol
`:foo' is in the list, then the block is in the tag category `:foo'.
"
(member tag %tags))
(define-method add-tag block
((tag symbol :default nil :label ""))
"Add the specified TAG symbol to this block."
(pushnew tag %tags))
(define-method remove-tag block
((tag symbol :default nil :label ""))
"Remove the specified TAG symbol from this block."
(setf %tags (remove tag %tags)))
;;; Serialization hooks
(define-method before-serialize block ())
(define-method after-deserialize block ()
"Prepare a deserialized block for running."
(bind-any-default-events self)
(register-uuid self))
;;; Expression structure (blocks composed into trees)
(define-method adopt block (child)
(when (get-parent child)
(unplug-from-parent child))
(set-parent child self))
(define-method update-parent-links block ()
(dolist (each %inputs)
(set-parent each self)))
(define-method can-accept block () nil)
(define-method accept block (other-block)
"Try to accept OTHER-BLOCK as a drag-and-dropped input. Return
non-nil to indicate that the block was accepted, nil otherwise."
nil)
(defvar *buffers* nil
"When non-nil, the UUID of the current buffer object.")
(define-method contains block (block)
(block finding
(dolist (this %inputs)
(when (object-eq block this)
(return-from finding this)))))
;; (find (find-object block)
;; %inputs
;; :test 'eq
;; :key #'find-object))
(define-method input-position block (input)
(assert (not (null input)))
(position (find-uuid input) %inputs :key #'find-uuid :test 'equal))
(defun input (self name)
(with-fields (inputs) self
(assert (not (null inputs)))
(nth (input-position self name) inputs)))
(defun (setf input) (self name block)
(with-fields (inputs) self
(assert (not (null inputs)))
(set-parent block self)
(setf (nth (input-position self name) inputs)
;; store the real link
(find-object block))))
(define-method position-within-parent block ()
(input-position %parent self))
(define-method set-parent block (parent)
"Store a UUID link to the enclosing block PARENT."
(assert (not (null parent)))
(assert (valid-connection-p parent self))
(setf %parent (when parent
;; always store uuid to prevent circularity
(find-uuid parent))))
(define-method get-parent block ()
%parent)
(define-method find-parent block ()
(when %parent (find-uuid %parent)))
(defun valid-connection-p (sink source)
(assert (or sink source))
;; make sure source is not actually sink's parent somewhere
(block checking
(prog1 t
(let ((pointer sink))
(loop while pointer do
(if (eq (find-object pointer)
(find-object source))
(return-from checking nil)
(setf pointer (find-parent pointer))))))))
(define-method update-result-lists block ()
(let ((len (length %inputs)))
(setf %input-widths (make-list len :initial-element 0))
(setf %results (make-list len))))
(define-method delete-input block (block)
(with-fields (inputs) self
(prog1 t
(assert (contains self block))
(setf inputs (remove block inputs
:key #'find-object
:test 'eq))
(assert (not (contains self block))))))
(define-method default-inputs block ()
nil)
(define-method this-position block ()
(with-fields (parent) self
(when parent
(input-position parent self))))
(define-method plug block (thing n)
"Connect the block THING as the value of the Nth input."
(set-parent thing self)
(setf (input self n) thing))
(define-method after-unplug-hook block (parent))
;; (setf %parent nil)
;; (add-object (current-buffer) self))
(define-method after-release-hook block ())
(define-method unplug block (input)
"Disconnect the block INPUT from this block."
(with-fields (inputs parent) self
(assert (contains self input))
(prog1 input
(setf inputs
(delete input inputs
:test 'eq :key #'find-object))
(after-unplug-hook input self))))
(define-method unplug-from-parent block ()
(when %parent
(prog1 t
(with-fields (parent) self
(assert (not (null parent)))
(assert (contains parent self))
(unplug parent self)
; (assert (not (contains parent self)))
(setf parent nil)))))
(define-method drop block (new-block &optional (dx 0) (dy 0) (dz 1))
"Add a new object to the current buffer at the current position.
Optionally provide an x-offset DX and a y-offset DY. The optional
z-offset DZ defaults to 1, which stacks the object on top of Self.
See also `drop-at'."
(add-object (current-buffer) new-block (+ %x dx) (+ %y dy) (+ %z dz)))
(define-method drop-at block (new-block x y &optional z)
"Add the NEW-BLOCK to the current buffer at the location X,Y."
(assert (and (numberp x) (numberp y)))
(add-object (current-buffer) new-block x y z))
(define-method clear-buffer-data block ()
(clear-saved-location self)
(setf %quadtree-node nil)
(setf %parent nil))
;;; Defining input events for blocks
;; see also definition of "task" blocks below.
(define-method initialize-events-table-maybe block (&optional force)
(when (or force
(not (has-local-value :events self)))
(setf %events (make-hash-table :test 'equal))))
(define-method bind-event-to-task block (event-name modifiers task)
"Bind the described event to invoke the action of the TASK.
EVENT-NAME is either a keyword symbol identifying the keyboard key, or
a string giving the Unicode character to be bound. MODIFIERS is a list
of keywords like :control, :alt, and so on."
(assert (find-object task))
(initialize-events-table-maybe self)
(let ((event (make-event event-name modifiers)))
(setf (gethash event %events)
task)))
(define-method unbind-event block (event-name modifiers)
"Remove the described event binding."
(remhash (normalize-event (cons event-name modifiers))
%events))
(define-method handle-event block (event)
"Look up and invoke the block task (if any) bound to
EVENT. Return the task if a binding was found, nil otherwise. The
second value returned is the return value of the evaluated task (if
any)."
(with-fields (events) self
(when events
(let ((task
;; unpack event
(destructuring-bind (head &rest modifiers) event
;; if head is a cons, check for symbol binding first,
;; then for unicode binding. we do this because we'll
;; often want to bind keys like ENTER or BACKSPACE
;; regardless of their Unicode interpretation
(if (consp head)
(or (gethash (cons (car head) ;; try symbol
modifiers)
events)
(gethash (cons (cdr head) ;; try unicode
modifiers)
events))
;; it's not a cons.
;; just search event as-is
(gethash event events)))))
(if task
(prog1 (values task (evaluate task))
(invalidate-layout self))
(values nil nil))))))
(define-method handle-text-event block (event)
"Look up events as with `handle-event', but insert
unhandled/unmodified keypresses as Unicode characters via the `insert'
function."
(unless (joystick-event-p event)
(with-fields (events) self
(destructuring-bind (key . unicode) (first event)
(when (or (block%handle-event self event)
;; treat non-alt-control Unicode characters as self-inserting
(when
(and (not (eq :return key))
unicode
(not (member :alt (rest event)))
(not (member :control (rest event))))
(prog1 t
(send :insert-string self unicode))))
(prog1 t (invalidate-layout self)))))))
(defun bind-event-to-method (block event-name modifiers method-name)
"Arrange for METHOD-NAME to be sent as a message to this object
whenever the event (EVENT-NAME . MODIFIERS) is received."
(destructuring-bind (key . mods)
(make-event event-name modifiers)
(bind-event-to-task block
key
mods
(new 'task method-name block))))
(define-method bind-event block (event binding)
"Bind the EVENT to invoke the action specified in BINDING.
EVENT is a list of the form:
(NAME modifiers...)
NAME is either a keyword symbol identifying the keyboard key, or a
string giving the Unicode character to be bound. MODIFIERS is a list
of keywords like :control, :alt, and so on.
Examples:
(bind-event self '(:up) :move-up)
(bind-event self '(:down) :move-down)
(bind-event self '(:q :control) :quit)
(bind-event self '(:escape :shift) :menu)
See `keys.lisp' for the full table of key and modifier symbols.
" (destructuring-bind (name &rest modifiers) event
(etypecase binding
(symbol (bind-event-to-method self name modifiers binding))
(list
;; create a method call
(let ((task (new 'task
(make-keyword (first binding))
self
:arguments (rest binding))))
(bind-event-to-task self name modifiers task))))))
(define-method bind-any-default-events block ()
(with-fields (default-events) self
(when default-events
(initialize-events-table-maybe self :force)
(dolist (entry default-events)
(apply #'bind-event self entry)))))
(define-method destroy-events block ()
(when %events
(loop for event being the hash-values of %events do
(destroy-maybe event))))
(defun bind-event-to-text-insertion (self key mods text)
(bind-event-to-task self key mods
(new 'task :insert-string self (list text))))
(define-method insert block (&optional x y z)
(drop-object (current-buffer) self x y z))
(define-method insert-string block (string)
(declare (ignore string))
nil)
(defvar *lowercase-alpha-characters* "abcdefghijklmnopqrstuvwxyz")
(defvar *uppercase-alpha-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
(defvar *numeric-characters* "0123456789")
(defvar *graphic-characters* "`~!@#$%^&*()_-+={[}]|\:;\"'<,>.?/")
(defparameter *text-qwerty-keybindings*
'((:f (:control) :forward-char)
(:b (:control) :backward-char)
(:n (:alt) :forward-history)
(:p (:alt) :backward-history)
(:right nil :forward-char)
(:left nil :backward-char)
(:backspace nil :backward-delete-char)
(:delete nil :delete-char)
(:d (:control) :delete-char)
(:a (:control) :beginning-of-line)
(:e (:control) :end-of-line)
(:tab nil :tab)
(:tab (:shift) :backtab)
(:return nil :enter)
(:return (:control) :execute)
;; (:return (:control) :evaluate-here)
;; (:delete (:alt) :delete-word)
;; (:d (:alt) :delete-word)
(:x (:control) :exit)
(:g (:control) :exit)
(:escape nil :exit)))
(defparameter *arrow-key-text-navigation-keybindings*
'(
(:up nil :previous-line)
(:down nil :next-line)
(:left nil :backward-char)
(:right nil :forward-char)
(:up (:alt) :previous-line)
(:down (:alt) :next-line)
(:left (:alt) :backward-word)
(:right (:alt) :forward-word)
(:home nil :beginning-of-line)
(:end nil :end-of-line)))
(defun keybinding-event (binding)
(cons (first binding)
(second binding)))
(defun keybinding-action (binding)
(nthcdr 2 binding))
(define-method install-keybindings block (keybindings)
(dolist (binding keybindings)
(bind-event self
(keybinding-event binding)
(keybinding-action binding))))
(define-method install-text-keybindings block (&optional (keybindings *text-qwerty-keybindings*))
;; install UI keys that will vary by locale
(with-fields (events) self
(setf events (make-hash-table :test 'equal))
(dolist (binding keybindings)
(destructuring-bind (key mods result) binding
(etypecase result
(keyword (bind-event-to-method self key mods result))
(string (bind-event-to-text-insertion self key mods result)))))))
;;; Pointer events (see also buffers.lisp)
(define-method select block () nil)
(define-method tap block (x y))
(define-method alternate-tap block (x y)
(when (shell-open-p)
(toggle-halo self)))
(define-method scroll-tap block (x y)
(declare (ignore x y))
nil)
(define-method scroll-up block ())
(define-method scroll-down block ())
(define-method scroll-left block ())
(define-method scroll-right block ())
(define-method handle-point-motion block (x y)
(declare (ignore x y)))
(define-method press block (x y button)
(declare (ignore x y button)))
(define-method release block (x y button)
(declare (ignore x y button)))
(define-method can-pick block ()
(not %pinned))
(define-method pick block ()
(with-fields (pinned parent) self
(if (not pinned)
self
(when (and parent
(can-pick parent))
(pick parent)))))
(define-method topmost block ()
(let ((this self)
(next nil))
(block searching
(loop while this do
(setf next (%parent this))
(when (or (null next)
(is-a 'buffer next))
(return-from searching this))
(setf this next)))))
(define-method after-add-hook block () nil)
(define-method after-drag-hook block () nil)
;;; Focus events (see also buffers.lisp)
(define-method focus block () (setf %focused-p t))
(define-method lose-focus block () (setf %focused-p nil))
(define-method grab-focus block ()
(send :focus-on (current-buffer) self :clear-selection nil))
(define-method pick-focus block () self)
;;; Squeak-style pop-up halo with action handles
;; see also halo.lisp
(define-method make-halo block ()
(when (null %halo)
(setf %halo (new 'halo self))
(add-block (current-buffer) %halo)))
(define-method destroy-halo block ()
(when (xelfp %halo)
(destroy %halo))
(setf %halo nil))
(define-method toggle-halo block (&optional force)
(if %halo
(destroy-halo self)
(when (or force (not %pinned))
(make-halo self))))
(define-method align-to-pixels block ()
(setf %x (truncate %x))
(setf %y (truncate %y)))
(define-method drag block (x y)
(move-to self x y))
(define-method as-drag block (x y)
self)
(define-method as-target block () self)
(define-method can-escape block ()
t)
;;; Tasks and updating
;; See also definition of "task" blocks below.
(define-method add-task block (task)
(assert (xelfp task))
(pushnew (find-uuid task) %tasks :test 'equal))
(define-method remove-task block (task)
(destroy-maybe task)
(setf %tasks (delete task %tasks :test 'equal)))
(define-method run block ()) ;; stub for with-turtle
(define-method run-tasks block ()
;; don't run tasks on objects that got deleted during UPDATE
(when %quadtree-node
(dolist (task %tasks)
(unless (running task)
(remove-task self task)))))
(define-method update block ()
"Update the simulation one step forward in time."
(mapc #'update %inputs))
;;; Block movement
(define-method save-location block ()
(setf %last-x %x
%last-y %y
%last-z %z))
(define-method clear-saved-location block ()
(setf %last-x nil
%last-y nil
%last-z nil))
(define-method restore-location block ()
;; is there a location to restore?
(when %last-x
(quadtree-delete-maybe self)
(setf %x %last-x
%y %last-y
%z %last-z)
(quadtree-insert-maybe self)))
(define-method set-location block (x y)
(setf %x x %y y))
(define-method move-to block (x y &optional z)
"Move this block to a new (X Y) location."
(when %quadtree-node (save-location self))
(quadtree-delete-maybe self)
(setf %x (cfloat x) %y (cfloat y))
(when z (setf %z (cfloat z)))
(quadtree-insert-maybe self))
;; (define-method move-to-* block
;; ((x number :default 0)
;; (y number :default 0)
;; (z number :default 0))
;; "Move this block to a new (X Y Z) location."
;; (move-to self x y)
;; (setf %z (cfloat z)))
(define-method raise block (distance)
(incf %z distance))
(define-method lower block (distance)
(decf %z distance))
(define-method move-to-depth block (depth)
(setf %z (cfloat depth)))
(define-method move-toward block
((direction symbol :default :up) (steps number :initform 1))
"Move this block STEPS steps in the direction given by KEYWORD.
The KEYWORD must be one of:
:up :down :left :right :upright :upleft :downleft :downright
"
(with-field-values (x y) self
(multiple-value-bind (x0 y0)
(step-in-direction x y (or direction :up) (or steps 5))
(move-to self x0 y0))))
(defun radian-angle (degrees)
"Convert DEGREES to radians."
(* degrees (cfloat (/ pi 180))))
(defun heading-degrees (radians)
(* radians (cfloat (/ 180 pi))))
(define-method (turn-left :category :motion) block ((degrees number :default 90))
"Turn this object's heading to the left DEGREES degrees."
(decf %heading (radian-angle degrees)))
(define-method (turn-right :category :motion) block ((degrees number :default 90))
"Turn this object's heading to the right DEGREES degrees."
(incf %heading (radian-angle degrees)))
(defun step-coordinates (x y heading &optional (distance 1))
(values (+ x (* distance (cos heading)))
(+ y (* distance (sin heading)))))
(define-method step-toward-heading block (heading &optional (distance 1))
"Return as values the X,Y coordinate of the point DISTANCE units
away from this object, in the angle HEADING."
(multiple-value-bind (x y) (center-point self)
(step-coordinates x y heading distance)))
(define-method move block ((heading number :default 0.0)
(distance number :default 1))
"Move this object DISTANCE units toward the angle HEADING."
(multiple-value-bind (x0 y0) (step-coordinates %x %y heading distance)
(move-to self x0 y0)))
(define-method forward block ((distance number :default 1))
"Move this object DISTANCE units toward its current heading."
(move self %heading distance))
(define-method backward block ((distance number :default 1))
"Move this object DISTANCE units away from its current heading."
(move self (- (* 2 pi) %heading) distance))
(define-method heading-to-thing2 block (thing)
"Compute the heading angle from this object to the other object THING."
(multiple-value-bind (x1 y1) (center-point thing)
(multiple-value-bind (x0 y0) (center-point self)
(find-heading x0 y0 x1 y1))))
(define-method heading-to-thing block (thing)
(multiple-value-bind (x0 y0) (center-point thing)
(find-heading %x %y x0 y0)))
(define-method heading-to-cursor block ()
"Compute the heading angle from this object to the cursor."
(heading-to-thing self (get-cursor *buffer*)))
;;; Show methods in Emacs Glass
(define-method show-method block (method)
(let ((sym (definition method (find-object self))))
(assert (symbolp sym))
(let ((name (string-upcase
(format nil "~A::~A"
(package-name (symbol-package sym))
(symbol-name sym)))))
(eval-in-emacs `(glass-show-definition ,name)))))
(define-method show-definition block ()
(let ((name
(concatenate 'string
(package-name *package*)
"::"
(prototype-variable-name
(find-super-prototype-name self)))))
(message "SHOWING DEF ON CL SIDE: ~S" name)
(eval-in-emacs `(glass-show-definition ,name))))
;;; Visibility
(define-method show block ()
(setf %visible t))
(define-method hide block ()
(setf %visible nil))
(define-method toggle-visibility block ()
(if %visible
(hide self)
(show self)))
(define-method visiblep block ()
%visible)
;;; Menus and programming-blocks
;; See also library.lisp for the Message blocks.
(define-method make-method-menu-item block (method target)
(assert (and target (keywordp method)))
(let ((method-string (pretty-string method)))
(list :label method-string
:method method
:target target
:action (new 'task method target))))
(define-method context-menu block ()
(let ((methods nil)
(pointer self))
;; gather methods
(loop do
(when (has-local-value :methods pointer)
(setf methods
(union methods
(field-value :methods pointer))))
(setf pointer (object-super pointer))
while pointer)
;;
(let (inputs)
(dolist (method (sort methods #'string<))
(push (make-method-menu-item self method (find-uuid self)) inputs))
(make-menu
(list
;; :label
;; (string-downcase
;; (concatenate 'string
;; (get-some-object-name self)
;; " " (object-address-string self)))
:inputs (nreverse inputs)
:pinned nil