; AisleRiot - gaps.scm
; Copyright (C) 2005 Zach Keene <zjkeene@bellsouth.net>
;
; This program is free software: you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation, either version 3 of the License, or
; (at your option) any later version.
;
; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
; GNU General Public License for more details.
;
; You should have received a copy of the GNU General Public License
; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(define row1 '(0 1 2 3 4 5 6 7 8 9 10 11 12))
(define row2 '(13 14 15 16 17 18 19 20 21 22 23 24 25))
(define row3 '(26 27 28 29 30 31 32 33 34 35 36 37 38))
(define row4 '(39 40 41 42 43 44 45 46 47 48 49 50 51))
(def-save-var rows (vector row1 row2 row3 row4))

(define random-gaps #f)

(define (new-game)
  (initialize-playing-area)
  (make-standard-deck)
  (shuffle-deck)

  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-carriage-return-slot)

  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-carriage-return-slot)

  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-carriage-return-slot)

  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-normal-slot '() )
  (add-carriage-return-slot)

  (deal-cards-face-up-from-deck DECK (append row1 row2 row3 row4))
  (remove-aces (append row1 row2 row3 row4))

  (set! rows (vector row1 row2 row3 row4))
  (check-sequence 0)
  (check-sequence 13)
  (check-sequence 26)
  (check-sequence 39)

  (give-status-message)
  (list 13 4)
)

(define (give-status-message)
  (set-statusbar-message (string-append (_"Redeals left:") " "
                                        (number->string (- 2 FLIP-COUNTER))
                         )
  )
)

(define (remove-aces slot-list)
  (if (not (null? slot-list))
    (begin 
      (if (= (get-value(get-top-card (car slot-list))) ace)
          (remove-card (car slot-list))
      )
      (remove-aces (cdr slot-list))
    )
  )
)

(define (button-pressed slot-id card-list) 
  (define rowlist (vector-ref rows (quotient slot-id 13)))
  (member slot-id rowlist)
)

(define (button-released start-slot card-list end-slot)
  (and (droppable? start-slot card-list end-slot)
       (complete-transaction start-slot card-list end-slot)
  ) 
)

(define (droppable? start-slot card-list end-slot)
  (and (empty-slot? end-slot)
       (not (= start-slot end-slot))
       (or (and (= 0 (modulo end-slot 13)) 
                (= 2 (get-value(car card-list)))
           )
           (and (not (= end-slot 0))
                (not (empty-slot? (- end-slot 1)))
                (= (get-value(car card-list))
                   (+ (get-value(get-top-card (- end-slot 1))) 1)
                )
                (= (get-suit(car card-list))
                   (get-suit(get-top-card (- end-slot 1)))
                )
           )               
       )
  )
)

(define (complete-transaction start-slot card-list end-slot)
  (move-n-cards! start-slot end-slot card-list)
  (check-sequence end-slot)
)

(define (check-sequence slot)
  (define rowlist (vector-ref rows (quotient slot 13)))

  (if (and (not (empty-slot? (car rowlist)))
           (= (modulo (car rowlist) 13)
              (- (get-value(get-top-card (car rowlist))) 2)
           )
           (or (= (get-value(get-top-card (car rowlist))) 2)
               (= (get-suit(get-top-card (car rowlist))) 
                  (get-suit(get-top-card (- (car rowlist) 1)))
               )
           )
      )
      (begin 
        (vector-set! rows (quotient slot 13) (cdr rowlist))
        (add-to-score! 1)
        (check-sequence slot)
      )
  )
)

(define (redeal-needed? row blocked) 
  (for-each 
    (lambda (x) 
      (if (and (empty-slot? x)
               (not (= (modulo x 13) 0))
               (or (empty-slot? (- x 1))
                   (= (get-value(get-top-card(- x 1))) king)
               )               
          )
          (set! blocked (+ blocked 1))
      )
    )
    (vector-ref rows row)
  )
  (if (< row 3)
    (redeal-needed? (+ row 1) blocked)
    (= blocked 4)
  )
)

(define (button-clicked slot-id) #f)

(define (button-double-clicked slot-id)
  (if (and (redeal-needed? 0 0) (< FLIP-COUNTER 2))
    (collect-and-deal)
    #f
  )
)
      

(define (game-continuable)
  (give-status-message)
  (and (not (and (= FLIP-COUNTER 2) (redeal-needed? 0 0)))
       (not (game-won))
  )
)

(define (collect-and-deal)
  (define collection '())
  (set! FLIP-COUNTER (+ FLIP-COUNTER 1))
  (for-each
    (lambda (x)
      (if (not (empty-slot? x))
          (begin
            (set! collection (append (list (make-card 
                                             (get-value(get-top-card x))
                                             (get-suit(get-top-card x))
                                           )
                                      )
                                      collection
                              )
            )
            (remove-card x)
          )
      )
    )
    (append (vector-ref rows 0) (vector-ref rows 1) (vector-ref rows 2)
            (vector-ref rows 3)
    )
  )
  (set! DECK collection)
  (if random-gaps
    (for-each 
      (lambda (x)
        (set! DECK (append (list (make-card ace club)) DECK))
      )
      '(1 2 3 4)
    )
  )
  (shuffle-deck)
  (if random-gaps
    (begin
      (deal-cards-face-up-from-deck DECK (append (vector-ref rows 0)
                                                 (vector-ref rows 1)
                                                 (vector-ref rows 2)
                                                 (vector-ref rows 3)
                                         )
      )
      (remove-aces (append (vector-ref rows 0) (vector-ref rows 1)
                           (vector-ref rows 2) (vector-ref rows 3)
                   )
      )
    )   
    (deal-cards-face-up-from-deck DECK (append (cdr (vector-ref rows 0))
                                               (cdr (vector-ref rows 1))
                                               (cdr (vector-ref rows 2))
                                               (cdr (vector-ref rows 3))
                                       )
    )
  )
  #t
)

(define (game-won)
  (equal? rows (vector '(12) '(25) '(38) '(51)))
)

(define (get-hint)
  (if (redeal-needed? 0 0)
      (list 0 (_"Double click any card to redeal."))
      (or (add-to-sequence? 0)
          (playable-gap? (vector-ref rows 0))
          (playable-gap? (vector-ref rows 1))
          (playable-gap? (vector-ref rows 2))
          (playable-gap? (vector-ref rows 3))
          (list 0 (_"No hint available."))
      )
  )
)

(define (add-to-sequence? row)
  (if (empty-slot? (car (vector-ref rows row)))
      (if (= 0 (modulo (car (vector-ref rows row)) 13))
          (list 0 (format (_"Place a two in the leftmost slot of row ~a.")
			  (number->string (+ row 1))))
          (if (not (= 12 (modulo (car (vector-ref rows row)) 13)))
	      (list 0 (format (_"Add to the sequence in row ~a.")
			      (number->string (+ row 1))))
	      (if (< row 3)
		  (add-to-sequence? (+ row 1))
		  #f)))
      (if (< row 3)
          (add-to-sequence? (+ row 1))
          #f)))

(define (playable-gap? slotlist)
  (if (null? slotlist)
      #f
      (if (and (empty-slot? (car slotlist))
               (not (empty-slot? (- (car slotlist) 1)))
               (not (= king (get-value(get-top-card(- (car slotlist) 1)))))
	       )
	  (let ((target-card (get-top-card (- (car slotlist) 1))))
	    (list 0 (format
                     (_"Place the ~a next to ~a.")
		     (get-name (add-to-value target-card 1))
		     (get-name target-card))))
           (playable-gap? (cdr slotlist))
      )
  )
)

(define (get-options)
  (list (list (_"Randomly Placed Gaps on Redeal") random-gaps))
)

(define (apply-options options)
  (set! random-gaps (cadar options))
)

(define (timeout) #f)

(set-features droppable-feature)

(set-lambda new-game button-pressed button-released button-clicked 
            button-double-clicked game-continuable game-won get-hint 
            get-options apply-options timeout droppable?
)
