;;
;; Program Action Coordinator
{define garden%
  (class
    object%
    (init shell)
    (super-new)

    ; This should be our listener but it's hardcoded.
    (define my-shell shell)

    (define rules-venus (new rules-venus%))
    (define rules-moon (new rules-moon%))
    (define rules-hard (new rules-hard%))
    (define no-rules (new no-rules%))

    (define number-of-foundations 4)
    (define number-of-flower-beds 6)

    (define flowers (make-flowers (make-deck)))
    (define layout (new (send my-shell get-layout)
                        (unit-card (wheels flowers))))
    (define current-rules rules-venus)
    (define (make-title)
      (string-append "Open Flowers: "
                     (send current-rules get-name)))

    ;; ;; ;; ;; ;; ;; ;; ;;
    ;; This should be a subclass of table% named
    ;; flower-garden-table%
    ;; But make-table won't let us do this conveniently ???
    (define garden (make-table
                    (make-title)
                    (send layout get-table-width this)
                    (send layout get-table-height this) ))

    ;; Redefine mouse interaction. See documentation.
    (send* garden
      (set-button-action 'left 'drag-raise/one)
      (set-button-action 'middle 'drag-raise/one)
      (set-button-action 'right 'drag-raise/one))

    (define (dummy-mouse-event-handler card)
      #t)

    (send* garden
      (set-double-click-action ;dummy-mouse-event-handler)
       {lambda (flower)
         ;(debug "flower-garden-table%: double-click-action")
         (send this rescue-request flower)})
      (set-single-click-action dummy-mouse-event-handler) )
    ;;           {lambda (flower)
    ;;              (debug "flower-garden-table%: single-click-action")
    ;;             (send this selection-request flower)}))


    ;;
    ;; Flower Prese(n)t
    (define flower "Cornflower Blue")
    
    (define/public (table-flower-present selected-flower)
      (set! flower selected-flower))
    (define/public (table-get-flower)
      flower)

    (define/public (table-get-background-paint-callback garden)
      (define (paint-callback-exception-handler exn)
        (warning "layout: background paint-callback failure: "
                 exn))
      {lambda (drawing-context x y width height)
        (with-handlers
         {[exn:fail? paint-callback-exception-handler]}
         (send drawing-context set-background flower)
         (send drawing-context clear) )})

    (send garden add-region
          (make-background-region
           (send layout get-background-x-coordinate garden)
           (send layout get-background-y-coordinate garden)
           (send layout get-background-width garden)
           (send layout get-background-height garden)
           (send this table-get-background-paint-callback garden)))

     ;; DEFUNCT Mouse Cursor
