home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / gaps.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  9.0 KB  |  329 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 (empty-slot? end-slot)
  130.        (or (and (= 0 (modulo end-slot 13)) 
  131.                 (= 2 (get-value(car card-list)))
  132.            )
  133.            (and (not (= end-slot 0))
  134.                 (not (empty-slot? (- end-slot 1)))
  135.                 (= (get-value(car card-list))
  136.                    (+ (get-value(get-top-card (- end-slot 1))) 1)
  137.                 )
  138.                 (= (get-suit(car card-list))
  139.                    (get-suit(get-top-card (- end-slot 1)))
  140.                 )
  141.            )               
  142.        )
  143.        (complete-transaction start-slot card-list end-slot)
  144.   ) 
  145. )
  146.  
  147. (define (complete-transaction start-slot card-list end-slot)
  148.   (move-n-cards! start-slot end-slot card-list)
  149.   (check-sequence end-slot)
  150. )
  151.  
  152. (define (check-sequence slot)
  153.   (define rowlist (vector-ref rows (quotient slot 13)))
  154.  
  155.   (if (and (not (empty-slot? (car rowlist)))
  156.            (= (modulo (car rowlist) 13)
  157.               (- (get-value(get-top-card (car rowlist))) 2)
  158.            )
  159.            (or (= (get-value(get-top-card (car rowlist))) 2)
  160.                (= (get-suit(get-top-card (car rowlist))) 
  161.                   (get-suit(get-top-card (- (car rowlist) 1)))
  162.                )
  163.            )
  164.       )
  165.       (begin 
  166.         (vector-set! rows (quotient slot 13) (cdr rowlist))
  167.         (add-to-score! 1)
  168.         (check-sequence slot)
  169.       )
  170.   )
  171. )
  172.  
  173. (define (redeal-needed? row blocked) 
  174.   (for-each 
  175.     (lambda (x) 
  176.       (if (and (empty-slot? x)
  177.                (not (= (modulo x 13) 0))
  178.                (or (empty-slot? (- x 1))
  179.                    (= (get-value(get-top-card(- x 1))) king)
  180.                )               
  181.           )
  182.           (set! blocked (+ blocked 1))
  183.       )
  184.     )
  185.     (vector-ref rows row)
  186.   )
  187.   (if (< row 3)
  188.     (redeal-needed? (+ row 1) blocked)
  189.     (= blocked 4)
  190.   )
  191. )
  192.  
  193. (define (button-clicked slot-id) #f)
  194.  
  195. (define (button-double-clicked slot-id)
  196.   (if (and (redeal-needed? 0 0) (< FLIP-COUNTER 2))
  197.     (collect-and-deal)
  198.     #f
  199.   )
  200. )
  201.       
  202.  
  203. (define (game-continuable)
  204.   (give-status-message)
  205.   (and (not (and (= FLIP-COUNTER 2) (redeal-needed? 0 0)))
  206.        (not (game-won))
  207.   )
  208. )
  209.  
  210. (define (collect-and-deal)
  211.   (define collection '())
  212.   (set! FLIP-COUNTER (+ FLIP-COUNTER 1))
  213.   (for-each
  214.     (lambda (x)
  215.       (if (not (empty-slot? x))
  216.           (begin
  217.             (set! collection (append (list (make-card 
  218.                                              (get-value(get-top-card x))
  219.                                              (get-suit(get-top-card x))
  220.                                            )
  221.                                       )
  222.                                       collection
  223.                               )
  224.             )
  225.             (remove-card x)
  226.           )
  227.       )
  228.     )
  229.     (append (vector-ref rows 0) (vector-ref rows 1) (vector-ref rows 2)
  230.             (vector-ref rows 3)
  231.     )
  232.   )
  233.   (set! DECK collection)
  234.   (if random-gaps
  235.     (for-each 
  236.       (lambda (x)
  237.         (set! DECK (append (list (make-card ace club)) DECK))
  238.       )
  239.       '(1 2 3 4)
  240.     )
  241.   )
  242.   (shuffle-deck)
  243.   (if random-gaps
  244.     (begin
  245.       (deal-cards-face-up-from-deck DECK (append (vector-ref rows 0)
  246.                                                  (vector-ref rows 1)
  247.                                                  (vector-ref rows 2)
  248.                                                  (vector-ref rows 3)
  249.                                          )
  250.       )
  251.       (remove-aces (append (vector-ref rows 0) (vector-ref rows 1)
  252.                            (vector-ref rows 2) (vector-ref rows 3)
  253.                    )
  254.       )
  255.     )   
  256.     (deal-cards-face-up-from-deck DECK (append (cdr (vector-ref rows 0))
  257.                                                (cdr (vector-ref rows 1))
  258.                                                (cdr (vector-ref rows 2))
  259.                                                (cdr (vector-ref rows 3))
  260.                                        )
  261.     )
  262.   )
  263.   #t
  264. )
  265.  
  266. (define (game-won)
  267.   (equal? rows (vector '(12) '(25) '(38) '(51)))
  268. )
  269.  
  270. (define (get-hint)
  271.   (if (redeal-needed? 0 0)
  272.       (list 0 (_"Double click any card to redeal."))
  273.       (or (add-to-sequence? 0)
  274.           (playable-gap? (vector-ref rows 0))
  275.           (playable-gap? (vector-ref rows 1))
  276.           (playable-gap? (vector-ref rows 2))
  277.           (playable-gap? (vector-ref rows 3))
  278.           (list 0 (_"No hint available."))
  279.       )
  280.   )
  281. )
  282.  
  283. (define (add-to-sequence? row)
  284.   (if (empty-slot? (car (vector-ref rows row)))
  285.       (if (= 0 (modulo (car (vector-ref rows row)) 13))
  286.           (list 0 (format (_ "Place a two in the leftmost slot of row ~a.")
  287.               (number->string (+ row 1))))
  288.           (if (not (= 12 (modulo (car (vector-ref rows row)) 13)))
  289.           (list 0 (format (_ "Add to the sequence in row ~a.")
  290.                   (number->string (+ row 1))))
  291.           (if (< row 3)
  292.           (add-to-sequence? (+ row 1))
  293.           #f)))
  294.       (if (< row 3)
  295.           (add-to-sequence? (+ row 1))
  296.           #f)))
  297.  
  298. (define (playable-gap? slotlist)
  299.   (if (null? slotlist)
  300.       #f
  301.       (if (and (empty-slot? (car slotlist))
  302.                (not (empty-slot? (- (car slotlist) 1)))
  303.                (not (= king (get-value(get-top-card(- (car slotlist) 1)))))
  304.            )
  305.       (let ((target-card (get-top-card (- (car slotlist) 1))))
  306.         (list 0 (format
  307.                      (_ "Place the ~a next to ~a.")
  308.              (get-name (add-to-value target-card 1))
  309.              (get-name target-card))))
  310.            (playable-gap? (cdr slotlist))
  311.       )
  312.   )
  313. )
  314.  
  315. (define (get-options)
  316.   (list (list (_"Randomly Placed Gaps on Redeal") random-gaps))
  317. )
  318.  
  319. (define (apply-options options)
  320.   (set! random-gaps (cadar options))
  321. )
  322.  
  323. (define (timeout) #f)
  324.  
  325. (set-lambda new-game button-pressed button-released button-clicked 
  326.             button-double-clicked game-continuable game-won get-hint 
  327.             get-options apply-options timeout
  328. )
  329.