syndicate-2017/racket/prospect/big-bang.rkt

180 lines
7.1 KiB
Racket

#lang racket/base
(provide big-bang-network
big-bang-network/universe
(struct-out window)
(struct-out to-server)
(struct-out from-server)
(struct-out tick-event)
(struct-out key-event)
(struct-out pad-event)
(struct-out release-event)
(struct-out mouse-event)
(struct-out mouse-state)
(struct-out active-window)
update-window
(all-from-out 2htdp/image))
(require racket/set)
(require racket/match)
(require 2htdp/image)
(require (except-in 2htdp/universe
key-event?
pad-event?
mouse-event?))
(require (only-in 2htdp/private/check-aux SQPORT))
(require (only-in racket/list flatten))
(require "main.rkt")
(require "trie.rkt")
;;---------------------------------------------------------------------------
(struct window (id x y z image) #:transparent) ;; image must be sealed
(struct to-server (message) #:transparent)
(struct from-server (message) #:transparent)
(struct tick-event () #:transparent)
(struct key-event (key window) #:transparent)
(struct pad-event (key window) #:transparent)
(struct release-event (key window) #:transparent)
(struct mouse-event (x y window type) #:transparent)
(struct mouse-state (x y window) #:transparent)
(struct active-window (id) #:transparent)
(define (update-window id x y image #:z [z 0])
(patch-seq (retract (window id ? ? ? ?) #:meta-level 1)
(assert (window id x y z (seal image)) #:meta-level 1)))
;;---------------------------------------------------------------------------
(struct bb (network windows inbound outbound halted? x y) #:transparent)
(define window-projection (?! (window ? ? ? ? ?)))
(define (inject b es)
(interpret-actions (struct-copy bb b [inbound (append (bb-inbound b)
es
(list (update-active-window
(find-active-window b))))])
#f
#t))
(define (incorporate-patch b p)
(define-values (added removed) (patch-project/set/single p window-projection))
(struct-copy bb b
[windows (sort (set->list (set-union added
(set-subtract (list->set (bb-windows b))
removed)))
(lambda (w1 w2) (< (window-z w1) (window-z w2))))]
[halted? (if (or (and (bb-halted? b)
(not (trie-lookup (patch-removed p) 'stop #f)))
(trie-lookup (patch-added p) 'stop #f))
#t
#f)]))
(define (deliver b e)
(clean-transition (network-handle-event e (bb-network b))))
(define (interpret-actions b txn need-poll?)
(match txn
[#f ;; inert
(match (bb-inbound b)
['()
(if need-poll?
(interpret-actions b (deliver b #f) #f)
(let ((outbound (reverse (bb-outbound b))))
(if (null? outbound)
b
(make-package (struct-copy bb b [outbound '()]) outbound))))]
[(cons e rest)
(let ((b (struct-copy bb b [inbound rest])))
(interpret-actions b (deliver b e) #t))])]
[(transition new-network actions)
(let process-actions ((b (struct-copy bb b [network new-network])) (actions actions))
(match actions
['() (interpret-actions b #f #t)]
[(cons a actions)
(process-actions (match a
[(? patch? p)
(incorporate-patch b p)]
[(message (to-server sexp))
(struct-copy bb b
[outbound (cons sexp (bb-outbound b))])]
[_ b])
actions)]))]))
(define (inside? mx my x y image)
(and (>= mx x)
(>= my y)
(< (- mx x) (image-width image))
(< (- my y) (image-height image))))
(define (find-active-window b)
(define mx (bb-x b))
(define my (bb-y b))
(let loop ((ws (bb-windows b)))
(match ws
['() #f]
[(cons (window id x y _ (seal image)) ws)
(if (inside? mx my x y image) id (loop ws))])))
(define (render b)
(for/fold [(scene empty-image)] [(w (bb-windows b))]
(match-define (window _ x y z (seal image)) w)
(overlay/xy scene x y image)))
(define (update-active-window active-id)
(patch-seq (retract (active-window ?))
(assert (active-window active-id))))
(define-syntax-rule (big-bang-network* boot-actions extra-clause ...)
(big-bang (interpret-actions (bb (make-network boot-actions)
'()
'()
'()
#f
0
0)
#f
#t)
(on-tick (lambda (b)
(inject b (list (message (tick-event))))))
(on-key (lambda (b k)
(inject b (list (message (key-event k (find-active-window b)))))))
;; (on-pad (lambda (b p)
;; (inject b (list (message (pad-event p (find-active-window b)))))))
(on-release (lambda (b k)
(inject b (list (message (release-event k (find-active-window b)))))))
(on-mouse (lambda (b0 x y e)
(define b (struct-copy bb b0 [x x] [y y]))
(define active-id (find-active-window b))
(inject b (list (patch-seq (retract (mouse-state ? ? ?))
(assert (mouse-state x y active-id)))
(message (mouse-event x y active-id e))))))
(stop-when bb-halted?)
extra-clause ...))
(define-syntax-rule (big-bang-network** width height boot-actions extra-clause ...)
(if (and width height)
(big-bang-network* boot-actions (to-draw render width height) extra-clause ...)
(big-bang-network* boot-actions (to-draw render) extra-clause ...)))
(define (big-bang-network #:width [width #f]
#:height [height #f]
. boot-actions)
(big-bang-network** width height boot-actions))
(define (big-bang-network/universe #:width [width #f]
#:height [height #f]
#:register [ip LOCALHOST]
#:port [port-number SQPORT]
#:name [world-name (gensym 'prospect)]
. boot-actions)
(big-bang-network** width height boot-actions
(on-receive (lambda (b sexps)
(inject b (for/list ((m sexps)) (message (from-server m))))))
(register ip)
(port port-number)
(name world-name)))