home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / clock.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  7.8 KB  |  244 lines
  1. ; AisleRiot - clock.scm
  2. ; Copyright (C) 1998, 2003 Rosanna Yuen <rwsy@mit.edu>
  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 (new-game)
  20.   (initialize-playing-area)
  21.   (make-standard-deck)
  22.   (shuffle-deck)
  23.  
  24.   (add-blank-slot)
  25.   (add-extended-slot '() right)
  26.   (add-blank-slot)
  27.   (add-extended-slot '() right)
  28.   (add-blank-slot)
  29.   (add-extended-slot '() right)
  30.   (add-carriage-return-slot)
  31.   
  32.   (add-extended-slot '() right)
  33.   (add-blank-slot)
  34.   (add-blank-slot)
  35.   (add-blank-slot)
  36.   (add-blank-slot)
  37.   (add-blank-slot)
  38.   (add-extended-slot '() right)
  39.   (add-carriage-return-slot)
  40.  
  41.   (add-extended-slot '() right)
  42.   (add-blank-slot)
  43.   (add-blank-slot)
  44.   (add-extended-slot DECK right)
  45.   (add-blank-slot)
  46.   (add-blank-slot)
  47.   (add-extended-slot '() right)
  48.   (add-carriage-return-slot)
  49.  
  50.   (add-extended-slot '() right)
  51.   (add-blank-slot)
  52.   (add-blank-slot)
  53.   (add-blank-slot)
  54.   (add-blank-slot)
  55.   (add-blank-slot)
  56.   (add-extended-slot '() right)
  57.   (add-carriage-return-slot)
  58.  
  59.   (add-blank-slot)
  60.   (add-extended-slot '() right)
  61.   (add-blank-slot)
  62.   (add-extended-slot '() right)
  63.   (add-blank-slot)
  64.   (add-extended-slot '() right)
  65.  
  66.   (deal-cards 6 '(2 4 7 9 12 11 10 8 5 3 0 1 2 4 7 9 12 11 10 8 5 3 0 1 2 4 7 9 12 11 10 8 5 3 0 1 2 4 7 9 12 11 10 8 5 3 0 1 ))
  67.  
  68.   (flip-top-card 6)
  69.  
  70.   (list 9 5)
  71. )
  72.  
  73. (define (button-pressed slot-id card-list)
  74.   (and (= slot-id 6)
  75.        (= (length card-list) 1)
  76.        (not (= king (get-value (car card-list))))))
  77.  
  78. (define (transaction-good? end-slot card-list)
  79.   (or (and (= end-slot 2)
  80.        (= ace (get-value (car card-list))))
  81.       (and (= end-slot 4)
  82.        (= 2 (get-value (car card-list))))
  83.       (and (= end-slot 7)
  84.        (= 3 (get-value (car card-list))))
  85.       (and (= end-slot 9)
  86.        (= 4 (get-value (car card-list))))
  87.       (and (= end-slot 12)
  88.        (= 5 (get-value (car card-list))))
  89.       (and (= end-slot 11)
  90.        (= 6 (get-value (car card-list))))
  91.       (and (= end-slot 10)
  92.        (= 7 (get-value (car card-list))))
  93.       (and (= end-slot 8)
  94.        (= 8 (get-value (car card-list))))
  95.       (and (= end-slot 5)
  96.        (= 9 (get-value (car card-list))))
  97.       (and (= end-slot 3)
  98.        (= 10 (get-value (car card-list))))
  99.       (and (= end-slot 0)
  100.        (= jack (get-value (car card-list))))
  101.       (and (= end-slot 1)
  102.        (= queen (get-value (car card-list))))
  103.       (and (= end-slot 6)
  104.        (= king (get-value (car card-list))))))
  105.  
  106. (define (complete-transaction card-list end-slot)
  107.   (add-cards! end-slot card-list)
  108.   (add-card! 6 (car (reverse (get-cards end-slot))))
  109.   (set-cards! end-slot (reverse (cdr (reverse (get-cards end-slot)))))
  110.   (make-visible-top-card 6)
  111.   (if (not (= end-slot 6))
  112.       (add-to-score! 1)
  113.       #t))
  114.  
  115. (define (droppable? start-slot card-list end-slot)
  116.   (transaction-good? end-slot card-list))
  117.  
  118. (define (button-released start-slot card-list end-slot)
  119.   (if (transaction-good? end-slot card-list)
  120.       (complete-transaction card-list end-slot)
  121.       #f))
  122.  
  123. (define (button-clicked slot-id)
  124.   (if (and (= (get-value (get-top-card slot-id)) king)
  125.        (is-visible? (get-top-card slot-id)))
  126.       (begin
  127.     (set-cards! 6 (cons (car (reverse (get-cards 6)))
  128.                 (reverse (cdr (reverse (get-cards 6))))))
  129.     (make-visible-top-card 6))
  130.       #f))
  131.  
  132. (define (button-double-clicked slot)
  133.   (if (and (not (= slot 6))
  134.        (transaction-good? slot (get-cards 6)))
  135.       (if (= slot 6)
  136.       (set-cards! 6 (cons (car (reverse (get-cards 6))) 
  137.                   (reverse (cdr (reverse (get-cards 6))))))
  138.       (begin
  139.         (let ((top-card (get-top-card 6)))
  140.           (set-cards! 6 (cdr (get-cards 6)))
  141.           (complete-transaction (list top-card) slot))))
  142.       #f))
  143.  
  144. (define (make-all-visible slot)
  145.   (if (< slot 13)
  146.       (begin
  147.     (make-visible (car (get-cards slot)))
  148.     (make-visible (cadr (get-cards slot)))
  149.     (make-visible (caddr (get-cards slot)))
  150.     (make-visible (cadddr (get-cards slot)))
  151.     (make-all-visible (+ slot 1)))))
  152.  
  153.  
  154. (define (game-won)
  155.   (make-all-visible 0)
  156.   (if (and (= (get-value (car (get-cards 2))) 1)
  157.        (= (get-value (cadr (get-cards 2))) 1)
  158.        (= (get-value (caddr (get-cards 2))) 1)
  159.        (= (get-value (cadddr (get-cards 2))) 1)
  160.        (= (get-value (car (get-cards 4))) 2)
  161.        (= (get-value (cadr (get-cards 4))) 2)
  162.        (= (get-value (caddr (get-cards 4))) 2)
  163.        (= (get-value (cadddr (get-cards 4))) 2)
  164.        (= (get-value (car (get-cards 7))) 3)
  165.        (= (get-value (cadr (get-cards 7))) 3)
  166.        (= (get-value (caddr (get-cards 7))) 3)
  167.        (= (get-value (cadddr (get-cards 7))) 3)
  168.        (= (get-value (car (get-cards 9))) 4)
  169.        (= (get-value (cadr (get-cards 9))) 4)
  170.        (= (get-value (caddr (get-cards 9))) 4)
  171.        (= (get-value (cadddr (get-cards 9))) 4)
  172.        (= (get-value (car (get-cards 12))) 5)
  173.        (= (get-value (cadr (get-cards 12))) 5)
  174.        (= (get-value (caddr (get-cards 12))) 5)
  175.        (= (get-value (cadddr (get-cards 12))) 5)
  176.        (= (get-value (car (get-cards 11))) 6)
  177.        (= (get-value (cadr (get-cards 11))) 6)
  178.        (= (get-value (caddr (get-cards 11))) 6)
  179.        (= (get-value (cadddr (get-cards 11))) 6)
  180.        (= (get-value (car (get-cards 10))) 7)
  181.        (= (get-value (cadr (get-cards 10))) 7)
  182.        (= (get-value (caddr (get-cards 10))) 7)
  183.        (= (get-value (cadddr (get-cards 10))) 7)
  184.        (= (get-value (car (get-cards 8))) 8)
  185.        (= (get-value (cadr (get-cards 8))) 8)
  186.        (= (get-value (caddr (get-cards 8))) 8)
  187.        (= (get-value (cadddr (get-cards 8))) 8)
  188.        (= (get-value (car (get-cards 5))) 9)
  189.        (= (get-value (cadr (get-cards 5))) 9)
  190.        (= (get-value (caddr (get-cards 5))) 9)
  191.        (= (get-value (cadddr (get-cards 5))) 9)
  192.        (= (get-value (car (get-cards 3))) 10)
  193.        (= (get-value (cadr (get-cards 3))) 10)
  194.        (= (get-value (caddr (get-cards 3))) 10)
  195.        (= (get-value (cadddr (get-cards 3))) 10)
  196.        (= (get-value (car (get-cards 0))) 11)
  197.        (= (get-value (cadr (get-cards 0))) 11)
  198.        (= (get-value (caddr (get-cards 0))) 11)
  199.        (= (get-value (cadddr (get-cards 0))) 11)
  200.        (= (get-value (car (get-cards 1))) 12)
  201.        (= (get-value (cadr (get-cards 1))) 12)
  202.        (= (get-value (caddr (get-cards 1))) 12)
  203.        (= (get-value (cadddr (get-cards 1))) 12)
  204.        )
  205.       #t
  206.       #f))
  207.  
  208. (define (game-over)
  209.   (not (and (is-visible? (car (reverse (get-cards 6))))
  210.         (= (get-value (get-top-card 6)) king)
  211.         (make-all-visible 0))))
  212.  
  213. (define (nth-item list n)
  214.   (if (= 0 n)
  215.       (car list)
  216.       (nth-item (cdr list) (- n 1))))
  217.  
  218. (define (get-hint)
  219.   (list 0 
  220.     (nth-item 
  221.      (list (_"Just because a crosswalk looks like a hopscotch board doesn't mean it is one")
  222.            (_"Look both ways before you cross the street")
  223.            (_"Have you read the help file?")
  224.            (_"Odessa is a better game.  Really.")
  225.            (_"Tourniquets are not recommended unless in the direst emergency")
  226.            (_"I could sure use a backrub right about now...")
  227.            (_"Monitors won't give you Vitamin D -- but sunlight will...")
  228.            (_"If you're ever lost and alone in the woods, hug a tree")
  229.            (_"Fishing wire makes bad dental floss")
  230.            (_"Consistency is key")
  231.            (_"When without a stapler, a staple and a ruler will work")
  232.            (_"Never blow in a dog's ear"))
  233.      (random 12))))
  234.  
  235. (define (get-options) #f)
  236.  
  237. (define (apply-options options) #f)
  238.  
  239. (define (timeout) #f)
  240.  
  241. (set-features droppable-feature)
  242.  
  243. (set-lambda new-game button-pressed button-released button-clicked button-double-clicked game-over game-won get-hint get-options apply-options timeout droppable?)
  244.