home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / triple_peaks.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  9.3 KB  |  358 lines
  1. ; AisleRiot - triple_peaks.scm
  2. ; Copyright (C) 2005 Richard Hoelscher <rah@rahga.com>
  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 progressive-rounds #f)
  20. (define multiplier-scoring #f)
  21.  
  22. (define (new-game)
  23.   (initialize-playing-area)  
  24.   (set-ace-low)
  25.   (make-standard-deck)
  26.   (shuffle-deck)
  27.  
  28.   (add-normal-slot DECK)
  29.   (add-normal-slot '())
  30.   (set! HORIZPOS 1)
  31.   (add-extended-slot '() right)
  32.   
  33.   (add-carriage-return-slot)
  34.   (add-blank-slot)
  35.   (add-blank-slot)
  36.   (add-normal-slot '())
  37.   (add-blank-slot)
  38.   (add-blank-slot)
  39.   (add-normal-slot '())
  40.   (add-blank-slot)
  41.   (add-blank-slot)
  42.   (add-normal-slot '())
  43.  
  44.   (add-carriage-return-slot)
  45.   (set! VERTPOS (- VERTPOS (/ 2 3)))
  46.   (set! HORIZPOS (+ HORIZPOS 0.5))
  47.   (add-blank-slot)
  48.   (add-normal-slot '())
  49.   (add-normal-slot '())
  50.   (add-blank-slot)
  51.   (add-normal-slot '())
  52.   (add-normal-slot '())
  53.   (add-blank-slot)
  54.   (add-normal-slot '())
  55.   (add-normal-slot '())
  56.  
  57.   (add-carriage-return-slot)
  58.   (set! VERTPOS (- VERTPOS (/ 2 3)))
  59.   (add-blank-slot)
  60.   (add-normal-slot '())
  61.   (add-normal-slot '())
  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.  
  70.   (add-carriage-return-slot)
  71.   (set! VERTPOS (- VERTPOS (/ 2 3)))
  72.   (set! HORIZPOS (+ HORIZPOS 0.5))
  73.   (add-normal-slot '())
  74.   (add-normal-slot '())
  75.   (add-normal-slot '())
  76.   (add-normal-slot '())
  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.  
  84.   (deal-cards 0 ' (3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20))
  85.   (deal-cards-face-up 0 ' (21 22 23 24 25 26 27 28 29 30 2))
  86.  
  87.   (give-status-message)
  88.  
  89.   (list 11 3))
  90.  
  91. (define (progressive-redeal)
  92.   (flip-deck 1 2)
  93.   (add-cards! 0 (get-cards 1))
  94.   (remove-n-cards 1 (length (get-cards 1)))
  95.   (shuffle-deck)
  96.   (deal-cards 0 ' (3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20))
  97.   (deal-cards-face-up 0 ' (21 22 23 24 25 26 27 28 29 30 2))
  98. )
  99.  
  100. (define (give-status-message)
  101.   (set-statusbar-message (get-stock-no-string)))
  102.  
  103. (define (get-stock-no-string)
  104.   (string-append (_"Stock left:") " " 
  105.          (number->string (length (get-cards 0)))))
  106.  
  107. (define (button-pressed slot-id card-list)
  108.   (available? slot-id))
  109.  
  110. (define (check-for-flips slot-id)
  111.   (cond ((= slot-id 30)
  112.          (if (empty-slot? 29)
  113.              (flip-top-card 20)
  114.              ))
  115.         ((= slot-id 29)
  116.          (begin
  117.            (if (empty-slot? 30)
  118.                (flip-top-card 20)
  119.                )
  120.            (if (empty-slot? 28)
  121.                (flip-top-card 19)
  122.                )))  
  123.         ((= slot-id 28)
  124.          (begin
  125.            (if (empty-slot? 29)
  126.                (flip-top-card 19)
  127.                )
  128.            (if (empty-slot? 27)
  129.                (flip-top-card 18)
  130.                )))
  131.         ((= slot-id 27)
  132.          (begin
  133.            (if (empty-slot? 28)
  134.                (flip-top-card 18)
  135.                )
  136.            (if (empty-slot? 26)
  137.                (flip-top-card 17)
  138.                )))
  139.         ((= slot-id 26)
  140.          (begin
  141.            (if (empty-slot? 27)
  142.                (flip-top-card 17)
  143.                )
  144.            (if (empty-slot? 25)
  145.                (flip-top-card 16)
  146.                )))
  147.         ((= slot-id 25)
  148.          (begin
  149.            (if (empty-slot? 26)
  150.                (flip-top-card 16)
  151.                )
  152.            (if (empty-slot? 24)
  153.                (flip-top-card 15)
  154.                )))
  155.         ((= slot-id 24)
  156.          (begin
  157.            (if (empty-slot? 25)
  158.                (flip-top-card 15)
  159.                )
  160.            (if (empty-slot? 23)
  161.                (flip-top-card 14)
  162.                )))
  163.         ((= slot-id 23)
  164.          (begin
  165.            (if (empty-slot? 24)
  166.                (flip-top-card 14)
  167.                )
  168.            (if (empty-slot? 22)
  169.                (flip-top-card 13)
  170.                )))
  171.         ((= slot-id 22)
  172.          (begin
  173.            (if (empty-slot? 23)
  174.                (flip-top-card 13)
  175.                )
  176.            (if (empty-slot? 21)
  177.                (flip-top-card 12)
  178.                )))
  179.         ((= slot-id 21)
  180.          (if (empty-slot? 22)
  181.              (flip-top-card 12)
  182.              ))
  183.  
  184.         ((= slot-id 20)
  185.          (if (empty-slot? 19)
  186.              (flip-top-card 11)
  187.              ))
  188.     ((= slot-id 19)
  189.          (begin
  190.            (if (empty-slot? 20)
  191.                (flip-top-card 11)
  192.                )
  193.            (if (empty-slot? 18)
  194.                (flip-top-card 10)
  195.                )))
  196.         ((= slot-id 18)
  197.          (if (empty-slot? 19)
  198.              (flip-top-card 10)
  199.              ))
  200.         ((= slot-id 17)
  201.          (if (empty-slot? 16)
  202.              (flip-top-card 9)
  203.              ))
  204.         ((= slot-id 16)
  205.          (begin
  206.            (if (empty-slot? 17)
  207.                (flip-top-card 9)
  208.                )
  209.            (if (empty-slot? 15)
  210.                (flip-top-card 8)
  211.                )))
  212.         ((= slot-id 15)
  213.          (if (empty-slot? 16)
  214.              (flip-top-card 8)
  215.              ))
  216.         ((= slot-id 14)
  217.          (if (empty-slot? 13)
  218.              (flip-top-card 7)
  219.              ))
  220.         ((= slot-id 13)
  221.          (begin
  222.            (if (empty-slot? 14)
  223.                (flip-top-card 7)
  224.                )
  225.            (if (empty-slot? 12)
  226.                (flip-top-card 6)
  227.                )))
  228.         ((= slot-id 12)
  229.          (if (empty-slot? 13)
  230.              (flip-top-card 6)
  231.              ))
  232.         ((= slot-id 11)
  233.          (if (empty-slot? 10)
  234.              (flip-top-card 5)
  235.              ))
  236.         ((= slot-id 10)
  237.          (if (empty-slot? 11)
  238.              (flip-top-card 5)
  239.              ))
  240.         ((= slot-id 9)
  241.          (if (empty-slot? 8)
  242.              (flip-top-card 4)
  243.              ))
  244.         ((= slot-id 8)
  245.          (if (empty-slot? 9)
  246.              (flip-top-card 4)
  247.              ))
  248.         ((= slot-id 7)
  249.          (if (empty-slot? 6)
  250.              (flip-top-card 3)
  251.              ))
  252.         ((= slot-id 6)
  253.          (if (empty-slot? 7)
  254.              (flip-top-card 3)
  255.              ))))
  256.  
  257. (define (available? slot-id)
  258.   (and (not (empty-slot? slot-id))
  259.        (> slot-id 2)
  260.        (is-visible? (get-top-card slot-id))))
  261.  
  262. (define (movable? card)
  263.   (and (not (empty-slot? 2))
  264.        (or (eq? (modulo (+ 1 (get-value card)) 13)
  265.                 (modulo (get-value (get-top-card 2)) 13))
  266.        (eq? (modulo (get-value card) 13) 
  267.         (modulo (+ 1 (get-value (get-top-card 2))) 13)))))
  268.  
  269. (define (droppable? start-slot card-list end-slot)
  270.   (and (not (= start-slot end-slot))
  271.        (= end-slot 2)
  272.        (movable? (car card-list))))
  273.  
  274. (define (tally-score start-slot)
  275.   (begin
  276.     (if multiplier-scoring
  277.     (add-to-score! (integer-expt 2 (- (length (get-cards 2)) 2)))
  278.     (add-to-score! (- (length (get-cards 2)) 1)))
  279.     (check-bonus start-slot)
  280.     (check-for-flips start-slot)))
  281.  
  282. (define (check-bonus slot-id)
  283.   (and (< slot-id 6)
  284.        (if (game-won)
  285.            (if multiplier-scoring
  286.                (add-to-score! 50)
  287.                (add-to-score! 30))
  288.            (if multiplier-scoring
  289.                (add-to-score! 25)
  290.                (add-to-score! 15))))
  291.   (and (game-won) 
  292.        progressive-rounds
  293.        (progressive-redeal)))
  294.  
  295. (define (button-released start-slot card-list end-slot)
  296.   (and (= end-slot 2)
  297.        (movable? (car card-list))
  298.        (move-n-cards! start-slot end-slot card-list)
  299.        (tally-score start-slot)))
  300.  
  301. (define (button-clicked slot-id)
  302.   (if (= slot-id 0)
  303.       (and (not (empty-slot? 0))
  304.            (flip-deck 1 2)
  305.            (deal-cards-face-up 0 '(2))
  306.            (if (not multiplier-scoring)
  307.                (set-score! (max (- (get-score) 5) 0))))
  308.       (and (> slot-id 2)
  309.            (available? slot-id)
  310.            (movable? (get-top-card slot-id))
  311.            (deal-cards slot-id '(2))
  312.            (tally-score slot-id))))
  313.  
  314. (define (button-double-clicked slot-id)
  315.   #f)
  316.  
  317. (define (game-continuable)
  318.   (give-status-message)
  319.   (and (not (game-won))
  320.        (get-hint)))
  321.  
  322. (define (game-won)
  323.   (and (empty-slot? 3)
  324.        (empty-slot? 4)
  325.        (empty-slot? 5)))
  326.  
  327. (define (check-move slot-id)
  328.   (and (< slot-id 31)
  329.        (or (check-move (+ 1 slot-id))
  330.        (and (available? slot-id)
  331.         (movable? (get-top-card slot-id))
  332.         (list 1
  333.               (get-name (get-top-card slot-id))
  334.               (get-name (get-top-card 2)))))))
  335.  
  336. (define (dealable?)
  337.   (and (not (empty-slot? 0))
  338.        (list 0 (_"Deal a card"))))
  339.  
  340. (define (get-hint)
  341.   (or (check-move 3)  
  342.       (dealable?)))
  343.  
  344. (define (get-options)
  345.   (list (list (_"Progressive Rounds") progressive-rounds) 
  346.         (list (_"Multiplier Scoring") multiplier-scoring)))
  347.  
  348. (define (apply-options options)
  349.   (set! progressive-rounds (cadar options))
  350.   (set! multiplier-scoring (cadadr options)))
  351.  
  352. (define (timeout) 
  353.   #f)
  354.  
  355. (set-features droppable-feature)
  356.  
  357. (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?)
  358.