;; #lang racket

;; (require games/cards racket/class)

;;;
;;; Extension of the Algorithmic Language Scheme
;;;

;; (define (broadcast object-list method . arguments)
;;   {define (apply-messages object)
;;     (send/apply object method arguments)}
;;   (map apply-messages object-list))

(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 (repeat n closure)
  "Execute closure n times."
  (if (not (and (exact? n)
                (integer? n)  ; 'integer?' does not check for exactness ...
                (>= 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
  ;; Every car has four wheels.
  car)

;;
;; The Virtual Card Library wants us to program in assembler
;; style. This is how we escape it.
(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)        ; determine the winning 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)        ; determine the winning 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)

;; That is "sea cat" but where is "bee cat"?
;; (You might even find "a cat").
(define sea-cat create-cell-and-attach)


;;;
;;; Card Logic
;;;

;;
;; Card Suits and Colors: Predicates and Utility Procedures

(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]
    ;; the following entry exists for completeness as card<%> get-suit
    ;; might return 'unknown
    [(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))


;;
;; Card Rank Predicates

(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))


;;;
;;; Card Binary Predicates

;; Card Rank Binary Predicates

(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)))))


;; Card Color and Suit Binary Predicates

(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)))


;;;
;;; Debugging and other Developer Utilities
;;;

(define (debug . args)
  (display "Flower Garden: ")
  (for-each {lambda (arg) (display arg)}
            args)
  (newline))

(define (warning . args)
  (apply debug "WARNING: " args))

;;; End of Pretext