home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / sol.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  20.9 KB  |  639 lines
  1. ; AisleRiot - sol.scm
  2. ; Copyright (C) 1998, 2003 Jonathan Blandford <jrb@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. (use-modules (ice-9 format))
  20.  
  21. ;; Compatibility code so we run on both guile 1.3 and 1.5
  22.  
  23. (define (eval-1 code)
  24.   (if (string<? (version) "1.5")
  25.       (eval code)
  26.       (eval code (current-module))))
  27.         
  28. ;; Feature masks:
  29. (define droppable-feature 1)
  30. (define scores-disabled 2)
  31.  
  32. (define (reset-features) (set-feature-word! 0))
  33.  
  34. (define (set-features . feature-list)
  35.   (set-feature-word! (+ (get-feature-word)
  36.                (apply + feature-list))))
  37.  
  38. ;; Sol.scm gets evaluated whenever game types are switched,
  39. ;; this makes sure that the old settings are gone.
  40. (reset-features)
  41.  
  42. ;; Constants:
  43.  
  44. (define jack 11)
  45. (define queen 12)
  46. (define king 13)
  47. (define ace 1)
  48. (define joker 0)
  49.  
  50. (define club 0)
  51. (define diamond 1)
  52. (define heart 2)
  53. (define spade 3)
  54.  
  55. (define black 0)
  56. (define red 1)
  57.  
  58. (define down 0)
  59. (define right 1)
  60.  
  61. ;; Global variables:
  62.  
  63. (define DECK '())
  64.  
  65. ; The list of variables to save when saving the game state
  66. (define variable-list '())
  67.  
  68. ;; NEW-GAME PROCEDURES
  69. ; these may be used in game files during the new-game procedure.
  70.  
  71. ; This procedure MUST be called at the start of the new-game procedure.
  72. ;
  73. ; Note that variable-list is not cleared, this is because defines are normally
  74. ; done before calling this and we would loose our variable list. At worst
  75. ; case we end up saving and restoring variables that are not currently in use 
  76. ; (but will be defined) so it will work out OK.
  77. (define (initialize-playing-area)
  78.   (reset-surface)
  79.   (set! FLIP-COUNTER 0)
  80.   (set! SLOTS 0)
  81.   (set! HORIZPOS 0)
  82.   (set! VERTPOS 0)
  83.   (set! IN-GAME #f)
  84.   (set! MOVE '())
  85.   (set-statusbar-message " ")
  86.   (set! HISTORY '()))
  87.  
  88. ; Use this instead of define for variables which determine the state of
  89. ; the game. i.e. anything that isn't a constant. This is so undo/redo
  90. ; is transparent. It should behave otherwise identically to define.
  91. (defmacro def-save-var (nm value)
  92.   `(begin (define ,nm ,value)
  93.           (set! variable-list (cons ',nm variable-list))))
  94.  
  95. ; create a 52 card deck (puts list of cards into DECK)
  96. (define (make-standard-deck)
  97.   (if (= ace 14)
  98.       (set! DECK (make-standard-deck-list-ace-high 2 club))
  99.       (set! DECK (make-standard-deck-list-ace-low ace club))))
  100.  
  101. ; create a 54 card deck with 2 jokers.
  102. (define (make-joker-deck)
  103.   (if (= ace 14)
  104.      (set! DECK (cons (make-card joker club) (cons (make-card joker diamond) 
  105.          (make-standard-deck-list-ace-high 2 club))))
  106.      (set! DECK (cons (make-card joker club) (cons (make-card joker diamond) 
  107.          (make-standard-deck-list-ace-low ace club))))))
  108.      
  109. ; create a double deck of 104 cards (puts list of cards into DECK)
  110. (define (make-standard-double-deck)
  111.   (if (= ace 14)
  112.       (set! DECK (append (make-standard-deck-list-ace-high 2 club) (make-standard-deck-list-ace-high 2 club)))
  113.       (set! DECK (append (make-standard-deck-list-ace-low ace club) (make-standard-deck-list-ace-low ace club)))))
  114.  
  115.  ; makes a deck from init-value to kings
  116. (define (make-deck-list-ace-low init-value value suit)
  117.    (if (eq? king value)
  118.       (if (eq? spade suit)
  119.       (list (make-card king spade))
  120.       (cons (make-card value suit) 
  121.         (make-deck-list-ace-low 
  122.          init-value init-value (+ 1 suit))))
  123.       (cons (make-card value suit) 
  124.         (make-deck-list-ace-low init-value (+ 1 value) suit))))
  125.  
  126.  ; makes a deck from init-value to aces
  127. (define (make-deck-list-ace-high init-value value suit)
  128.    (if (eq? 14 value)
  129.       (if (eq? spade suit)
  130.       (list (make-card ace spade))
  131.       (cons (make-card value suit) 
  132.         (make-deck-list-ace-high 
  133.          init-value init-value (+ 1 suit))))
  134.       (cons (make-card value suit) 
  135.         (make-deck-list-ace-high init-value (+ 1 value) suit))))
  136.  
  137.  
  138.  
  139. ; shuffle the card list in DECK
  140. (define (shuffle-deck)
  141.   (let* ((vec (list->vector DECK))
  142.      (len (vector-length vec)))
  143.     (set! DECK (shuffle-deck-helper vec 0 len))))
  144.                          
  145. ; The playing area is divided into slots, where cards can be placed.
  146. ; Each slot can hold any amount of cards.  The slots are identified 
  147. ; using numbers assigned in order of their creation. The deck of cards
  148. ; held in DECK should be assigned to one of the slots on creation.
  149. ; (You may then create another deck and place it in a later slot).
  150. ;
  151. ; The slots are added to the board from left to right until the
  152. ; add-carriage-return-slot procedure is called, which starts a new line.
  153. ; A space may be added using the add-blank-slot procedure. These false
  154. ; slots are not assigned identifiers.
  155.  
  156. (define (add-blank-slot)
  157.   (get-and-increment-position))
  158.  
  159. (define (add-carriage-return-slot)
  160.   (linefeed-position))
  161.  
  162. ; The real slots come in three varieties:
  163. ; A slot in which only the topmost card is visible:
  164. (define (add-normal-slot cards)
  165.   (add-slot (set-tag! (new-slot cards 
  166.                 (list 'normal (get-and-increment-position))))))
  167.  
  168. ; A slot in which all the cards are visible, arranged as an overlapped pile:
  169. ; (either proceeding to the right or down).
  170. (define (add-extended-slot cards direction)
  171.   (if (= right direction)
  172.       (add-slot (set-tag! (new-slot cards 
  173.                     (list 'expanded-right 
  174.                       (get-and-increment-position)))))
  175.       (add-slot (set-tag! (new-slot cards 
  176.                     (list 'expanded 
  177.                       (get-and-increment-position)))))))
  178.  
  179. ; A slot in only the n topmost cards are visible:
  180. (define (add-partially-extended-slot cards direction n)
  181.   (if (= right direction)
  182.       (add-slot (set-tag! (new-slot cards 
  183.                     (list 'partially-expanded-right 
  184.                       (get-and-increment-position) n))))
  185.       (add-slot (set-tag! (new-slot cards 
  186.                     (list 'partially-expanded 
  187.                       (get-and-increment-position) n))))))
  188.  
  189. ; Cards may be dealt off one slot (usually the one containing the deck)
  190. ; and onto a list of other slots using these procedures:
  191. (define (deal-cards target-slot-id slot-list)
  192.   (if (not (null? slot-list))
  193.       (begin 
  194.     (add-card! (car slot-list) (remove-card target-slot-id))
  195.     (deal-cards target-slot-id (cdr slot-list)))))
  196.  
  197. (define (deal-cards-face-up target-slot-id slot-list)
  198.   (if (not (null? slot-list))
  199.       (begin 
  200.     (add-card! (car slot-list) (make-visible (remove-card target-slot-id)))
  201.     (deal-cards-face-up target-slot-id (cdr slot-list)))))
  202.  
  203. ;; GENERAL GAME PROCEDURES
  204. ; these may be used in game files at any time.
  205.  
  206. ;; Procedures that change slot contents:
  207.  
  208. ; turn the top card of a slot over (face up to face down and vice versa)
  209. (define (flip-top-card slot-id)
  210.   (add-card! slot-id (flip-card (remove-card slot-id))))
  211.  
  212. ; turn the top card of a slot face side up 
  213. (define (make-visible-top-card slot-id)
  214.   (add-card! slot-id (make-visible (remove-card slot-id))))
  215.  
  216. ; add a card onto the top of a slot
  217. (define (add-card! slot-id card)
  218.   (set-cards! slot-id (cons card (get-cards slot-id))))
  219.  
  220. ; add a list of cards onto the top of a slot
  221. (define (add-cards! slot-id cards)
  222.   (set-cards! slot-id (append cards (get-cards slot-id))))
  223.  
  224. ; remove (and return) the top card from a slot
  225. (define (remove-card slot-id)
  226.   (let ((cards (get-cards slot-id)))
  227.     (set-cards! slot-id (cdr cards))
  228.     (car cards)))
  229.  
  230. ;; Utilities
  231.  
  232. ; deal a card from the stock-slot to the waste-slot.
  233. ; when the stock slot is empty than the waste slot will be flipped back
  234. ; onto the stock unless the flip limit has been reached.
  235. ; an optional forth argument indicates the number of cards to deal.
  236. ; If the flip limit is negative, it is treated as infinite.
  237. (define (flip-stock stock-slot waste-slot flip-limit . rest)
  238.   (if (empty-slot? stock-slot)
  239.       (and (or (< flip-limit 0)
  240.            (< FLIP-COUNTER flip-limit))
  241.        (set! FLIP-COUNTER (+ 1 FLIP-COUNTER))
  242.        (flip-deck stock-slot waste-slot))
  243.       (or (let loop ((i (if (null? rest) 1 (car rest))))
  244.         (and (> i 0)
  245.          (not (empty-slot? stock-slot))
  246.          (add-card! waste-slot (flip-card (remove-card stock-slot)))
  247.          (loop (- i 1))))
  248.       #t)))
  249.  
  250. ; turn the cards in the waste slot over and add them to the stock-slot.
  251. (define (flip-deck stock-slot waste-slot)
  252.   (and (not (empty-slot? waste-slot))
  253.        (add-card! stock-slot (flip-card (remove-card waste-slot)))
  254.        (or (flip-deck stock-slot waste-slot)
  255.        #t)))
  256.  
  257. ;; Procedures for manipulating cards:
  258.  
  259. ; NB: In order to use these procedures you must remove the cards 
  260. ;     from their slots and then replace them after applying the procedure 
  261. ;     (as in the make-top-card-visible procedure above)
  262. (define (flip-card card)
  263.   (list (car card) (cadr card) (not (caddr card))))
  264.  
  265. (define (make-visible card)
  266.   (list (car card) (cadr card) #t))
  267.  
  268. ;; Procedures that provide information only:
  269.  
  270. ; card procedures
  271. (define (is-visible? card)
  272.   (caddr card))
  273.  
  274. (define (get-suit card) 
  275.       (cadr card))
  276.  
  277. (define (get-color card)
  278.   (cond ((eq? (get-suit card) club) black)
  279.     ((eq? (get-suit card) spade) black)
  280.     ((eq? (get-suit card) heart) red)
  281.     ((eq? (get-suit card) diamond) red)
  282.     (#t (_"Unknown color"))))
  283.  
  284. (define (get-value card)
  285.       (car card))
  286.  
  287. ;; WARNING: This generates a synthetic card that isn't part of the game.
  288. ;;          See gaps.scm for an example of its intended use.
  289. (define (add-to-value card n)
  290.   (cons (+ (car card) n) (cdr card)))
  291.  
  292. ; slot procedures
  293. (define (get-cards slot-id)
  294.   (cadr (get-slot slot-id)))
  295.  
  296. (define (empty-slot? slot-id)
  297.   (null? (get-cards slot-id)))
  298.  
  299. ; Get the nth card from a slot. Returns #f if n is out of range.
  300. (define (get-nth-card slot-id n)
  301.   (let ((cards (get-cards slot-id)))
  302.     (cond ((< n 1) #f)
  303.       ((> n (length cards)) #f)
  304.       (#t (list-ref cards (- n 1))))))
  305.  
  306. (define (get-top-card slot-id)
  307.   (let ((cards (get-cards slot-id)))
  308.     (if (null? cards)
  309.     '()
  310.     (car cards))))
  311.  
  312. ;; Utilities - need more of these:
  313. (define (cards-eq? card1 card2)
  314.   (and (eq? (get-value card1) (get-value card2))
  315.        (eq? (get-suit card1) (get-suit card2))))
  316.  
  317. (define (is-red? card)
  318.   (eq? red (get-color card)))
  319.  
  320. (define (is-black? card)
  321.   (eq? black (get-color card)))
  322.  
  323. (define (is-joker? card)
  324.   (= (get-value card) joker))
  325.  
  326. (define (set-ace-low)  (set! ace 1))
  327.  
  328. (define (set-ace-high) (set! ace 14))
  329.  
  330. ; use to compare two cards when aces are treated as high:
  331. (define (ace-high-order value)
  332.   (remainder (+ 11 value) 13))
  333.  
  334. (define (check-same-suit-list card-list)
  335.   (or (< (length card-list) 2)
  336.       (and (= (get-suit (car card-list)) (get-suit (cadr card-list)))
  337.        (check-same-suit-list (cdr card-list)))))
  338.  
  339. (define (check-same-color-list card-list)
  340.   (or (< (length card-list) 2)
  341.       (and (eq? (is-red? (car card-list)) (is-red? (cadr card-list)))
  342.        (check-same-color-list (cdr card-list)))))
  343.  
  344. (define (check-alternating-color-list card-list)
  345.   (or (< (length card-list) 2)
  346.       (and (eq? (is-black? (car card-list)) (is-red? (cadr card-list)))
  347.        (check-alternating-color-list (cdr card-list)))))
  348.  
  349. (define (check-straight-descending-list card-list)
  350.   (or (< (length card-list) 2)
  351.       (and (= (get-value (car card-list)) (- (get-value (cadr card-list)) 1))
  352.        (check-straight-descending-list (cdr card-list)))))
  353.  
  354. ; debugging aid:
  355. (define (display-list . objs)
  356.   (map display objs) (newline))
  357.  
  358. ; hint procedures
  359. (define (get-value-name value)
  360.   (cond ((eq? value ace) (_"ace"))
  361.         ((eq? value 2) (_"two"))
  362.         ((eq? value 3) (_"three"))
  363.         ((eq? value 4) (_"four"))
  364.         ((eq? value 5) (_"five"))
  365.         ((eq? value 6) (_"six"))
  366.         ((eq? value 7) (_"seven"))
  367.         ((eq? value 8) (_"eight"))
  368.         ((eq? value 9) (_"nine"))
  369.         ((eq? value 10) (_"ten"))
  370.         ((eq? value jack) (_"jack"))
  371.         ((eq? value queen) (_"queen"))
  372.         ((eq? value king) (_"king"))
  373.         (#t (_"Unknown value"))))
  374.  
  375. (define (get-suit-name suit)
  376.   (cond ((eq? suit club) (_"clubs"))
  377.         ((eq? suit spade) (_"spades"))
  378.         ((eq? suit heart) (_"hearts"))
  379.         ((eq? suit diamond) (_"diamonds"))
  380.         (#t (_"Unknown suit"))))
  381.  
  382. (define (get-joker-name card) 
  383.   (if (is-black? card) (_"black joker") (_"red joker")))
  384.  
  385. (define (get-name card)
  386.   (let ((value (get-value card)) (suit (get-suit card)))
  387.     (if (is-joker? card)
  388.         (get-joker-name card)
  389.         (cond ((eq? suit club) 
  390.                (cond ((eq? value ace) (_"the ace of clubs"))
  391.                      ((eq? value 2) (_"the two of clubs"))
  392.                      ((eq? value 3) (_"the three of clubs"))
  393.                      ((eq? value 4) (_"the four of clubs"))
  394.                      ((eq? value 5) (_"the five of clubs"))
  395.                      ((eq? value 6) (_"the six of clubs"))
  396.                      ((eq? value 7) (_"the seven of clubs"))
  397.                      ((eq? value 8) (_"the eight of clubs"))
  398.                      ((eq? value 9) (_"the nine of clubs"))
  399.                      ((eq? value 10) (_"the ten of clubs"))
  400.                      ((eq? value jack) (_"the jack of clubs"))
  401.                      ((eq? value queen) (_"the queen of clubs"))
  402.                      ((eq? value king) (_"the king of clubs"))
  403.                      (#t (_"the unknown card"))))
  404.               ((eq? suit spade) 
  405.                (cond ((eq? value ace) (_"the ace of spades"))
  406.                      ((eq? value 2) (_"the two of spades"))
  407.                      ((eq? value 3) (_"the three of spades"))
  408.                      ((eq? value 4) (_"the four of spades"))
  409.                      ((eq? value 5) (_"the five of spades"))
  410.                      ((eq? value 6) (_"the six of spades"))
  411.                      ((eq? value 7) (_"the seven of spades"))
  412.                      ((eq? value 8) (_"the eight of spades"))
  413.                      ((eq? value 9) (_"the nine of spades"))
  414.                      ((eq? value 10) (_"the ten of spades"))
  415.                      ((eq? value jack) (_"the jack of spades"))
  416.                      ((eq? value queen) (_"the queen of spades"))
  417.                      ((eq? value king) (_"the king of spades"))
  418.                      (#t (_"the unknown card"))))
  419.               ((eq? suit heart) 
  420.                (cond ((eq? value ace) (_"the ace of hearts"))
  421.                      ((eq? value 2) (_"the two of hearts"))
  422.                      ((eq? value 3) (_"the three of hearts"))
  423.                      ((eq? value 4) (_"the four of hearts"))
  424.                      ((eq? value 5) (_"the five of hearts"))
  425.                      ((eq? value 6) (_"the six of hearts"))
  426.                      ((eq? value 7) (_"the seven of hearts"))
  427.                      ((eq? value 8) (_"the eight of hearts"))
  428.                      ((eq? value 9) (_"the nine of hearts"))
  429.                      ((eq? value 10) (_"the ten of hearts"))
  430.                      ((eq? value jack) (_"the jack of hearts"))
  431.                      ((eq? value queen) (_"the queen of hearts"))
  432.                      ((eq? value king) (_"the king of hearts"))
  433.                      (#t (_"the unknown card"))))
  434.               ((eq? suit diamond) 
  435.                (cond ((eq? value ace) (_"the ace of diamonds"))
  436.                      ((eq? value 2) (_"the two of diamonds"))
  437.                      ((eq? value 3) (_"the three of diamonds"))
  438.                      ((eq? value 4) (_"the four of diamonds"))
  439.                      ((eq? value 5) (_"the five of diamonds"))
  440.                      ((eq? value 6) (_"the six of diamonds"))
  441.                      ((eq? value 7) (_"the seven of diamonds"))
  442.                      ((eq? value 8) (_"the eight of diamonds"))
  443.                      ((eq? value 9) (_"the nine of diamonds"))
  444.                      ((eq? value 10) (_"the ten of diamonds"))
  445.                      ((eq? value jack) (_"the jack of diamonds"))
  446.                      ((eq? value queen) (_"the queen of diamonds"))
  447.                      ((eq? value king) (_"the king of diamonds"))
  448.                      (#t (_"the unknown card"))))
  449.               (#t (_"the unknown card"))))))
  450.  
  451. (define (move-n-cards! start-slot end-slot cards)
  452.   (add-cards! end-slot cards))
  453.  
  454. (define (remove-n-cards slot-id n)
  455.   (set-cards! slot-id (nthcdr n (get-cards slot-id))))
  456.  
  457. (define (deal-cards-from-deck deck slot-list)
  458.   (if (not (null? slot-list))
  459.       (begin 
  460.     (add-card! (car slot-list) (car deck))
  461.     (deal-cards-from-deck (cdr deck) (cdr slot-list)))))
  462.  
  463. (define (deal-cards-face-up-from-deck deck slot-list)
  464.   (if (not (null? slot-list))
  465.       (begin 
  466.     (add-card! (car slot-list) (make-visible (car deck)))
  467.     (deal-cards-face-up-from-deck (cdr deck) (cdr slot-list)))))
  468.  
  469.  
  470. (define (set-cards! slot-id new_cards)
  471.   (set-cards-c! slot-id new_cards))
  472.  
  473. (define (make-card value suit)
  474.   (list value suit #f))
  475.  
  476. (define (make-standard-deck-list-ace-high value suit)
  477.   (if (eq? ace value)
  478.       (if (eq? spade suit)
  479.       (list (make-card ace spade))
  480.       (cons (make-card value suit) 
  481.         (make-standard-deck-list-ace-high 2 (+ 1 suit))))
  482.       (cons (make-card value suit) 
  483.         (make-standard-deck-list-ace-high (+ 1 value) suit))))
  484.  
  485. (define (make-standard-deck-list-ace-low value suit)
  486.   (if (eq? king value)
  487.       (if (eq? spade suit)
  488.       (list (make-card king spade))
  489.       (cons (make-card value suit) 
  490.         (make-standard-deck-list-ace-low 1 (+ 1 suit))))
  491.       (cons (make-card value suit) 
  492.         (make-standard-deck-list-ace-low (+ 1 value) suit))))
  493.  
  494. (define (shuffle-deck-helper deck ref1 len)
  495.   (if (zero? len)
  496.       '()
  497.       (let* ((ref2 (+ ref1 (random len)))
  498.          (val-at-ref2 (vector-ref deck ref2)))
  499.     (vector-set! deck ref2 (vector-ref deck ref1))
  500.     (cons val-at-ref2 (shuffle-deck-helper deck (+ ref1 1) (- len 1))))))
  501.  
  502. (define (new-slot deck placement)
  503.   (list #f deck placement))
  504.  
  505. (define (set-tag! slot)
  506.   (set! SLOTS (+ 1 SLOTS))
  507.   (cons (- SLOTS 1) (cdr slot)))
  508.  
  509. (define (get-and-increment-position)
  510.   (let ((retval (list HORIZPOS VERTPOS)))
  511.     (set! HORIZPOS (+ HORIZPOS 1))
  512.     retval))
  513.  
  514. (define (linefeed-position)
  515.   (set! HORIZPOS 0)
  516.   (set! VERTPOS (+ VERTPOS 1)))
  517.  
  518. (define (register-undo-function function data)
  519.   (set! MOVE (cons '(function data) (cdr MOVE))))
  520.  
  521. ; common lisp procedure not provided in guile 1.3
  522. (define (nthcdr n lst)
  523.   (if (zero? n) lst (nthcdr (+ -1 n) (cdr lst))))
  524.  
  525. ;; INTERNAL procedures
  526.  
  527. ; global variables
  528. (define FLIP-COUNTER 0)
  529. (define SLOTS 0)
  530. (define HORIZPOS 0)
  531. (define VERTPOS 0)
  532. (define MOVE '())
  533. (define HISTORY '())
  534. (define FUTURE '())
  535. (define IN-GAME #f)
  536.  
  537. ; called from C:
  538. (define (start-game)
  539.   (set! IN-GAME #t))
  540.  
  541. ; called from C:
  542. (define (end-move)
  543.   (if (not (= 0 (length MOVE)))
  544.       (begin
  545.     (set! HISTORY (cons MOVE HISTORY))
  546.     (set! FUTURE '())
  547.     (set! MOVE '())
  548.         (if (null? HISTORY)
  549.             (undo-set-sensitive #f)
  550.             (undo-set-sensitive #t))
  551.         (if (null? FUTURE)
  552.             (redo-set-sensitive #f)
  553.             (redo-set-sensitive #t)))))
  554.  
  555. (define (return-cards card-positions slot-id)
  556.   (and (not (= 0 (length card-positions)))
  557.        (set-cards! slot-id (car card-positions))
  558.        (return-cards (cdr card-positions) (+ 1 slot-id))))
  559.  
  560. (define (give-status-message)
  561.   #t)
  562.  
  563. (define (eval-move move)
  564.   (return-cards (caddr move) 0)
  565.   ((car move) (cadr move))
  566.   (give-status-message))
  567.  
  568. ; called from C:
  569. (define (undo)
  570.   (and (not (null? HISTORY))
  571.        (record-move -1 '())
  572.        (eval-move (car HISTORY))
  573.        (set! FUTURE (cons MOVE FUTURE))
  574.        (set! HISTORY (cdr HISTORY))
  575.        (set! MOVE '())
  576.        (redo-set-sensitive #t)
  577.        (if (null? HISTORY)
  578.            (undo-set-sensitive #f))))
  579.  
  580. ; called from C:
  581. (define (redo)
  582.   (and (not (null? FUTURE))
  583.        (record-move -1 '())
  584.        (eval-move (car FUTURE))
  585.        (set! HISTORY (cons MOVE HISTORY))
  586.        (set! FUTURE (cdr FUTURE))
  587.        (set! MOVE '())
  588.        (undo-set-sensitive #t)
  589.        (if (null? FUTURE)
  590.            (redo-set-sensitive #f))))
  591.  
  592. (define (undo-func data)
  593.   (set-score! (car data))
  594.   (set! FLIP-COUNTER (cadr data))
  595.   (restore-variables variable-list (caddr data)))
  596. ;(register-undo-function undo-func '(score FLIP-COUNTER))
  597.          
  598. (define (snapshot-board slot-id moving-slot old-cards)
  599.   (cond ((>= slot-id SLOTS)
  600.      '())
  601.     ((= slot-id moving-slot)
  602.      (cons old-cards 
  603.            (snapshot-board (+ 1 slot-id) moving-slot old-cards)))
  604.     (#t
  605.      (cons (get-cards slot-id) 
  606.            (snapshot-board (+ 1 slot-id) moving-slot old-cards)))))
  607.  
  608. ; called from C:
  609. (define (record-move slot-id old-cards)
  610.   (set! MOVE (list undo-func 
  611.                    (list (get-score) FLIP-COUNTER 
  612.                          (save-variables variable-list))
  613.                    (snapshot-board 0 slot-id old-cards))))
  614.  
  615. ; called from C:
  616. (define (discard-move)
  617.   (set! MOVE '()))
  618.  
  619. ;; Routines for saving/restoring generic variables
  620.  
  621. ; Get a list of values for the variables we wish to save.
  622. (define save-variables
  623.   (lambda (names)
  624.     (if (equal? '() names)
  625.         '()
  626.         (cons (eval-1 (list 'copy-tree (car names))) 
  627.               (save-variables (cdr names))))))
  628.  
  629. ; Restore all the state variables for a game
  630. (define restore-variables
  631.   (lambda (names values)
  632.     (or (equal? '() names)
  633.         (begin
  634.           (eval-1 (list 'set! (car names) (list 'quote (car values))))
  635.           (restore-variables (cdr names) (cdr values))
  636.           ))))
  637.  
  638.  
  639.