(define-syntax cast (syntax-rules () ((_ type) (cdr type))))
(define-syntax broadcast
(syntax-rules ()
((_ object-list method ...)
(map {lambda (object) (send object method ...)}
object-list))))
(define-syntax broadcast*
(syntax-rules ()
((_ object-list method ...)
(map {lambda (object) (send* object method ...)}
object-list))))
(define-syntax define/on-delegate
(syntax-rules ()
((_ delegate-object (method-name ...))
(define (method-name ...)
(send delegate-object method-name ...)) )))
(define (repeat n closure)
"Execute closure n times."
(if (not (and (exact? n)
(integer? n) (>= n 0)))
(error "repeat: the parameter n must be an exact natural number or zero.")
{let loop ((i 0))
(when (< i n)
(closure)
(loop (add1 i)))} ))
(define (apply-or well-formed-list)
(foldl {lambda (a b) (or a b)}
#f
well-formed-list))
(define (apply-and well-formed-list)
(foldl {lambda (a b) (and a b)}
#t
well-formed-list))
(define (half numerical) (/ numerical 2))
(define wheels
car)
(define (w/o-card-animation table closure)
"Don't let the car's movement be shown."
(let ((returned-value void))
(send table begin-card-sequence) (set! returned-value (closure))
(send table end-card-sequence)
returned-value))
(define-syntax w/o-card-animation*
(syntax-rules ()
((_ table first-expression ...)
(let* ([closure {lambda ()
first-expression
...}]
[returned-value void])
(send table begin-card-sequence)
(set! returned-value (closure))
(send table end-card-sequence)
returned-value) )))
(define (with-card-animation table closure)
"Don't let the car's movement be shown."
(let ((returned-value void))
(send table end-card-sequence)
(set! returned-value (closure))
(send table begin-card-sequence) returned-value))
(define-syntax with-card-animation*
(syntax-rules ()
((_ table first-expression ...)
(let* ([closure {lambda ()
first-expression
...}]
[returned-value void])
(send table end-card-sequence)
(set! returned-value (closure))
(send table begin-card-sequence)
returned-value) )))
(define create-cell-and-attach cons)
(define sea-cat create-cell-and-attach)
(define (suit-color suit-symbol)
"Return 'red for 'heart and 'club. Return 'black for 'diamond or 'spade. Else false."
(case suit-symbol
[(hearts diamonds) 'red]
[(clubs spades) 'black]
[(unknown)
(debug "card logic: suit-color: unknown suit") #f]
[else
(warning "card logic: suit-color: suit not found: " suit-symbol) #f]))
(define (card-color card)
"Return the color of the card's suit like suit-color."
(suit-color (send card get-suit)))
(define (card-is-red? card)
"Return true if the color of the card's suit is red."
(eq? (card-color card) 'red))
(define (card-is-black? card)
"Return true if the color of the card's suit is black."
(eq? (card-color card) 'black))
(define (card-is-ace? card)
"Return true if the card is an ace."
(= (send card get-value) 1))
(define (card-is-king? card)
"Return true if the card is a king."
(= (send card get-value) 13))
(define (card-is-queen? card)
"Return true if the card is a queen."
(= (send card get-value) 12))
(define (card-is-jack? card)
"Reutrn true if the card is a jack."
(= (send card get-value) 11))
(define (card-is-ten? card) "Return true if the card is a ten."
(= (send card get-value) 10))
(define (card-is-nine? card) "Return true if the card is a nine."
(= (send card get-value) 9))
(define (card-is-eight? card) "Return true if the card is an eight."
(= (send card get-value) 8))
(define (card-is-seven? card) "Return true if the card is a seven."
(= (send card get-value) 7))
(define (card-is-six? card) "Return true if the card is a six."
(= (send card get-value) 6))
(define (card-is-five? card) "Return true if the card is a five."
(= (send card get-value) 5))
(define (card-is-four? card) "Return true if the card is a four."
(= (send card get-value) 4))
(define (card-is-three? card) "Return true if the card is a three."
(= (send card get-value) 3))
(define (card-is-two? card) "Return true if the card is a two."
(= (send card get-value) 2))
(define (card-one-rank-below? first-card second-card)
"Return true if the first-card is one rank below the second-card."
(let ((first-value (send first-card get-value))
(second-value (send second-card get-value)))
(= 1 (- second-value first-value))))
(define (card-one-rank-above? first-card second-card)
"Return true if the first-card is one rank above the second-card."
(card-one-rank-below? second-card first-card))
(define (card-next-rank? first-card second-card)
"Return true if the first card is one rank above or below the second-card."
(or (card-one-rank-below? first-card second-card)
(card-one-rank-above? first-card second-card)))
(define (card-circular-one-rank-below? first-card second-card)
"Return true if card-one-rank-below? is true or if the first-card is a king and second-card is an ace."
(or (card-one-rank-below? first-card second-card)
(and (card-is-king? first-card)
(card-is-ace? second-card))))
(define (card-circular-one-rank-above? first-card second-card)
"Return true if card-one-rank-above? is true or if the first-card is an ace and the second-card is a king."
(or (card-one-rank-above? first-card second-card)
(and (card-is-ace? first-card)
(card-is-king? second-card))))
(define (card-circular-next-rank? first-card second-card)
"Return true if card-next-rank? is true or if the two cards are a king and an ace."
(or (card-next-rank? first-card second-card)
(or (and (card-is-king? first-card) (card-is-ace? second-card))
(and (card-is-ace? first-card) (card-is-king? second-card)))))
(define (card-same-color? first-card second-card)
"Return true if the color of the first-card's suit is the same as the one of the second-card."
(eq? (card-color first-card)
(card-color second-card)))
(define (card-same-suit? first-card second-card)
"Return true if the suit of the first-card is the same as the one of the second-card."
(eq? (send first-card get-suit)
(send second-card get-suit)))
(define (debug . args)
(display "Flower Garden: ")
(for-each {lambda (arg) (display arg)}
args)
(display " (") (delta-debug) (display ")")
(newline))
(define (warning . args)
(apply debug "WARNING: " args))
(define *last-time* #f)
(define *last-process-time* #f)
(define *last-gc-time* #f)
(define (delta a b)
"Return the numerical distance between a and b."
(let ((a (abs a))
(b (abs b)))
(if (>= a b)
(- a b)
(- b a))))
(define (delta-debug)
(let ((time (current-milliseconds))
(process-time (current-process-milliseconds))
(gc-time (current-gc-milliseconds)))
(define (set-last)
(set! *last-time* time)
(set! *last-process-time* process-time)
(set! *last-gc-time* gc-time))
(when (not (and *last-time* *last-process-time*))
(display "debug-delta: init with current time: ")
(display (date->string
(seconds->date
(* 0.001 (current-inexact-milliseconds))) #t))
(display " ")
(set-last))
(let ((delta-time (delta time *last-time*))
(delta-process-time (delta process-time *last-process-time*))
(delta-gc-time (delta gc-time *last-gc-time*)))
(for-each display (list "debug-delta:"
" clock: " delta-time
" cpu: " delta-process-time
" gc: " delta-gc-time)))
(set-last)) )
(define (my-collect-garbage)
(display "Flower Garden: manual GC: ")
(time (collect-garbage)))