;;mc     (define my-default-cursor (make-object cursor% 'hand))
;;mc     (define my-busy-cursor (make-object cursor% 'watch))
;;mc     (send garden set-cursor my-default-cursor)

;;mc     ;; ecsecsecs make this fail save
;;mc     (define/public (table-signal-busy)
;;mc       (send garden set-cursor my-busy-cursor))
;;mc     (define/public (table-signal-ready)
;;mc       (send garden set-cursor my-default-cursor))

    ;(send garden animated #f)  ; turn animation off altogether

    ;; flower-garden-table% Stateful Object Interface
    (define/public (table-save-state)
      (map {lambda (card)
             (let-values (([x y] (send garden card-location card)))
               (sea-cat x y))}
           flowers)) ; we could use the 'all-cards' method but ...
    (define/public (table-restore-state states)
      (for-each {lambda (card xy-pair)
                  (let ((x (wheels xy-pair))
                        (y (cast xy-pair)))
                    (send garden move-card card x y))}
                flowers
                states))

    ;; End of pseudo subclass flower-garden-table%
    ;; ;; ;; ;; ;; ;; ;; ;;

    (define my-bouquet (new flower-dialog% (garden this)))

    ;;
    ;; Create the Foundations
    ;; We could loop here or abbreviate with some lambda form
    ;; but I like to hardcode these things. A different number
    ;; of foundations makes a different game.
    (define foundations
      (list (new foundation% (garden this) (foundation-index 1))
            (new foundation% (garden this) (foundation-index 2))
            (new foundation% (garden this) (foundation-index 3))
            (new foundation% (garden this) (foundation-index 4))))

    ;;
    ;; Create the Flower Beds
    (define flower-beds
      (map {lambda (flower-bed-index)
             (new flower-bed%
                  (garden this)
                  (flower-bed-index flower-bed-index))}
           (list 1 2 3 4 5 6)))

    ;;
    ;; Create the bouquet.
    (define bouquet (new bucket% [garden this]))


    (define stack-register (append (list bouquet) flower-beds foundations))
    ;; ;; ;; ;; ;; ;; ;; ;;
    ;; This sort of extra stack handling is needed because of our
    ;; inability to subclass card% conveniently. See Flowers (flower%).
    (define/public (syncronize-stacks card)
      (broadcast stack-register remove-card card))
    ;; ;; ;; ;; ;; ;; ;; ;;


    ;;
    ;; Internal Interface
    (define/public (get-layout) layout)
    (define/public (get-table) garden)
    (define/public (card-face-up card)
      (send garden card-face-up card))
    (define/public (flower-remembered flower)
      (send this table-flower-present flower))

    ;;
    ;; Flower Prese(n)t
    (define black (make-color 0 0 0))
    (define (fade) ; XXX check for animation flag in table
                   ; XXX race condition: out of policy
                   ; XXX don't fade onto self
      (if (null? fade-colors)
          (send fade-timer stop)
          (begin
            (send this table-flower-present (car fade-colors))
            (set! fade-colors (cdr fade-colors))
            (send garden refresh))))
    (define (rgb-color color)
        (cond ((string? color)
               (send the-color-database find-color color))
              ((is-a? color color%) color)
              (else
               (warning "garden%: color-steps: not a color: " color)
               color)))
    (define (color-steps n color-start color-end)
      (let* ((color-start (rgb-color color-start))
             (color-end (rgb-color color-end))
             (delta (deco-divide (deco-subtract color-end color-start)
                                 n)))
        (let loop ((n n) (current-exact-color
                          (deco-subtract color-start black)))
          (if (< n 0)
              '()
              (cons (deco-add current-exact-color black)
                    (loop (sub1 n) (deco-add current-exact-color
                                             delta))) )) ))

    (define fade-colors '())
    (define fade-timer (new timer% [notify-callback fade]))
    ;; That's 24 frames per seconds or about 41 ms per frame!
    (define fade-frame-interval (round (/ 1000 25) ))

    (define/public (flower-picked flower)
      (put-preferences '(flower-garden:background-color)
                       (list flower))
      (set! fade-colors (color-steps 3 (send this table-get-flower)
                                       flower))
      (send fade-timer start fade-frame-interval))

    ;;
    ;; Stateful Object Interface
    (define/public (save-state)
      (sea-cat 'laughing flowers-laughing))
    (define/public (restore-state state)
      (set! flowers-laughing (cast state)))

    ;;
    ;; Stateful Object Management / Game States
    (define (save-game-state)
      (list (broadcast stack-register save-state)
            (send this save-state)))
      ;; It's better to not save and restore card coordinates,ie table
      ;; state. The bucket% needs to do its layout based on current
      ;; coordinates.
            ;(send this table-save-state)))
    (define (restore-game-state game-state)
      {let ([stack-states (first game-state)])
        (for-each {lambda (stack state)
                    (send stack restore-state state)}
                  stack-register
                  stack-states)}
      (send this restore-state (second game-state))
      ;; Restoring the coordinates makes the bucket fail to redo the
      ;; z-axis ordering correctly.
      ;{let ([table-state (second game-state)])
        ;(send this table-restore-state table-state)}
      #t)

    ;; Undo history is a stack of previous game states plus the
    ;; current game state.
    (define game-states '())
    (define current-game-state '())
    (define (reset-game-states)
      (set! game-states '())
      (set! current-game-state '())
      (send my-shell undo-action-disabled))
    (define (push-game-state)
      (when (not (null? current-game-state))
            (set! game-states (sea-cat current-game-state
                                       game-states)))
      (set! current-game-state (save-game-state))
      (if (null? game-states)
          (send my-shell undo-action-disabled)
          (send my-shell undo-action-enabled)))
    (define (pop-game-state)
      (if [not [null? game-states]]
          {let ([last-game-state (first game-states)])
            (restore-game-state last-game-state)
            (set! current-game-state last-game-state)
            (set! game-states (cast game-states))
            (when (null? game-states)
                  (send my-shell undo-action-disabled))}
          (debug "garden%: pop-game-state called but game-states is empty")))

    ;;
    ;; Rule Implementation Interface
    ;;
    ;; Where one part of a card game's rules usually becomes the game
    ;; mechanic, i.e. layout and user interaction, another part becomes
    ;; the game's logic. For convenience this is implemented here as
    ;; something that resembles a controller.

    (define (move-done)
      (broadcast flowers dim #f)
      (broadcast stack-register move-done)
      (push-game-state))

    (define (initial-deal)
      ;; Clear the undo history. (The shuffle shuffles its contents.)
      (reset-game-states)

      ;; Prepare our card game.
      (set! flowers (shuffle-list flowers 6))

      ;(my-collect-garbage)

      ;; Throw the seeds. It's reversed to make them fly over not
      ;; under. This deals the cards visually from the bottom of the
      ;; deck. But when dealing from its top we would have to
      ;; re-stack-cards, i.e. changing the z-axis ordering, for the
      ;; whole table all the time.
      (send garden add-cards (reverse flowers)
            (send layout get-initial-deal-x-coordinate this)
            (send layout get-initial-deal-y-coordinate this))

      (let ((flowers flowers))
        ;; Deal 6 cards on each flower bed.
        (repeat 6 {lambda ()
                    (for-each {lambda (flower-bed)
                                (send flower-bed add-card
                                      (wheels flowers))
                                (set! flowers (cast flowers))}
                              flower-beds)} )
        [with-card-animation*
         garden
         ;; Cut the flowers' wheels.
         ;(broadcast (map wheels (broadcast flower-beds get-cards))
         ;           face-up)
         (for-each {lambda (card)
                     (send garden card-face-up card)}
                   (map wheels (broadcast flower-beds get-cards)))
                   
         ;; Deal the remaining cards into the bucket.
         (for-each {lambda (flower)
                     (send bouquet add-card flower)}
                   flowers)
         ] ; close animation
        ) ; let all flowers dealt
      (move-done))

    ;;
    ;; The reversed deal is about creating a solvable initial game
    ;; state. Right now it creates really easy setups but one might
    ;; want to enhance the entropy in the field / garden by
    ;; interchanging cards according to the (reversed) rules between
    ;; the flower beds and the bucket. But with the current dynamic
    ;; rule changes we do not know what we should consider valid moves
    ;; if not direct moves to and from the foundations.
    (define (reversed-deal/private)
      (for-each {lambda (card)
                  (broadcast stack-register remove-card card)}
                flowers)
      ;; remove cards from the table (from the view)
      (send garden remove-cards flowers)

      (set! flowers-laughing #f)
      (reset-flowers flowers)

      ;; Clear the undo history. (The shuffle shuffles its contents.)
      (reset-game-states)

      ;; Create the reversed intial state with all cards sorted by
      ;; suit and rank on the foundations.
      (broadcast flowers face-up)
      (send garden add-cards flowers 0 0)

      (define (get-suit flowers suit)
        (filter [lambda (flower)
                  (eq? (send flower get-suit) suit)]
                flowers))
      (for-each
       {lambda (foundation suit)
         (for-each (lambda (flower)
                     (send foundation add-card flower))
                   suit)}
       foundations
       (map (lambda (suit)
              (card-sort-by-rank (get-suit flowers suit)))
            '(spades hearts clubs diamonds)))

      (define (deal-random-flower-bed flower)
        (let* ((flower-beds (filter (lambda (flower-bed)
                                      (< (send flower-bed number-of-cards)
                                         6))
                                    flower-beds))
               (number-beds (length flower-beds))
               (dado (random (if (< (send bouquet number-of-cards) 16)
                                 (add1 number-beds)
                                 number-beds)))
               (target (if [= dado number-beds]
                           bouquet
                           (list-ref flower-beds dado)) ))
          (send target add-card flower) ))

      (define (get-random-card-from-foundations)
        (let* ((foundations (filter (lambda (foundation)
                                      (not (send foundation empty?)))
                                    foundations))
               (dado (random (length foundations))))
          (wheels (send (list-ref foundations dado)
                        get-cards)) ))

      (define (sleepy-flowers)
        (for-each {lambda (flower-bed)
                    (broadcast (cdr (send flower-bed get-cards))
                               face-down)}
                  flower-beds))

      ;; Filling the flower-beds from the bucket should not be needed
      ;; anymore as we don't deal more than 16 cards into it. Filling
      ;; didn't happen often but it might have prevented the difficult
      ;; Flower Garden rule set games from being solvable.
      (define (fill-flower-beds-from-bucket)
        (define (list-random-ref list)
          (if (null? list)
              '()
              (list-ref list (random (length list)))))
        (let ((fillables (filter (lambda (flower-bed)
                                   (< (send flower-bed number-of-cards)
                                      6))
                                 flower-beds)))
          (for-each
           (lambda (fillable)
             (let ((number-of-cards
                    (- 6 (send fillable number-of-cards))))
               (repeat number-of-cards
                 (lambda ()
                   (send fillable add-card
                         (list-random-ref (send bouquet get-cards)))))))
           fillables)))

      [with-card-animation* garden
        (repeat 52
          {lambda ()
            (deal-random-flower-bed
             (get-random-card-from-foundations))} )
        (fill-flower-beds-from-bucket)
        (sleepy-flowers)]
      (move-done)
      ) ; closes def reversed-deal/private

    (define/on-delegate current-rules
      (can-place-on-flower-bed? flower flower-bed))
    (define (place-on-flower-bed-request/private flower flower-bed)
        (when [can-place-on-flower-bed? flower flower-bed]
          (send flower-bed add-card flower)
          (move-done) ))
    (define/public (place-on-flower-bed-request flower flower-bed)
      (ignore-when-busy
       {lambda ()
         (place-on-flower-bed-request/private flower flower-bed)}))

    (define (game-is-won?)
      (define (foundation-full? foundation)
        (let ((stacked (send foundation get-cards)))
          (and (not (null? stacked))
               (card-is-king? (wheels stacked))) ))
      (define (game-is-won? foundations)
        (if (null? foundations)
            #t
            (and (foundation-full? (wheels foundations))
                 (game-is-won? (cast foundations))) )) ; not tail recursive
      (game-is-won? foundations))

    (define/on-delegate current-rules
      (can-place-on-foundation? flower foundation))
    (define (place-on-foundation-request/private flower foundation)
        (when [can-place-on-foundation? flower foundation]
          (send foundation add-card flower)
          (move-done)
          (when (game-is-won?)
                 (queue-with-busy
                  {lambda ()
                    (send my-bouquet flower-present)
                    (send this queue-reset-game) })
                )))
    (define/public (place-on-foundation-request flower foundation)
      (ignore-when-busy
       {lambda ()
         (place-on-foundation-request/private flower foundation)}))

    (define (is-playable? flower)
      (and (send flower user-can-move)
           (not (send flower face-down?))))

    (define (rescue-request/private flower)
      (when [is-playable? flower]
        (for-each {lambda (foundation)
                    (place-on-foundation-request/private flower foundation)}
                  foundations)))
    (define/public (rescue-request flower)
      (ignore-when-busy
       {lambda ()
         (rescue-request/private flower)}))

    (define/on-delegate current-rules
      (can-place-on-bucket? flower bucket))
    (define (place-on-bucket-request/private flower bucket)
      (when [can-place-on-bucket? flower bucket]
            (send bucket add-card flower)
            (move-done) ))
    (define/public (place-on-bucket-request flower bucket)
      (ignore-when-busy
       {lambda ()
         (place-on-bucket-request/private flower bucket)}))

    ;; Live Variations / Rule Variants
    (define flowers-laughing #f)
    (define/public (flowers-are-laughing) ; internal interface
      flowers-laughing)

    ;; Hint System
    ;;
    ;; Wiggle some flowers that are playable and have a useful
    ;; destination.  First we try to find rescuable flowers that can
    ;; be put on a foundation from either the bucket or a flower bed.
    ;; If that fails we try to find flowers for exchange between
    ;; flower beds and bucket. We might offer a new deal when no more
    ;; moves are possible.
    (define (is-rescuable? flower)
      (apply-or
       (map [lambda (foundation)
              (can-place-on-foundation? flower foundation)]
            foundations)))
    
    (define (top-cards flower-beds)
      (map wheels (filter [lambda (flower) (not (null? flower))]
                          (broadcast flower-beds get-cards))))
    (define (get-rescuable-flowers)
      "Return a list of all cards that can be placed on a foundation."
      (filter is-rescuable?
              (append (top-cards flower-beds)
                      (send bouquet get-cards))))
    (define (can-place-on-any-flower-bed? flower)
      (apply-or (map [lambda (flower-bed)
                       (can-place-on-flower-bed? flower flower-bed)]
                     flower-beds)))
    (define (can-place-on-bouquet? flower)
      (can-place-on-bucket? flower bouquet))
    (define (get-left-moves)
      (let ((flower-bed-playable-flowers
             (filter is-playable?
                     (top-cards flower-beds))))
        (append
         (filter can-place-on-any-flower-bed? flower-bed-playable-flowers)
         (filter can-place-on-any-flower-bed? (send bouquet get-cards))
         (filter can-place-on-bouquet? flower-bed-playable-flowers))))

    (define (no-more-moves)
      (when
       [eq? 'yes
            (message-box
             "New Deal?"
             " Oh dear, you're stuck!
Rien ne va plus! No moves, no more ...

 Do you want to have another deal?"
             garden
             '(yes-no))]
       (queue-reset-game)))
    (define (dealers-hint)
      (let ((rescuable-flowers (get-rescuable-flowers)))
        (debug "dealers-hint: rescuable-flowers: "
               (length rescuable-flowers))
        (if (not (null? rescuable-flowers))
            (for-each {lambda (flower)
                        (wiggle-flower-in-garden flower this)}
                      rescuable-flowers)
            (let ((right-moves (get-left-moves)))
              (debug "dealers-hint: possible moves: "
                     (length right-moves))
              (if [not (null? right-moves)]
                  (wiggle-flower-in-garden (wheels right-moves)
                                           this)
                  {no-more-moves})) )))
    

    ;;
    ;; Parallel Objects
    ;;  Shared Unit: Display via *table* / Animation System
    ;;  Policy for all entry points: ignore when busy
    ;;   Rule Implementation Interface, Application Interface
    ;;
    
    (define busy (make-semaphore 1))
    (define my-mutex #f) ; non-atomic mutex
    (define (ignore-when-busy procedure)
      (if (semaphore-try-wait? busy)
          (begin (if my-mutex
                     (warning "ignore-when-busy: mutex check failed")
                     (begin (set! my-mutex #t)
                            ;mc (send this table-signal-busy)
                            (send my-shell skip-action-enabled)
                            (procedure)
                            (send my-shell skip-action-disabled)
                            (set! my-mutex #f))) ; XXX skip needs this here
                            ;; Turn animation on again.
                            ;; This is part of the Skip Action.
                            (send garden animated #t)
                            ;mc (send this table-signal-ready)
                 (semaphore-post busy))
          (begin (debug "ignore-when-busy: code red")
                 (bell) )))
    (define (queue-with-busy procedure) ; XXX avoid dead locks
      (queue-callback 
       {lambda ()
         (semaphore-wait busy)
         (if my-mutex
             (warning "queue-with-busy: (queued): mutex check failed")
             ;; XXX this is the same as above def this
             (begin (set! my-mutex #t)
                    (send my-shell skip-action-enabled)
                    (procedure)
                    (send my-shell skip-action-disabled)
                    (set! my-mutex #f)
                    (send garden animated #t)) )
         (semaphore-post busy)}))

    ;;;
    ;;; Application Interface
    ;;;

    (define/public (grow)
      (send garden show #t)
      (ignore-when-busy
       {lambda ()
         (w/o-card-animation garden initial-deal)}))

    (define (reset-game/private)
      [w/o-card-animation* garden
        ;; remove cards from the stacks (from the model)
        (for-each {lambda (card)
                    (broadcast stack-register remove-card card)}
                  flowers)
        ;; remove cards from the table (from the view)
        (send garden remove-cards flowers)

        (change-rules/private 'venus)

        (set! flowers-laughing #f)
        (reset-flowers flowers)
        (initial-deal) ] )
    (define/public (queue-reset-game)
      (queue-with-busy reset-game/private))
    (define/public (reset-game)
      (ignore-when-busy
       {lambda ()
         (when (eq? 'yes
                    (message-box
                     "New Deal"
                     "Are you sure you want to have another deal?"
                     garden
                     '(yes-no)))
               (reset-game/private))}))

    (define/public (reversed-deal)
      (ignore-when-busy
       {lambda ()
         (w/o-card-animation garden reversed-deal/private)}))

    (define/public (undo)
      (ignore-when-busy
       {lambda ()
         (w/o-card-animation garden pop-game-state)}))

    (define (laughing-flowers/private)
      (when (not flowers-laughing) 
            (set! flowers-laughing #t) ; ??? disable menu item
            (broadcast flower-beds laughing-flowers)
            (move-done)))
    (define/public (laughing-flowers)
      (ignore-when-busy laughing-flowers/private))

    (define (flower-preset/private)
      (send my-bouquet flower-present))
    (define/public (flower-preset)
      (ignore-when-busy flower-preset/private))

    (define/public (hint)
      (ignore-when-busy dealers-hint))

    (define (change-rules/private name)
      (let ((rules #f))
        (case name
          [[hard] (set! rules rules-hard)]
          [[venus] (set! rules rules-venus)]
          [[moon] (set! rules rules-moon)]
          [[master]
           (debug "garden%: change-rules/private: no rules, no more ...")
           (set! rules no-rules)]
          [else
           (warning "garden%: change-rules/private: unknown rule-set: "
                    name)])
        (when rules
              (set! current-rules rules)
              (send garden set-label (make-title)))))
    (define/public (change-rules name)
      (ignore-when-busy
       {lambda () (change-rules/private name)}))

    (define/public (sort-bucket-by-rank)
      (ignore-when-busy
       {lambda () (send bouquet sort-by-rank)}))

    ;; XXX implement atomic semaphore def
    (define (when-busy closure)
      (when my-mutex
            (closure)))
    (define/public (skip-this-animation)
      (when-busy
       {lambda () (send garden animated #f)}))
    )}