Compare commits

..

No commits in common. "main" and "fruit" have entirely different histories.
main ... fruit

259 changed files with 13592 additions and 7132 deletions

View File

@ -1,6 +1,6 @@
__ignored__ := $(shell ./setup.sh)
PACKAGES=syndicate syndicate-examples syndicate-msd
PACKAGES=syndicate syndicate-examples
COLLECTS=syndicate syndicate-examples
all: setup
@ -22,13 +22,3 @@ test: setup testonly
testonly:
raco test -p $(PACKAGES)
PROTOCOLS_BRANCH=main
pull-protocols:
git subtree pull -P syndicate/private/protocols \
-m 'Merge latest changes from the syndicate-protocols repository' \
git@git.syndicate-lang.org:syndicate-lang/syndicate-protocols \
$(PROTOCOLS_BRANCH)
fixcopyright:
-fixcopyright.rkt --preset-racket LGPL-3.0-or-later

View File

@ -1,7 +1,11 @@
# Third Racket implementation of Syndicate
# Second Racket implementation of Syndicate
## Quickstart
raco pkg install syndicate
or
git clone https://git.syndicate-lang.org/syndicate-lang/syndicate-rkt
cd syndicate-rkt
make link
@ -18,31 +22,27 @@ implementation of Syndicate, which includes
- a TCP echo server example, which listens for connections on port
5999 by default, in
[`syndicate-examples/tcp-echo-server.rkt`](syndicate-examples/tcp-echo-server.rkt).
[`syndicate-examples/echo.rkt`](syndicate-examples/echo.rkt).
Connect to it using, for example, `telnet localhost 5999`.
- a number of other examples both small and large, in
[`syndicate-examples/`](syndicate-examples/).
## New design, new implementation
## New implementation
This implementation of Syndicate is based on the *Syndicated Actor
Model*, a design that takes the language-level constructs of facets,
capabilities denoting objects, and dataflow fields to heart. The
implementation integrates these ideas into a facet- and
assertion-oriented actor implementation and a capability-aware
dataspace implementation.
This is a reimplementation of Syndicate that takes the language-level
constructs of facets, endpoints, and fields to heart, integrating
knowledge of facets and endpoints into the dataspace implementation
itself.
It gains a *significant* performance advantage (10-30x speedup!) over
[2017-era dataspace implementations](https://git.syndicate-lang.org/syndicate-lang/syndicate-2017/src/branch/main/racket)
by representing patterns over assertions in a
[new way](syndicate/HOWITWORKS.md), and a smaller but not
insignificant advantage over
[2019-era implementations](https://git.syndicate-lang.org/syndicate-lang/syndicate-rkt/src/branch/fruit)
by switching to a simpler and more general actor implementation.
It gains a *significant* performance advantage by doing so.
The dataspace implementation techniques herein are the subject of a
forthcoming paper. The prototype that embodies the new idea is in
Programs seem to be about *20x faster* (compared to the
[previous implementation](https://git.syndicate-lang.org/syndicate-lang/syndicate-2017/src/branch/main/racket)).
Some are only 10x faster, some are 30x faster.
The implementation techniques herein are the subject of a forthcoming
paper. The prototype that embodies the new idea is in
[historical/prototype.rkt](historical/prototype.rkt), and
[syndicate/HOWITWORKS.md](syndicate/HOWITWORKS.md) describes the
approach via prose.
@ -50,28 +50,30 @@ approach via prose.
All the drivers end up looking much nicer with this new
implementation. The previously-separate GL-2D support is now
integrated as just another driver (though the timing characteristics
of the old implementation are not precisely preserved). The connection
to the surrounding Racket environment is also much cleaner.
of the old implementation are not precisely preserved). The
[ground.rkt](syndicate/ground.rkt) implementation is much cleaner.
<!-- To see the difference in speed, try out the "many Racket logos" -->
<!-- animation example/demo after installing the `syndicate` and -->
<!-- `syndicate-examples` packages: -->
To see the difference in speed, try out the "many Racket logos"
animation example/demo after installing the `syndicate` and
`syndicate-examples` packages:
<!-- racket -l syndicate-examples/gl-2d-many -->
racket -l syndicate-examples/gl-2d-many
<!-- Hopefully you'll get a smooth 60fps, though I admit I'm running it on -->
<!-- a fairly fast machine so you might need to drop the `sprite-count` in -->
<!-- the code a bit to sustain 60fps. -->
Hopefully you'll get a smooth 60fps, though I admit I'm running it on
a fairly fast machine so you might need to drop the `sprite-count` in
the code a bit to sustain 60fps.
## Compiling and running the code
You will need Racket version 8.1 or later.
You will need Racket version 7.6 or later. (If you're using Racket CS,
you'll need version 7.8 or later because of
[this issue](https://github.com/racket/racket/issues/3132).)
Once you have Racket installed, run
<!-- raco pkg install syndicate -->
raco pkg install syndicate
<!-- to install the package from the Racket package repository, or -->
to install the package from the Racket package repository, or
raco pkg install --link syndicate

144
fixcopyright.rkt Executable file
View File

@ -0,0 +1,144 @@
#!/usr/bin/env racket
#lang racket
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
(require file/glob)
(require racket/date)
(define ((re p) i) (regexp-match p i))
(define ((re? p) i) (regexp-match? p i))
(define ((s p ins) i) (regexp-replace p i ins))
(define this-year (number->string (date-year (current-date))))
(define (get-git-config key)
(string-trim (with-output-to-string
(lambda () (system* "/usr/bin/env" "git" "config" "--get" key)))))
(define (is-tracked? f)
(call-with-output-file "/dev/null" #:exists 'append
(lambda (sink)
(parameterize ((current-error-port sink)
(current-output-port sink))
(system* "/usr/bin/env" "git" "ls-files" "--error-unmatch" f)))))
(define user-name (get-git-config "user.name"))
(define user-email (get-git-config "user.email"))
(define user (format "~a <~a>" user-name user-email))
(define (make-copyright who low [hi #f])
(if (and hi (not (string=? low hi)))
(format "Copyright © ~a-~a ~a" low hi who)
(format "Copyright © ~a ~a" low who)))
(define total-file-count 0)
(define total-changed-files 0)
(define dry-run? #f)
(define modify-untracked? #f)
(define (fix-files #:file-type-name file-type-name
#:file-pattern file-pattern
#:front-matter-re [front-matter-re #f]
#:leading-comment-re leading-comment-re
#:comment-prefix comment-prefix
#:file-filter [file-filter (lambda (x) #t)])
(define matched-files (filter file-filter (glob file-pattern)))
(define file-count (length matched-files))
(define changed-files 0)
(for [(file-number (in-naturals))
(f (in-list matched-files))]
(printf "~a [~a/~a] ~a ..." file-type-name file-number file-count f)
(flush-output)
(define all-lines (file->lines f))
(define-values (front-matter head tail)
(let*-values (((lines) all-lines)
((front-matter lines) (if front-matter-re
(splitf-at lines (re? front-matter-re))
(values '() lines)))
((head tail) (splitf-at lines (re? leading-comment-re))))
(values front-matter head tail)))
(let* ((head (map (s leading-comment-re "") head))
(head (map (lambda (l)
(match (regexp-match "^([^:]+): (.*)$" l)
[(list _ k v) (list k v)]
[#f (list #f l)]))
head))
(head (if (assoc "SPDX-FileCopyrightText" head)
head
(cons (list "SPDX-FileCopyrightText" (make-copyright user this-year)) head)))
(head (if (assoc "SPDX-License-Identifier" head)
head
(cons (list "SPDX-License-Identifier" "LGPL-3.0-or-later") head)))
(head (map (lambda (l)
(match l
[(list "SPDX-FileCopyrightText"
(and (regexp (regexp-quote user-name))
(regexp #px"(\\d{4})-\\d{4}" (list _ low))))
(list "SPDX-FileCopyrightText"
(make-copyright user low this-year))]
[(list "SPDX-FileCopyrightText"
(and (regexp (regexp-quote user-name))
(regexp #px"\\d{4}" (list low))))
(list "SPDX-FileCopyrightText"
(make-copyright user low this-year))]
[_ l]))
head))
(head (map (lambda (l)
(if (string=? (cadr l) "")
(string-trim comment-prefix)
(string-append comment-prefix
(match l
[(list #f v) v]
[(list k v) (format "~a: ~a" k v)]))))
head))
(new-lines `(,@front-matter
,@head
""
,@(dropf tail (lambda (l) (string=? (string-trim l) "")))))
(would-change-if-written? (not (equal? all-lines new-lines)))
(write-needed? (and would-change-if-written? (or modify-untracked? (is-tracked? f)))))
(when (and write-needed? (not dry-run?))
(call-with-atomic-output-file
f
(lambda (port _tmp-path)
(for [(l front-matter)] (displayln l port))
(for [(l head)] (displayln l port))
(newline port)
(for [(l (dropf tail (lambda (l) (string=? (string-trim l) ""))))] (displayln l port)))))
(if write-needed?
(begin (set! changed-files (+ changed-files 1))
(printf "\e[41mchanged\e[0m\n"))
(printf "\r\e[K"))))
(when (positive? changed-files)
(printf "~a [~a total files, ~a changed]\n" file-type-name file-count changed-files))
(set! total-file-count (+ total-file-count file-count))
(set! total-changed-files (+ total-changed-files changed-files)))
(command-line #:once-each
[("-n" "--dry-run") "Do not write back changes to files"
(set! dry-run? #t)]
[("--modify-untracked") "Modify files not tracked by git as well as those that are"
(set! modify-untracked? #t)])
(void (fix-files #:file-type-name "Racket"
#:file-pattern "**.rkt"
#:front-matter-re #px"^#"
#:leading-comment-re #px"^;+ *"
#:comment-prefix ";;; "))
(printf "fixcopyright: ~a files examined, ~a ~a\n"
total-file-count
total-changed-files
(if dry-run?
(if (zero? total-changed-files)
"changes are needed"
"files need to be updated")
(if (zero? total-changed-files)
"changes were needed"
"files were updated")))
(void (system "chmod a+x fixcopyright.rkt"))
(exit (if (positive? total-changed-files) 1 0))

View File

@ -1,4 +1,4 @@
#!/bin/sh
set -e
exec 1>&2
fixcopyright.rkt -n --preset-racket LGPL-3.0-or-later
./fixcopyright.rkt -n

View File

@ -1,5 +1,5 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2024 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang racket/base

View File

@ -1 +0,0 @@
/schemas/

View File

@ -1,5 +1,5 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2024 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang syndicate
;; Simple mutable box and count-to-infinity box client.
@ -7,24 +7,18 @@
(message-struct set-box (new-value))
(assertion-struct box-state (value))
(module+ main
(standard-actor-system/no-services (ds)
(spawn #:name 'box
(define-field current-value 0)
(at ds
(assert (box-state (current-value)))
(on (message (set-box $new-value))
(log-info "box: taking on new-value ~v" new-value)
(current-value new-value)))
(stop-on-true (= (current-value) 10)
(log-info "box: terminating")))
(spawn (field [current-value 0])
(assert (box-state (current-value)))
(stop-when-true (= (current-value) 10)
(log-info "box: terminating"))
(on (message (set-box $new-value))
(log-info "box: taking on new-value ~v" new-value)
(current-value new-value)))
(spawn #:name 'client
(at ds
(stop-on (retracted (Observe (:pattern (set-box ,_)) _))
(log-info "client: box has gone"))
(on (asserted (box-state $v))
(log-info "client: learned that box's value is now ~v" v)
(send! (set-box (+ v 1))))
(on (retracted (box-state _))
(log-info "client: box state disappeared"))))))
(spawn (stop-when (retracted (observe (set-box _)))
(log-info "client: box has gone"))
(on (asserted (box-state $v))
(log-info "client: learned that box's value is now ~v" v)
(send! (set-box (+ v 1))))
(on (retracted (box-state _))
(log-info "client: box state disappeared")))

View File

@ -0,0 +1,37 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang syndicate
(require/activate syndicate/drivers/tcp)
(require/activate syndicate/drivers/external-event)
(require/activate syndicate/reassert)
(require (only-in racket/port read-bytes-line-evt))
(spawn (define id 'chat)
(define root-facet (current-facet))
(reassert-on (tcp-connection id (tcp-address "localhost" 5999))
(retracted (tcp-accepted id))
(asserted (tcp-rejected id _)))
(on (asserted (tcp-rejected id $reason))
(printf "*** ~a\n" (exn-message reason)))
(during (tcp-accepted id)
(on-start (printf "*** Connected.\n")
(issue-credit! tcp-in id))
(on (retracted (tcp-accepted id)) (printf "*** Remote EOF.\n"))
;; ^ Not on-stop, because the facet is stopped by local EOF too!
(on (message (tcp-in-line id $bs))
(write-bytes bs)
(newline)
(flush-output)
(issue-credit! tcp-in id))
(define stdin-evt (read-bytes-line-evt (current-input-port) 'any))
(on (message (inbound (external-event stdin-evt (list $line))))
(if (eof-object? line)
(stop-facet root-facet (printf "*** Local EOF. Terminating.\n"))
(send! (tcp-out id (bytes-append line #"\n")))))))

View File

@ -0,0 +1,32 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang syndicate
(require/activate syndicate/drivers/tcp)
(require racket/format)
(message-struct speak (who what))
(assertion-struct present (who))
(dataspace
(spawn #:name 'chat-server
(during/spawn (inbound (tcp-connection $id (tcp-listener 5999)))
#:name (list 'chat-connection id)
(assert (outbound (tcp-accepted id)))
(on-start (send! (outbound (credit (tcp-listener 5999) 1)))
(send! (outbound (credit tcp-in id 1))))
(let ((me (gensym 'user)))
(assert (present me))
(on (message (inbound (tcp-in-line id $bs)))
(match bs
[#"/quit" (stop-current-facet)]
[#"/stop-server" (quit-dataspace!)]
[_ (send! (speak me (bytes->string/utf-8 bs)))
(send! (outbound (credit tcp-in id 1)))])))
(during (present $user)
(on-start (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " arrived\n"))))))
(on-stop (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " left\n"))))))
(on (message (speak user $text))
(send!
(outbound (tcp-out id (string->bytes/utf-8 (~a user " says '" text "'\n"))))))))))

View File

@ -0,0 +1,33 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang syndicate
(require/activate syndicate/drivers/tcp)
(require racket/format)
(message-struct speak (who what))
(assertion-struct present (who))
(message-struct stop-server ())
(spawn #:name 'chat-server
(stop-when (message (stop-server)))
(during/spawn (tcp-connection $id (tcp-listener 5999))
#:name (list 'chat-connection id)
(assert (tcp-accepted id))
(on-start (issue-credit! (tcp-listener 5999))
(issue-credit! tcp-in id))
(let ((me (gensym 'user)))
(assert (present me))
(on (message (tcp-in-line id $bs))
(issue-credit! tcp-in id)
(match bs
[#"/quit" (stop-current-facet)]
[#"/stop-server" (send! (stop-server))]
[_ (send! (speak me (bytes->string/utf-8 bs)))])))
(during (present $user)
(on-start (send! (tcp-out id (string->bytes/utf-8 (~a user " arrived\n")))))
(on-stop (send! (tcp-out id (string->bytes/utf-8 (~a user " left\n")))))
(on (message (speak user $text))
(send! (tcp-out id (string->bytes/utf-8 (~a user " says '" text "'\n"))))))))

View File

@ -1,6 +0,0 @@
#!/usr/bin/env -S syndicate-server -c
<require-service <relay-listener <tcp "0.0.0.0" 9001> $gatekeeper>>
let ?ds = dataspace
<bind <ref {oid: "syndicate" key: #x""}> $ds #f>

View File

@ -1,46 +0,0 @@
#lang syndicate
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2023-2024 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
(module+ main
(require syndicate/distributed/gatekeeper)
(require syndicate/distributed/tcp)
(require syndicate/driver-support)
(require syndicate/gensym)
(require "schemas/simpleChatProtocol.rkt")
(require syndicate/sturdy)
(require (only-in file/sha1 hex-string->bytes))
(define me (symbol->string (strong-gensym 'user)))
(define ref (SturdyRef (Parameters "syndicate"
(hex-string->bytes "69ca300c1dbfa08fba692102dd82311a")
(CaveatsField-absent))))
(standard-actor-system (ds)
(define conn-facet this-facet)
(define (on-connected remote-ds)
(on-stop (stop-facet conn-facet))
(linked-thread
#:name (list 'read-stdin)
(lambda (facet)
(let loop ()
(match (read-line)
[(? eof-object?) (log-info "EOF on stdin.")]
[line (turn! facet (lambda () (send! remote-ds (Says me line))))
(loop)]))))
(at remote-ds
(assert (Present me))
(during (Present $who)
(on-start (log-info "~a arrived" who))
(on-stop (log-info "~a departed" who)))
(on (message (Says $who $what)) (log-info "~a says: ~v" who what))))
(run-tcp-client-relay
ds
#:hostname "localhost"
#:port (string->number (or (getenv "CHAT_PORT") "9001"))
#:import (lambda (v) (gatekeeper-resolve (embedded-value v) ref on-connected)))))

View File

@ -1,41 +0,0 @@
#lang syndicate
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2022-2024 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
(require syndicate/distributed/ports)
(require syndicate/driver-support)
(require (only-in racket/system system))
(message-struct log (timestamp details))
(module+ main
(standard-actor-system/no-services (ds)
(spawn #:name 'main
(spawn/link #:name 'subprocess
(define-values (stdout-in stdout-out) (make-pipe))
(define-values (stdin-in stdin-out) (make-pipe))
(linked-thread
#:name 'subprocess-io
(lambda (facet)
(parameterize ((current-input-port stdin-in)
(current-output-port stdout-out))
(system "racket dummy-port-relay.rkt"))))
(define (cleanup!)
(close-input-port stdout-in)
(close-output-port stdout-out)
(close-input-port stdin-in)
(close-output-port stdin-out))
(actor-add-exit-hook! this-actor cleanup!)
(run-port-relay
#:input-port stdout-in
#:output-port stdin-out
#:name 'loader-relay
#:import (lambda (c)
(at (embedded-value c)
(assert (hash 'hello-from 'loader
'log (embedded
(object
[#:message v
(writeln `(got log ,v))])))))
))))))

View File

@ -1,14 +0,0 @@
#!/usr/bin/env -S syndicate-server -c
<require-service <daemon dummy-port-relay>>
<daemon dummy-port-relay {
argv: "racket -y dummy-port-relay.rkt"
protocol: application/syndicate
}>
? <service-object <daemon dummy-port-relay> ?cap> [
$cap {
config: $config
log: $log
}
]

View File

@ -1,21 +0,0 @@
#lang syndicate
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2022-2024 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
(require syndicate/distributed/ports)
(message-struct log (timestamp details))
(module+ main
(standard-actor-system/no-services (ds)
(spawn #:name 'main
(facet-prevent-inert-check! this-facet)
(run-port-relay
#:export
(ref (during* (lambda (a)
(eprintf "assert ~a\n" a)
(match (hash-ref a 'log #f)
[(embedded l)
(send! l (log "-" (hash 'line "hello!")))]
[_ (void)])
(on-stop (eprintf "retract ~a\n" a)))))))))

View File

@ -0,0 +1,16 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang syndicate
(require/activate syndicate/drivers/tcp)
(spawn (during/spawn (tcp-connection $id (tcp-listener 5999))
(on-start (printf "Accepted connection ~v\n" id))
(on-stop (printf "Closed connection ~v\n" id))
(assert (tcp-accepted id))
(on-start (issue-credit! (tcp-listener 5999))
(issue-credit! tcp-in id))
(on (message (tcp-in-line id $bs))
(issue-credit! tcp-in id)
(send! (tcp-out id (bytes-append bs (bytes 13 10)))))))

View File

@ -0,0 +1,34 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang syndicate
(require/activate syndicate/drivers/external-event)
(require/activate syndicate/drivers/filesystem)
(require racket/file)
(require (only-in racket/port read-bytes-line-evt))
(require (only-in racket/string string-trim string-split))
(spawn #:name 'monitor-shell
(define e (read-bytes-line-evt (current-input-port) 'any))
(on (message (inbound (external-event e (list $line))))
(match line
[(? eof-object?)
(stop-current-facet (send! (list "close" 'all)))]
[(? bytes? command-bytes)
(send! (string-split (string-trim (bytes->string/utf-8 command-bytes))))])))
(spawn #:name 'monitor-opener
(define (monitor name reader-proc)
(spawn #:name (list 'monitor name)
(stop-when (message (list "close" 'all))) ;; old-syndicate version used wildcard
(stop-when (message (list "close" name)))
(on (asserted (file-content name reader-proc $data))
(log-info "~a: ~v" name data))))
(on (message (list "open" $name)) (monitor name file->bytes))
;; The driver can track directory "contents" just as well as files.
(on (message (list "opendir" $name)) (monitor name directory-list)))

View File

@ -0,0 +1,136 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang syndicate
(require racket/set)
(require 2htdp/image)
(require/activate syndicate/drivers/gl-2d)
(define (spawn-background)
(spawn (during (window $width $height)
(assert-scene `((push-matrix (scale ,width ,(* height 2))
(translate 0 -0.25)
(texture
,(overlay/xy (rectangle 1 1 "solid" "white")
0 0
(rectangle 1 2 "solid" "black"))))
;; (rotate -30)
;; (scale 5 5)
)
`()))))
(define (draggable-mixin touching? x y)
(define (idle)
(react (stop-when #:when (touching?)
(message (mouse-event 'left-down (mouse-state $mx $my _ _ _)))
(log-info "idle -> dragging; in-script? ~v" (in-script?))
(dragging (- mx (x)) (- my (y))))))
(define (dragging dx dy)
(react (on (message (mouse-event 'motion (mouse-state $mx $my _ _ _)))
(x (- mx dx))
(y (- my dy)))
(stop-when (message (mouse-event 'left-up _)) (idle))
(stop-when (message (mouse-event 'leave _)) (idle))))
(idle))
(define (draggable-shape name orig-x orig-y z plain-image hover-image
#:coordinate-map-id [coordinate-map-id #f]
#:parent [parent-id #f])
(spawn (field [x orig-x] [y orig-y])
(define/query-value touching? #f (touching name) #t)
(assert (simple-sprite #:parent parent-id
#:coordinate-map-id coordinate-map-id
#:touchable-id name
#:touchable-predicate in-unit-circle?
z (x) (y) 50 50
(if (touching?)
hover-image
plain-image)))
(on-start (draggable-mixin touching? x y))))
(define (tooltip touching? x y w h label-string)
(define label-text (text label-string 22 "black"))
(define label (overlay label-text (empty-scene (+ (image-width label-text) 10)
(+ (image-height label-text) 10))))
(define (pos)
(define v (- (x) (image-width label) 10))
(if (negative? v)
(+ (x) w 10)
v))
(react (assert #:when (touching?)
(simple-sprite -10
(pos)
(+ (y) (* 1/2 h) (- (* 1/2 (image-height label))))
(image-width label)
(image-height label)
label))))
(define (spawn-player-avatar)
(local-require 2htdp/planetcute)
(define CC character-cat-girl)
(spawn (field [x 100] [y 100])
(assert (simple-sprite #:touchable-id 'player
#:coordinate-map-id 'player
-0.5 (x) (y) (image-width CC) (image-height CC) CC))
(field [keys-down (set)])
(on (asserted (key-pressed $k)) (keys-down (set-add (keys-down) k)))
(on (retracted (key-pressed $k)) (keys-down (set-remove (keys-down) k)))
(define (key->delta k distance) (if (set-member? (keys-down) k) distance 0))
(define/query-value touching? #f (touching 'player) #t)
(on-start (draggable-mixin touching? x y))
(on (asserted (coordinate-map 'player $xform))
;; TODO: figure out why this causes lag in frame updates
(log-info "Player coordinate map: ~v" xform))
(on-start (tooltip touching? x y (image-width CC) (image-height CC) "The Player"))
(on (message (frame-event _ _ $elapsed-ms _))
(define-values (old-x old-y) (values (x) (y)))
(define distance (* 0.360 elapsed-ms))
(define nx (+ old-x (key->delta 'right distance) (key->delta 'left (- distance))))
(define ny (+ old-y (key->delta 'down distance) (key->delta 'up (- distance))))
(when (not (and (= nx old-x) (= ny old-y)))
(x nx)
(y ny)))))
(define (spawn-frame-counter)
(spawn (field [i empty-image])
(assert (simple-sprite -10 300 10 (image-width (i)) (image-height (i)) (i)))
(on (message (frame-event $counter $sim-time-ms _ _))
(when (> sim-time-ms 0)
(define fps (/ counter (/ sim-time-ms 1000.0)))
(i (text (format "~a fps" fps) 22 "black"))))))
(spawn-keyboard-integrator)
(spawn-mouse-integrator)
(spawn-background)
;; (spawn-frame-counter)
(spawn-player-avatar)
(draggable-shape 'orange 50 50 0
(circle 50 "solid" "orange")
(circle 50 "solid" "red"))
(draggable-shape 'yellow 10 -10 0 #:parent 'orange
(circle 50 "solid" "yellow")
(circle 50 "solid" "purple"))
(draggable-shape 'green 60 60 -1
(circle 50 "solid" "green")
(circle 50 "solid" "cyan"))
(spawn* (until (message (key-event #\q #t _)))
(assert! (gl-control 'stop)))
(spawn (during (touching $id)
(on-start (log-info "Touching ~v" id))
(on-stop (log-info "No longer touching ~v" id))))
(spawn-gl-2d-driver)

View File

@ -0,0 +1,90 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang syndicate
;; Compare to "ezd" clock-face example from: J. F. Bartlett, “Dont
;; Fidget with Widgets, Draw!,” Palo Alto, California, DEC WRL
;; Research Report 91/6, May 1991.
(require lang/posn)
(require 2htdp/image)
(require (only-in racket/math pi))
(require racket/date)
(require/activate syndicate/drivers/gl-2d)
(define hand
(polygon (list (make-posn 0 0)
(make-posn 30 10)
(make-posn 100 0)
(make-posn 30 -10))
"solid"
"black"))
(define (fmod a b)
(- a (* b (truncate (/ a b)))))
(define (hand-sprite id layer angle-field length)
(sprite #:id id layer `((translate 100 100)
(rotate ,(fmod (- 90 (angle-field)) 360))
(scale ,length ,(/ length 5))
(translate 0 -0.5)
(touchable ,id ,in-unit-square?)
(texture ,hand))))
(define (text-sprite layer x y content)
(define i (text content 24 "green"))
(simple-sprite layer x y (image-width i) (image-height i) i))
(spawn (field [minute-angle 0]
[hour-angle 0]
[start-time (current-inexact-milliseconds)]
[elapsed-seconds 0]
[displacement (let ((now (current-date)))
(* 6 (+ (* 60 (date-hour now))
(date-minute now))))])
(assert (simple-sprite 10 0 0 200 200 (circle 100 "solid" "blue")))
(assert (hand-sprite 'minute 9 minute-angle 95))
(assert (text-sprite 8 40 40 "time"))
(assert (text-sprite 8 110 80 "drifts"))
(assert (text-sprite 8 40 120 "by"))
(assert (hand-sprite 'hour 7 hour-angle 65))
(assert (simple-sprite 6 95 95 10 10 (circle 5 "solid" "black")))
(define (respond-to-drags id scale)
(define/query-value touching? #f (touching id) #t)
(on #:when (touching?) (message (mouse-event 'left-down (mouse-state $mx $my _ _ _)))
(start-time #f)
(elapsed-seconds 0)
(update-displacement! mx my scale)
(react (stop-when (message (mouse-event 'left-up _)))
(stop-when (message (mouse-event 'leave _)))
(on-stop (start-time (current-inexact-milliseconds)))
(on (message (mouse-event 'motion (mouse-state $mx $my _ _ _)))
(update-displacement! mx my scale)))))
(define (update-displacement! mx my scale)
(define angle (- 90 (* (/ 180 pi) (atan (- 100 my) (- mx 100)))))
(define delta0 (fmod (- (* scale angle) (displacement)) 360))
(define delta (if (<= delta0 -180) (+ delta0 360) delta0))
(displacement (+ (displacement) delta)))
(respond-to-drags 'minute 1)
(respond-to-drags 'hour 12)
(begin/dataflow
(define angle (+ (/ (elapsed-seconds) 1000 10) (displacement)))
(minute-angle angle)
(hour-angle (/ angle 12)))
(on (message (frame-event _ _ _ _))
(when (start-time)
(elapsed-seconds (- (current-inexact-milliseconds) (start-time)))))
(on (message (key-event #\q #t _))
(send! (gl-control 'stop))))
(spawn-gl-2d-driver #:label "Syndicate Clock"
#:width 200
#:height 200)

View File

@ -0,0 +1,87 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang syndicate
;; Multiple animated sprites.
;;
;; 2018-05-01 With the new "imperative" implementation of Syndicate,
;; the same 2.6GHz laptop mentioned below can animate 135 logos in a
;; 640x480 window at 60 fps on a single core, with a bit of headroom
;; to spare.
;;
;; 2016-12-12 With the current implementations of (a) Syndicate's
;; dataspaces and (b) Syndicate's 2D sprite support, my reasonably new
;; 2.6GHz laptop can animate 20 logos at 256x256 pixels at about 20
;; frames per second on a single core.
;;
;; For comparison, Kay recounts in "The Early History of Smalltalk"
;; (1993) that "by the Fall of '73 [Steve Purcell] could demo 80
;; ping-pong balls and 10 flying horses running at 10 frames per
;; second in 2 1/2 D" in an early Smalltalk (?) on a NOVA.
(require 2htdp/image)
(require images/logos)
(require/activate syndicate/drivers/gl-2d)
(define speed-limit 40)
(define sprite-count 135)
(define (spawn-background)
(spawn
(during (window $width $height)
(assert-scene `((push-matrix (scale ,width ,height)
(texture ,(rectangle 1 1 "solid" "white"))))
`()))))
(define i:logo (plt-logo))
(define i:logo-width (image-width i:logo))
(define i:logo-height (image-height i:logo))
(define (spawn-logo)
(spawn (field [x 100] [y 100])
(field [dx (* (- (random) 0.5) speed-limit)]
[dy (* (- (random) 0.5) speed-limit)])
(define/query-value w #f ($ w (window _ _)) w)
(assert (simple-sprite 0
(x)
(y)
i:logo-width
i:logo-height
i:logo))
(define (bounce f df limit)
(define v (f))
(define limit* (- limit i:logo-width))
(cond [(< v 0) (f 0) (df (abs (df)))]
[(> v limit*) (f limit*) (df (- (abs (df))))]
[else (void)]))
(on (message (frame-event _ _ _ _))
(when (w) ;; don't animate until we know the window bounds
(x (+ (x) (dx)))
(y (+ (y) (dy)))
(bounce x dx (window-width (w)))
(bounce y dy (window-height (w)))))))
(spawn-background)
(for [(i sprite-count)]
(spawn-logo))
(spawn (define start-time #f)
(log-info "Sprite count: ~a" sprite-count)
(on (message (frame-event $counter $timestamp _ _))
(if (eq? start-time #f)
(set! start-time (current-inexact-milliseconds))
(let ((delta (- (current-inexact-milliseconds) start-time)))
(when (and (zero? (modulo counter 100)) (positive? delta))
(log-info "~v frames, ~v ms ==> ~v Hz"
counter
delta
(/ counter (/ delta 1000.0))))))))
(spawn-gl-2d-driver)
(spawn (field [fullscreen? #f])
(on (message (key-event #\f #t _)) (fullscreen? (not (fullscreen?))))
(assert #:when (fullscreen?) (gl-control 'fullscreen))
(on (message (key-event #\q #t _))
(send! (gl-control 'stop))))

View File

@ -0,0 +1,828 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang syndicate
(require 2htdp/image)
(require 2htdp/planetcute)
(require racket/set)
(require plot/utils) ;; for vector utilities
(require (only-in racket/string string-prefix?))
(require (only-in racket/gui/base play-sound))
(require/activate syndicate/drivers/timer)
(require/activate syndicate/drivers/gl-2d)
(require syndicate/bag)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Layers:
;;
;; - External I/O
;; as arranged by syndicate-gl/2d
;; including keyboard events, interface to rendering, and frame timing
;;
;; - Ground
;; corresponds to computer itself
;; device drivers
;; applications (e.g. in this instance, the game)
;;
;; - Game
;; running application
;; per-game state, such as score and count-of-deaths
;; process which spawns levels
;; regular frame ticker
;;
;; - Level
;; model of the game world
;; actors represent entities in the world, mostly
;; misc actors do physicsish things
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ## Common Data Definitions
;;
;; A Vec is a (vector Number Number)
;; A Point is a (vector Number Number)
;; (See vector functions in plot/utils)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ## Ground Layer Protocols
;;-------------------------------------------------------------------------
;; ### Scene Management
;; - assertion: ScrollOffset
;; - assertion: OnScreenDisplay
;; - role: SceneManager
;; Displays the scene backdrop and adjusts display coordinates via ScrollOffset.
;;
;; A ScrollOffset is a (scroll-offset Vec), indicating the vector to *subtract*
;; from world coordinates to get device coordinates.
(struct scroll-offset (vec) #:transparent)
;;
;; An OnScreenDisplay is an (on-screen-display Number Number (Seal Image)),
;; representing an item to display in a fixed window-relative position
;; above the scrolled part of the scene. If the coordinates are
;; positive, they measure right/down from the left/top of the image;
;; if negative, they measure left/up from the right/bottom.
(struct on-screen-display (x y sealed-image) #:transparent)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ## Game Layer Protocols
;;-------------------------------------------------------------------------
;; ### Scoring
;; - message: AddToScore
;; - assertion: CurrentScore
;; - role: ScoreKeeper
;; Maintains the score as private state.
;; Publishes the score using a CurrentScore.
;; Responds to AddToScore by updating the score.
;;
;; An AddToScore is an (add-to-score Number), a message
;; which signals a need to add the given number to the player's
;; current score.
(struct add-to-score (delta) #:transparent)
;;
;; A CurrentScore is a (current-score Number), an assertion
;; indicating the player's current score.
(struct current-score (value) #:transparent)
;;-------------------------------------------------------------------------
;; ### Level Spawning
;; - assertion: LevelRunning
;; - message: LevelCompleted
;; - role: LevelSpawner
;; Maintains the current level number as private state.
;; Spawns a new Level when required.
;; Monitors LevelRunning - when it drops, the level is over.
;; Receives LevelCompleted messages. If LevelRunning drops without
;; a LevelCompleted having arrived, the level ended in failure and
;; should be restarted. If LevelComplete arrived before LevelRunning
;; dropped, the level was completed successfully, and the next level
;; should be presented.
;; - role: Level
;; Running level instance. Maintains LevelRunning while it's still
;; going. Sends LevelCompleted if the player successfully completed
;; the level.
;;
;; A LevelRunning is a (level-running), an assertion indicating that the
;; current level is still in progress.
(struct level-running () #:transparent)
;;
;; A LevelCompleted is a (level-completed), a message indicating that
;; the current level was *successfully* completed before it terminated.
(struct level-completed () #:transparent)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ## Level Layer Protocols
;;-------------------------------------------------------------------------
;; ### Movement and Physics
;; - message: JumpRequest
;; - assertion: Impulse
;; - assertion: Position
;; - assertion: GamePieceConfiguration
;; - assertion: Touching
;; - role: PhysicsEngine
;; Maintains positions, velocities and accelerations of all GamePieces.
;; Uses GamePieceConfiguration for global properties of pieces.
;; Publishes Position to match.
;; Listens to FrameDescription, using it to advance the simulation.
;; Considers only mobile GamePieces for movement.
;; Takes Impulses as the baseline for moving GamePieces around.
;; For massive mobile GamePieces, applies gravitational acceleration.
;; Computes collisions between GamePieces.
;; Uses Attributes of GamePieces to decide what to do in response to collisions.
;; For 'touchable GamePieces, a Touching row is asserted.
;; Responds to JumpRequest by checking whether the named piece is in a
;; jumpable location, and sets its upward velocity negative if so.
;; - role: GamePiece
;; Maintains private state. Asserts Impulse to move around,
;; and GamePieceConfiguration to get things started. May issue
;; JumpRequests at any time. Represents both the player,
;; enemies, the goal(s), and platforms and blocks in the
;; environment. Asserts a Sprite two layers out to render
;; itself.
;;
;; An ID is a Symbol; the special symbol 'player indicates the player's avatar.
;; Gensyms from (gensym 'enemy) name enemies, etc.
;;
;; A JumpRequest is a (jump-request ID), a message indicating a *request* to jump,
;; not necessarily honoured by the physics engine.
(struct jump-request (id) #:transparent)
;;
;; An Impulse is an (impulse ID Vec), an assertion indicating a contribution to
;; the net *requested* velocity of the given gamepiece.
(struct impulse (id vec) #:transparent)
;;
;; A Position is a (position ID Point Vec), an assertion describing
;; the current actual top-left corner and (physics-related, not
;; necessarily graphics-related) size of the named gamepiece.
(struct position (id top-left size) #:transparent)
;;
;; An Attribute is either
;; - 'player - the named piece is a player avatar
;; - 'touchable - the named piece reacts to the player's touch
;; - 'solid - the named piece can be stood on / jumped from
;; - 'mobile - the named piece is not fixed in place
;; - 'massive - the named piece is subject to effects of gravity
;; (it is an error to be 'massive but not 'mobile)
;;
;; A GamePieceConfiguration is a
;; - (game-piece-configuration ID Point Vec (Set Attribute))
;; an assertion specifying not only the *existence* of a named
;; gamepiece, but also its initial position and size and a collection
;; of its Attributes.
(struct game-piece-configuration (id initial-position size attributes) #:transparent)
;;
;; A Touching is a
;; - (touching ID ID Side)
;; an assertion indicating that the first ID is touching the second on
;; the named side of the second ID.
(struct touching (a b side) #:transparent)
;;
;; A Side is either 'top, 'left, 'right, 'bottom or the special value
;; 'mid, indicating an unknown or uncomputable side.
(define (game-piece-has-attribute? g attr)
(set-member? (game-piece-configuration-attributes g) attr))
;;-------------------------------------------------------------------------
;; ### Player State
;; - message: Damage
;; - assertion: Health
;; - role: Player
;; Maintains hitpoints, which it reflects using Health.
;; Responds to Damage.
;; When hitpoints drop low enough, removes the player from the board.
;;
;; A Damage is a (damage ID Number), a message indicating an event that should
;; consume the given number of health points of the named gamepiece.
(struct damage (id hit-points) #:transparent)
;;
;; A Health is a (health ID Number), an assertion describing the current hitpoints
;; of the named gamepiece.
(struct health (id hit-points) #:transparent)
;;-------------------------------------------------------------------------
;; ### World State
;; - assertion: LevelSize
;; - role: DisplayControl
;; Maintains a LevelSize assertion.
;; Observes the Position of the player, and computes and maintains a
;; ScrollOffset two layers out, to match.
;; Also kills the player if they wander below the bottom of the level.
;;
;; A LevelSize is a (level-size Vec), an assertion describing the right-hand and
;; bottom edges of the level canvas (in World coordinates).
(struct level-size (vec) #:transparent)
;; -----------
;; Interaction Diagrams (to be refactored into the description later)
;;
;; ================================================================================
;;
;; title Jump Sequence
;;
;; Player -> Physics: (jump 'player)
;; note right of Physics: Considers the request.
;; note right of Physics: Denied -- Player is not on a surface.
;;
;; Player -> Physics: (jump 'player)
;; note right of Physics: Considers the request.
;; note right of Physics: Accepted.
;; note right of Physics: Updates velocity, position
;; Physics -> Subscribers: (vel 'player ...)
;; Physics -> Subscribers: (pos 'player ...)
;;
;;
;; ================================================================================
;;
;; title Display Control Updates
;;
;; Physics -> DisplayCtl: (pos 'player ...)
;; note right of DisplayCtl: Compares player pos to level size
;; DisplayCtl -> Subscribers: (inbound (inbound (scroll-offset ...)))
;;
;; ================================================================================
;;
;; title Movement Sequence
;;
;; Moveable -> Physics: (mobile ID Boolean)
;; Moveable -> Physics: (attr ID ...)
;; Moveable -> Physics: (impulse ID vec)
;; note right of Physics: Processes simulation normally
;; Physics -> Subscribers: (pos ID ...)
;; Physics -> Subscribers: (vel ID ...)
;;
;; ================================================================================
;;
;; title Keyboard Interpretation
;;
;; Keyboard -> Player: (press right-arrow)
;; Player -->> Physics: assert (impulse ID (vec DX 0))
;;
;; note right of Physics: Processes simulation normally
;;
;; Keyboard -> Player: (press left-arrow)
;; Player -->> Physics: assert (impulse ID (vec 0 0))
;;
;; Keyboard -> Player: (release right-arrow)
;; Player -->> Physics: assert (impulse ID (vec -DX 0))
;;
;; Keyboard -> Player: (press space)
;; Player -> Physics: (jump)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Icon
(struct icon (pict scale hitbox-width-fraction hitbox-height-fraction baseline-fraction)
#:transparent)
(define (icon-width i) (* (image-width (icon-pict i)) (icon-scale i)))
(define (icon-height i) (* (image-height (icon-pict i)) (icon-scale i)))
(define (icon-hitbox-width i) (* (icon-width i) (icon-hitbox-width-fraction i)))
(define (icon-hitbox-height i) (* (icon-height i) (icon-hitbox-height-fraction i)))
(define (icon-hitbox-size i) (vector (icon-hitbox-width i) (icon-hitbox-height i)))
(define (focus->top-left i x y)
(vector (- x (/ (icon-hitbox-width i) 2))
(- y (icon-hitbox-height i))))
(define (icon-sprite i layer pos)
(match-define (vector x y) pos)
(simple-sprite layer
(- x (/ (- (icon-width i) (icon-hitbox-width i)) 2))
(- y (- (* (icon-baseline-fraction i) (icon-height i)) (icon-hitbox-height i)))
(icon-width i)
(icon-height i)
(icon-pict i)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SceneManager
(define (spawn-scene-manager)
(spawn #:name 'scene-manager
(define backdrop (rectangle 1 1 "solid" "white"))
(define/query-value size (vector 0 0) (window $x $y) (vector x y))
(define/query-set osds ($ o (on-screen-display _ _ _)) o)
(define/query-value offset (vector 0 0) (scroll-offset $v) v)
(field [fullscreen? #f])
(assert #:when (fullscreen?) (gl-control 'fullscreen))
(on (message (key-event #\f #t _))
(fullscreen? (not (fullscreen?))))
(define (compute-backdrop)
(match-define (vector width height) (size))
(match-define (vector ofs-x ofs-y) (offset))
(define osd-blocks
(for/list [(osd (in-set (osds)))]
(match-define (on-screen-display raw-x raw-y (seal i)) osd)
(define x (if (negative? raw-x) (+ width raw-x) raw-x))
(define y (if (negative? raw-y) (+ height raw-y) raw-y))
`(push-matrix (translate ,x ,y)
(scale ,(image-width i) ,(image-height i))
(texture ,i))))
(scene (seal `((push-matrix
(scale ,width ,height)
(texture ,backdrop))
(translate ,(- ofs-x) ,(- ofs-y))))
(seal `((translate ,ofs-x ,ofs-y)
,@osd-blocks))))
(assert (compute-backdrop))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ScoreKeeper
(define (spawn-score-keeper)
(spawn #:name 'score-keeper
(field [score 0])
(assert (current-score (score)))
(assert (outbound
(on-screen-display -150 10
(seal (text (format "Score: ~a" (score)) 24 "white")))))
(on (message (add-to-score $delta))
(score (+ (score) delta))
(log-info "Score increased by ~a to ~a" delta (score))
(play-sound-sequence 270304))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PhysicsEngine
(define impulse-multiplier 0.360) ;; 360 pixels per second
(define jump-vel (vector 0 -2))
(define gravity 0.004)
(define (spawn-physics-engine)
(spawn #:name 'physics-engine
(field [configs (hash)]
[previous-positions (hash)]
[previous-velocities (hash)]
[positions (hash)]
[velocities (hash)])
(during (game-piece-configuration $id $initial-position $size $attrs)
(on-start (configs
(hash-set (configs) id
(game-piece-configuration id initial-position size attrs))))
(on-stop (configs (hash-remove (configs) id))
(positions (hash-remove (positions) id))
(velocities (hash-remove (velocities) id)))
(assert (position id (hash-ref (positions) id initial-position) size)))
(define/query-hash impulses (impulse $id $vec) id vec)
(define (piece-cfg id) (hash-ref (configs) id))
(define (piece-pos which id)
(hash-ref (which) id (lambda () (game-piece-configuration-initial-position (piece-cfg id)))))
(define (piece-vel which id) (hash-ref (which) id (lambda () (vector 0 0))))
(define (piece-imp id) (hash-ref (impulses) id (lambda () (vector 0 0))))
(define (update-piece! g new-pos new-vel)
(positions (hash-set (positions) (game-piece-configuration-id g) new-pos))
(velocities (hash-set (velocities) (game-piece-configuration-id g) new-vel)))
(define (find-support p size which-pos)
(match-define (vector p-left p-top) p)
(match-define (vector p-w p-h) size)
(define p-right (+ p-left p-w))
(define p-bottom (+ p-top p-h))
(for/or [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)]
(match-define (vector left top) (piece-pos which-pos id))
(and (< (abs (- top p-bottom)) 0.5)
(<= left p-right)
(match (game-piece-configuration-size g)
[(vector w h)
(<= p-left (+ left w))])
g)))
(define (segment-intersection-time p0 r q0 q1)
;; See http://stackoverflow.com/a/565282/169231
;; Enhanced to consider the direction of impact with the segment,
;; too: only returns an intersection when the vector of motion is
;; at an obtuse angle to the normal of the segment.
(define s (v- q1 q0))
(define rxs (vcross2 r s))
(cond [(< (abs rxs) 0.005) #f] ;; zeroish; lines are parallel (and maybe collinear)
[else
(define q-p (v- q0 p0))
(define q-pxs (vcross2 q-p s))
(define t (/ q-pxs rxs))
(and (<= 0 t 1)
(let* ((q-pxr (vcross2 q-p r))
(u (/ q-pxr rxs)))
(and (< 0 u 1)
(let* ((q-norm
(vnormalize (vector (vector-ref s 1) (- (vector-ref s 0))))))
(and (not (positive? (vdot r q-norm)))
(- t 0.001))))))]))
(define (three-corners top-left size)
(match-define (vector w h) size)
(values (v+ top-left (vector w 0))
(v+ top-left size)
(v+ top-left (vector 0 h))))
(define (clip-movement-by top-left moved-top-left size solid-top-left solid-size)
(define-values (solid-top-right solid-bottom-right solid-bottom-left)
(three-corners solid-top-left solid-size))
(define-values (top-right bottom-right bottom-left)
(three-corners top-left size))
(define r (v- moved-top-left top-left))
(define t
(apply min
(for/list [(p (in-list (list #;top-left #;top-right bottom-right bottom-left)))]
(min (or (segment-intersection-time p r solid-top-left solid-top-right) 1)
;; TODO: some means of specifying *which edges* should appear solid.
#;(or (segment-intersection-time p r solid-top-right solid-bottom-right) 1)
#;(or (segment-intersection-time p r solid-bottom-right solid-bottom-left) 1)
#;(or (segment-intersection-time p r solid-bottom-left solid-top-left) 1)))))
(v+ top-left (v* r t)))
(define (clip-movement-by-solids p0 p1 size)
(for/fold [(p1 p1)]
[((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)]
(clip-movement-by p0 p1 size
(piece-pos previous-positions id)