;; #lang racket

;; (require games/cards racket/class
;;          "pretext.rkt")

;;
;; Stacks
;;
;; There are three kinds of stacks: foundations, flower beds and
;; bouquet. Layouting is done with the help of the layout hub object
;; as retrieved from the hosting garden object.
;;
;; While each card<%> object knows about its home-region, the regions
;; are not aware of these cards. To get all the cards in one region on
;; the table we could ask each card individually or keep track of all
;; the moves and maintain the missing list of cards for each stack.
;;
;; NB Asking all card objects on the table about their home-region is
;; not too time consuming, i.e. O(n), where each deck brings only 52
;; objects into the game.

(define stack%
  {class
   object%
   (init garden)
   (super-new)

   ;;
   ;; Fields
   (define cards null)
   (define my-region null)
   (define my-garden garden)

   ;; Accessors
   (define/public (get-garden) my-garden)
   (define/public (get-layout)
     (send my-garden get-layout))

   (define/public (add-card card-to-add)
     (send (send this get-garden) syncronize-stacks card-to-add)
     (set! cards (sea-cat card-to-add cards))
     (send* card-to-add
            (home-region my-region)
            ;;(stay-in-region my-region)
            )
     (send this add-card-pre-layout)
     (send (get-layout) layout-cards this)
     )

   (define/public (remove-card card-to-remove)
     (set! cards (filter {lambda (card)
                           (not (eq? card card-to-remove))}
                         cards)))

   (define/public (move-done)
     ;;(send (get-layout) layout-cards this)
     #t)

   (define/public (number-of-cards) (length cards))
   (define/public (empty?) (null? cards))
   (define/public (get-cards) cards)

   ;; Class Internal: bucket% needs this
   (define/public (set-cards bucket-cards)
     (set! cards bucket-cards))
   (define/public (add-card-pre-layout) #t)
;;    (define/public (drag-over on-region? cards)
;;      (debug "stack%: drag-over: " on-region?))



   (define/public (get-region) my-region)
   (define/public (set-region new-region)
     (set! my-region new-region)
;;      (set-region-interactive-callback!
;;       my-region
;;       {lambda (on-region? cards)
;;         (send this drag-over on-region? cards)})
     )

   ;;
   ;; Stateful Object Interface
   (define/public (save-state)
     (list (sea-cat 'cards cards)
           (sea-cat 'flower-states (map flower-save-state cards))))
   (define/public (restore-state state)
     (set! cards (cast (first state)))
     (let ((flower-states (cast (second state))))
       (map flower-restore-state
            cards
            flower-states))
     ;; The coordinates of the cards are restored by the stateful
     ;; table object but it cannot save or restore the z-axis order
     ;; so we have to do some layout again.
     (send (send this get-layout) layout-cards this)
     )
   })

(define foundation%
  {class
   stack%
   (init foundation-index)
   (super-new)

   (define my-index foundation-index)

   (define (foundation-region-callback cards)
     (send (send this get-garden)
           place-on-foundation-request (wheels cards) this))

   (let ((layout (send this get-layout)))
     (send this set-region
           (make-region
            (send layout get-foundation-x-coordinate this)
            (send layout get-foundation-y-coordinate this)
            (send layout get-foundation-width this)
            (send layout get-foundation-height this)
            (send layout get-foundation-title this)
            foundation-region-callback)))
   (send (send (send this get-garden) get-table)
         add-region (send this get-region))

   (define/public (get-foundation-index) my-index)
   })

(define flower-bed%
  {class
   stack%
   (init flower-bed-index)
   (super-new)

   (define my-index flower-bed-index)

   (define (flower-bed-region-callback cards)
     (send (send this get-garden)
           place-on-flower-bed-request (wheels cards) this))

   (let ((layout (send this get-layout)))
     (send this set-region
           (make-region
            (send layout get-flower-bed-x-coordinate this)
            (send layout get-flower-bed-y-coordinate this)
            (send layout get-flower-bed-width this)
            (send layout get-flower-bed-height this)
            (send layout get-flower-bed-title this)
            flower-bed-region-callback)))
   (send (send (send this get-garden) get-table)
         add-region (send this get-region))

   (define/public (get-flower-bed-index) my-index)

   (define (reconfigure-cards)
     (let ((my-cards (send this get-cards)))
       (broadcast* my-cards
                   (user-can-move #f)
                   (snap-back-after-move #t))
       [when [send (send this get-garden)
                   flowers-are-laughing]
           (broadcast my-cards face-up)]
       (when (not (null? my-cards))
             (let ((top-card (wheels my-cards)))
               (when [send top-card face-down?]
                     (send (send this get-garden)
                           card-face-up top-card))
               (send top-card user-can-move #t)) )))

   ;; Table animates zero moves and each one takes time.
   ;; Do as little layout as possible even with moves on self.
   ;; But this should happen after the bucket% animation.
   ;; move-done or queue ???
;;    (define/override (remove-card flower)
;;      (let* ((cards (send this get-cards))
;;             (number-of-cards (length cards))
;;             (hit (memq flower cards)))
;;        (super remove-card flower)
;;        (when [and hit (> number-of-cards 8)] ; magic number / see layout%
;;                   (send (send this get-layout) layout-cards this))))

   (define/public (laughing-flowers)
     (reconfigure-cards))

   (define/override (move-done)
     (reconfigure-cards))
   ;;(send (send this get-layout) layout-cards this))
   })

;; According to the game play bucket% might not even be a
;; stack%. Technically speaking it does not impose any useful order
;; onto the cards but is the reserve and its layout could be done by
;; the user. Quality assurance (me when I just want to play) assured
;; us though that doing the layout by hand isn't much fun and they
;; would prefer us to do the layout for the user.
(define bucket%
  {class
   stack%
   (super-new)

   (define (bucket-region-callback cards)
     (send (send this get-garden)
           place-on-bucket-request (wheels cards) this))

   (let ((layout (send this get-layout)))
     (send this set-region
           (make-region
            (send layout get-bucket-x-coordinate this)
            (send layout get-bucket-y-coordinate this)
            (send layout get-bucket-width this)
            (send layout get-bucket-height this)
            (send layout get-bucket-title this)
            bucket-region-callback)))
   (send (send (send this get-garden) get-table)
         add-region (send this get-region))

   (define (prepare-card-for-bucket card)
     (when (send card face-down?) (send card face-up))
     (send* card
            ;;(face-up)
            (snap-back-after-move #f)
            (user-can-move #t)
            ))

   (define/override (add-card card)
     (prepare-card-for-bucket card)
     (super add-card card))

   (define (sort-cards-by-x-axis-order)
     (let ((table (send (send this get-garden)
                        get-table)))
       (sort (send this get-cards)
             [lambda (first-card second-card)
               (let-values (([x1 y1] (send table
                                           card-location first-card))
                            ([x2 y2] (send table
                                           card-location second-card)))
                           (< x1 x2) )])))

   (define/override (move-done)
     (send this set-cards (sort-cards-by-x-axis-order))
     (send (send this get-layout) layout-cards this))

   (define/override (add-card-pre-layout)
     (send this set-cards (sort-cards-by-x-axis-order)))

;;    (define/override (drag-over on-region? cards)
;;      (debug "bucket%: drag-over: " on-region?))
   })