175 lines
6.4 KiB
Scheme
175 lines
6.4 KiB
Scheme
#lang scheme
|
|
|
|
(require htdp/image
|
|
htdp/error
|
|
(only-in lang/htdp-beginner image?))
|
|
|
|
(provide (all-defined-out))
|
|
|
|
(define INSET 5) ;; the space around the image in the canvas
|
|
(define RATE 1/30) ;; the clock tick rate
|
|
(define TRIES 3) ;; how many times should register try to connect to the server
|
|
(define PAUSE 1/2) ;; # secs to wait between attempts to connect to server
|
|
(define SQPORT 4567) ;; the port on which universe traffic flows
|
|
|
|
(define (K w . r) w)
|
|
(define (False w) #f)
|
|
|
|
;
|
|
;
|
|
;
|
|
; ;;; ;;;
|
|
; ; ; ; ;
|
|
; ; ; ; ;
|
|
; ; ;;; ;;;;; ;;;;; ;;; ;;;; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;;
|
|
; ;;; ;;; ; ; ; ; ; ; ;;; ; ; ; ; ;; ; ; ; ;;
|
|
;
|
|
;
|
|
;
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
|
|
;; Any -> Boolean
|
|
(define (scene? i)
|
|
(and (image? i) (internal-scene? i)))
|
|
|
|
;; Image -> Boolean
|
|
(define (internal-scene? i)
|
|
(and (= 0 (pinhole-x i)) (= 0 (pinhole-y i))))
|
|
|
|
;; Number -> Integer
|
|
(define (number->integer x)
|
|
(inexact->exact (floor x)))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; Nat Nat ->String
|
|
;; converts i to a string, adding leading zeros, make it at least as long as L
|
|
(define (zero-fill i L)
|
|
(let ([n (number->string i)])
|
|
(string-append (make-string (max (- L (string-length n)) 0) #\0) n)))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
|
|
;; MouseEvent -> [List Nat Nat MouseEventType]
|
|
;; turn a mouse event into its pieces
|
|
(define (mouse-event->parts e)
|
|
(define x (- (send e get-x) INSET))
|
|
(define y (- (send e get-y) INSET))
|
|
(values x y (cond [(send e button-down?) 'button-down]
|
|
[(send e button-up?) 'button-up]
|
|
[(send e dragging?) 'drag]
|
|
[(send e moving?) 'move]
|
|
[(send e entering?) 'enter]
|
|
[(send e leaving?) 'leave]
|
|
[else ; (send e get-event-type)
|
|
(error 'on-mouse-event
|
|
(format
|
|
"Unknown event type: ~a"
|
|
(send e get-event-type)))])))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; Any -> Symbol
|
|
(define (name-of draw tag)
|
|
(define fname (object-name draw))
|
|
(if fname fname tag))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; Any -> Boolean
|
|
(define (sexp? x)
|
|
(cond
|
|
[(empty? x) true]
|
|
[(string? x) true]
|
|
[(symbol? x) true]
|
|
[(number? x) true]
|
|
[(char? x) true]
|
|
[(pair? x) (and (list? x) (andmap sexp? x))]
|
|
[else false]))
|
|
|
|
(define (no-newline? x)
|
|
(not (member #\newline (string->list x))))
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
;; exchange one-line messages between worlds and the server
|
|
|
|
(define tcp-eof (gensym 'tcp-eof))
|
|
|
|
;; Any -> Boolean
|
|
(define (tcp-eof? a) (eq? tcp-eof a))
|
|
|
|
;; OutPort Sexp -> Void
|
|
(define (tcp-send out msg)
|
|
(write msg out)
|
|
(newline out)
|
|
(flush-output out))
|
|
|
|
;; InPort -> Sexp
|
|
(define (tcp-receive in)
|
|
(with-handlers ((exn? (lambda (x) (raise tcp-eof))))
|
|
(define x (read in))
|
|
(if (eof-object? x)
|
|
(raise tcp-eof)
|
|
(begin
|
|
(read-line in) ;; read the newline
|
|
x))))
|
|
|
|
;
|
|
;
|
|
;
|
|
; ;;; ;;; ; ;
|
|
; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ;
|
|
; ; ; ; ;; ;;;; ; ;;;; ; ;
|
|
; ;;;;; ;; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ;;
|
|
; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ;;;; ;;; ; ; ; ;
|
|
; ;
|
|
; ; ;
|
|
; ;;;
|
|
|
|
;; Symbol Any String -> Void
|
|
(define (check-pos t c r)
|
|
(check-arg
|
|
t (and (number? c) (>= (number->integer c) 0)) "positive integer" r c))
|
|
|
|
;; Symbol Any String String *-> Void
|
|
(define (check-image tag i rank . other-message)
|
|
(if (and (pair? other-message) (string? (car other-message)))
|
|
(check-arg tag (image? i) (car other-message) rank i)
|
|
(check-arg tag (image? i) "image" rank i)))
|
|
|
|
;; Symbol Any String -> Void
|
|
(define (check-scene tag i rank)
|
|
(define error "image with pinhole at (~s,~s)")
|
|
(if (image? i)
|
|
(check-arg tag (internal-scene? i) "scene" rank (image-pins i))
|
|
(check-arg tag #f "scene" rank i)))
|
|
|
|
;; Symbol Any -> Void
|
|
(define (check-scene-result tname i)
|
|
(if (image? i)
|
|
(check-result tname internal-scene? "scene" i (image-pins i))
|
|
(check-result tname (lambda (x) (image? x)) "scene" i)))
|
|
|
|
(define (image-pins i)
|
|
(format "image with pinhole at (~s,~s)" (pinhole-x i) (pinhole-y i)))
|
|
|
|
|
|
;; Symbol Any String -> Void
|
|
(define (check-color tag width rank)
|
|
(check-arg tag (or (symbol? width) (string? width))
|
|
"color symbol or string" rank width))
|
|
|
|
;; Symbol (union Symbol String) Nat -> Void
|
|
(define (check-mode tag s rank)
|
|
(check-arg tag (or (eq? s 'solid)
|
|
(eq? s 'outline)
|
|
(string=? "solid" s)
|
|
(string=? "outline" s)) "mode (solid or outline)" rank s))
|
|
|