home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / gnome-games / aisleriot / games / gaps.scm < prev    next >
Encoding:
Text File  |  2009-04-14  |  9.2 KB  |  337 lines

  1. ; AisleRiot - gaps.scm
  2. ; Copyright (C) 2005 Zach Keene <zjkeene@bellsouth.net>
  3. ;
  4. ; This game is free software; you can redistribute it and/or modify
  5. ; it under the terms of the GNU General Public License as published by
  6. ; the Free Software Foundation; either version 2, or (at your option)
  7. ; any later version.
  8. ;
  9. ; This program is distributed in the hope that it will be useful,
  10. ; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ; GNU General Public License for more details.
  13. ;
  14. ; You should have received a copy of the GNU General Public License
  15. ; along with this program; if not, write to the Free Software
  16. ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
  17. ; USA
  18.  
  19. (define row1 '(0 1 2 3 4 5 6 7 8 9 10 11 12))
  20. (define row2 '(13 14 15 16 17 18 19 20 21 22 23 24 25))
  21. (define row3 '(26 27 28 29 30 31 32 33 34 35 36 37 38))
  22. (define row4 '(39 40 41 42 43 44 45 46 47 48 49 50 51))
  23. (def-save-var rows (vector row1 row2 row3 row4))
  24.  
  25. (define random-gaps #f)
  26.  
  27. (define (new-game)
  28.   (initialize-playing-area)
  29.   (make-standard-deck)
  30.   (shuffle-deck)
  31.  
  32.   (add-normal-slot '() )
  33.   (add-normal-slot '() )
  34.   (add-normal-slot '() )
  35.   (add-normal-slot '() )
  36.   (add-normal-slot '() )
  37.   (add-normal-slot '() )
  38.   (add-normal-slot '() )
  39.   (add-normal-slot '() )
  40.   (add-normal-slot '() )
  41.   (add-normal-slot '() )
  42.   (add-normal-slot '() )
  43.   (add-normal-slot '() )
  44.   (add-normal-slot '() )
  45.   (add-carriage-return-slot)
  46.  
  47.   (add-normal-slot '() )
  48.   (add-normal-slot '() )
  49.   (add-normal-slot '() )
  50.   (add-normal-slot '() )
  51.   (add-normal-slot '() )
  52.   (add-normal-slot '() )
  53.   (add-normal-slot '() )
  54.   (add-normal-slot '() )
  55.   (add-normal-slot '() )
  56.   (add-normal-slot '() )
  57.   (add-normal-slot '() )
  58.   (add-normal-slot '() )
  59.   (add-normal-slot '() )
  60.   (add-carriage-return-slot)
  61.  
  62.   (add-normal-slot '() )
  63.   (add-normal-slot '() )
  64.   (add-normal-slot '() )
  65.   (add-normal-slot '() )
  66.   (add-normal-slot '() )
  67.   (add-normal-slot '() )
  68.   (add-normal-slot '() )
  69.   (add-normal-slot '() )
  70.   (add-normal-slot '() )
  71.   (add-normal-slot '() )
  72.   (add-normal-slot '() )
  73.   (add-normal-slot '() )
  74.   (add-normal-slot '() )
  75.   (add-carriage-return-slot)
  76.  
  77.   (add-normal-slot '() )
  78.   (add-normal-slot '() )
  79.   (add-normal-slot '() )
  80.   (add-normal-slot '() )
  81.   (add-normal-slot '() )
  82.   (add-normal-slot '() )
  83.   (add-normal-slot '() )
  84.   (add-normal-slot '() )
  85.   (add-normal-slot '() )
  86.   (add-normal-slot '() )
  87.   (add-normal-slot '() )
  88.   (add-normal-slot '() )
  89.   (add-normal-slot '() )
  90.   (add-carriage-return-slot)
  91.  
  92.   (deal-cards-face-up-from-deck DECK (append row1 row2 row3 row4))
  93.   (remove-aces (append row1 row2 row3 row4))
  94.  
  95.   (set! rows (vector row1 row2 row3 row4))
  96.   (check-sequence 0)
  97.   (check-sequence 13)
  98.   (check-sequence 26)
  99.   (check-sequence 39)
  100.  
  101.   (give-status-message)
  102.   (list 13 4)
  103. )
  104.  
  105. (define (give-status-message)
  106.   (set-statusbar-message (string-append (_"Redeals left:") " "
  107.                                         (number->string (- 2 FLIP-COUNTER))
  108.                          )
  109.   )
  110. )
  111.  
  112. (define (remove-aces slot-list)
  113.   (if (not (null? slot-list))
  114.     (begin 
  115.       (if (= (get-value(get-top-card (car slot-list))) ace)
  116.           (remove-card (car slot-list))
  117.       )
  118.       (remove-aces (cdr slot-list))
  119.     )
  120.   )
  121. )
  122.  
  123. (define (button-pressed slot-id card-list) 
  124.   (define rowlist (vector-ref rows (quotient slot-id 13)))
  125.   (member slot-id rowlist)
  126. )
  127.  
  128. (define (button-released start-slot card-list end-slot)
  129.   (and (droppable? start-slot card-list end-slot)
  130.        (complete-transaction start-slot card-list end-slot)
  131.   ) 
  132. )
  133.  
  134. (define (droppable? start-slot card-list end-slot)
  135.   (and (empty-slot? end-slot)
  136.        (not (= start-slot end-slot))
  137.        (or (and (= 0 (modulo end-slot 13)) 
  138.                 (= 2 (get-value(car card-list)))
  139.            )
  140.            (and (not (= end-slot 0))
  141.                 (not (empty-slot? (- end-slot 1)))
  142.                 (= (get-value(car card-list))
  143.                    (+ (get-value(get-top-card (- end-slot 1))) 1)
  144.                 )
  145.                 (= (get-suit(car card-list))
  146.                    (get-suit(get-top-card (- end-slot 1)))
  147.                 )
  148.            )               
  149.        )
  150.   )
  151. )
  152.  
  153. (define (complete-transaction start-slot card-list end-slot)
  154.   (move-n-cards! start-slot end-slot card-list)
  155.   (check-sequence end-slot)
  156. )
  157.  
  158. (define (check-sequence slot)
  159.   (define rowlist (vector-ref rows (quotient slot 13)))
  160.  
  161.   (if (and (not (empty-slot? (car rowlist)))
  162.            (= (modulo (car rowlist) 13)
  163.               (- (get-value(get-top-card (car rowlist))) 2)
  164.            )
  165.            (or (= (get-value(get-top-card (car rowlist))) 2)
  166.                (= (get-suit(get-top-card (car rowlist))) 
  167.                   (get-suit(get-top-card (- (car rowlist) 1)))
  168.                )
  169.            )
  170.       )
  171.       (begin 
  172.         (vector-set! rows (quotient slot 13) (cdr rowlist))
  173.         (add-to-score! 1)
  174.         (check-sequence slot)
  175.       )
  176.   )
  177. )
  178.  
  179. (define (redeal-needed? row blocked) 
  180.   (for-each 
  181.     (lambda (x) 
  182.       (if (and (empty-slot? x)
  183.                (not (= (modulo x 13) 0))
  184.                (or (empty-slot? (- x 1))
  185.                    (= (get-value(get-top-card(- x 1))) king)
  186.                )               
  187.           )
  188.           (set! blocked (+ blocked 1))
  189.       )
  190.     )
  191.     (vector-ref rows row)
  192.   )
  193.   (if (< row 3)
  194.     (redeal-needed? (+ row 1) blocked)
  195.     (= blocked 4)
  196.   )
  197. )
  198.  
  199. (define (button-clicked slot-id) #f)
  200.  
  201. (define (button-double-clicked slot-id)
  202.   (if (and (redeal-needed? 0 0) (< FLIP-COUNTER 2))
  203.     (collect-and-deal)
  204.     #f
  205.   )
  206. )
  207.       
  208.  
  209. (define (game-continuable)
  210.   (give-status-message)
  211.   (and (not (and (= FLIP-COUNTER 2) (redeal-needed? 0 0)))
  212.        (not (game-won))
  213.   )
  214. )
  215.  
  216. (define (collect-and-deal)
  217.   (define collection '())
  218.   (set! FLIP-COUNTER (+ FLIP-COUNTER 1))
  219.   (for-each
  220.     (lambda (x)
  221.       (if (not (empty-slot? x))
  222.           (begin
  223.             (set! collection (append (list (make-card 
  224.                                              (get-value(get-top-card x))
  225.                                              (get-suit(get-top-card x))
  226.                                            )
  227.                                       )
  228.                                       collection
  229.                               )
  230.             )
  231.             (remove-card x)
  232.           )
  233.       )
  234.     )
  235.     (append (vector-ref rows 0) (vector-ref rows 1) (vector-ref rows 2)
  236.             (vector-ref rows 3)
  237.     )
  238.   )
  239.   (set! DECK collection)
  240.   (if random-gaps
  241.     (for-each 
  242.       (lambda (x)
  243.         (set! DECK (append (list (make-card ace club)) DECK))
  244.       )
  245.       '(1 2 3 4)
  246.     )
  247.   )
  248.   (shuffle-deck)
  249.   (if random-gaps
  250.     (begin
  251.       (deal-cards-face-up-from-deck DECK (append (vector-ref rows 0)
  252.                                                  (vector-ref rows 1)
  253.                                                  (vector-ref rows 2)
  254.                                                  (vector-ref rows 3)
  255.                                          )
  256.       )
  257.       (remove-aces (append (vector-ref rows 0) (vector-ref rows 1)
  258.                            (vector-ref rows 2) (vector-ref rows 3)
  259.                    )
  260.       )
  261.     )   
  262.     (deal-cards-face-up-from-deck DECK (append (cdr (vector-ref rows 0))
  263.                                                (cdr (vector-ref rows 1))
  264.                                                (cdr (vector-ref rows 2))
  265.                                                (cdr (vector-ref rows 3))
  266.                                        )
  267.     )
  268.   )
  269.   #t
  270. )
  271.  
  272. (define (game-won)
  273.   (equal? rows (vector '(12) '(25) '(38) '(51)))
  274. )
  275.  
  276. (define (get-hint)
  277.   (if (redeal-needed? 0 0)
  278.       (list 0 (_"Double click any card to redeal."))
  279.       (or (add-to-sequence? 0)
  280.           (playable-gap? (vector-ref rows 0))
  281.           (playable-gap? (vector-ref rows 1))
  282.           (playable-gap? (vector-ref rows 2))
  283.           (playable-gap? (vector-ref rows 3))
  284.           (list 0 (_"No hint available."))
  285.       )
  286.   )
  287. )
  288.  
  289. (define (add-to-sequence? row)
  290.   (if (empty-slot? (car (vector-ref rows row)))
  291.       (if (= 0 (modulo (car (vector-ref rows row)) 13))
  292.           (list 0 (format (_"Place a two in the leftmost slot of row ~a.")
  293.               (number->string (+ row 1))))
  294.           (if (not (= 12 (modulo (car (vector-ref rows row)) 13)))
  295.           (list 0 (format (_"Add to the sequence in row ~a.")
  296.                   (number->string (+ row 1))))
  297.           (if (< row 3)
  298.           (add-to-sequence? (+ row 1))
  299.           #f)))
  300.       (if (< row 3)
  301.           (add-to-sequence? (+ row 1))
  302.           #f)))
  303.  
  304. (define (playable-gap? slotlist)
  305.   (if (null? slotlist)
  306.       #f
  307.       (if (and (empty-slot? (car slotlist))
  308.                (not (empty-slot? (- (car slotlist) 1)))
  309.                (not (= king (get-value(get-top-card(- (car slotlist) 1)))))
  310.            )
  311.       (let ((target-card (get-top-card (- (car slotlist) 1))))
  312.         (list 0 (format
  313.                      (_"Place the ~a next to ~a.")
  314.              (get-name (add-to-value target-card 1))
  315.              (get-name target-card))))
  316.            (playable-gap? (cdr slotlist))
  317.       )
  318.   )
  319. )
  320.  
  321. (define (get-options)
  322.   (list (list (_"Randomly Placed Gaps on Redeal") random-gaps))
  323. )
  324.  
  325. (define (apply-options options)
  326.   (set! random-gaps (cadar options))
  327. )
  328.  
  329. (define (timeout) #f)
  330.  
  331. (set-features droppable-feature)
  332.  
  333. (set-lambda new-game button-pressed button-released button-clicked 
  334.             button-double-clicked game-continuable game-won get-hint 
  335.             get-options apply-options timeout droppable?
  336. )
  337.