home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / plait.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  10.6 KB  |  378 lines
  1. ;;; plait.scm
  2.  
  3. ;; Copyright (C) 1999, 2003 W. Borgert
  4.  
  5. ;; Author: W. Borgert <debacle@debian.org>
  6.  
  7. ;; This program is free software; you can redistribute it and'or modify
  8. ;; it under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11.  
  12. ;; This program is distributed in the hope that it will be useful,
  13. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15. ;; GNU General Public License for more details.
  16.  
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with this program; if not, write to the Free Software
  19. ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21. ;; @(#) $Id: plait.scm,v 1.14 2005/07/10 07:08:54 callum Exp $
  22.  
  23. ;; Constants
  24. (define edge-1  0)
  25. (define plait   1)
  26. (define edge-2  2)
  27. (define home-1  3)
  28. (define home-2  4)
  29. (define free-1  5)
  30. (define free-2  6)
  31. (define free-3  7)
  32. (define free-4  8)
  33. (define stock   9)
  34. (define deck   10)
  35. (define home-3 11)
  36. (define home-4 12)
  37. (define free-5 13)
  38. (define free-6 14)
  39. (define free-7 15)
  40. (define free-8 16)
  41. (define home-5 17)
  42. (define home-6 18)
  43. (define edge-3 19)
  44. (define edge-4 20)
  45. (define home-7 21)
  46. (define home-8 22)
  47. (def-save-var direc 0)
  48. (define start-value 0)
  49.  
  50. (define up 1)
  51. (define down 2)
  52.  
  53. ;; Utilities
  54. (define (edge? slot)
  55.   (or (= slot edge-1)
  56.       (= slot edge-2)
  57.       (= slot edge-3)
  58.       (= slot edge-4)))
  59.  
  60. (define (home? slot)
  61.   (or (= slot home-1)
  62.       (= slot home-2)
  63.       (= slot home-3)
  64.       (= slot home-4)
  65.       (= slot home-5)
  66.       (= slot home-6)
  67.       (= slot home-7)
  68.       (= slot home-8)))
  69.  
  70. (define (free? slot)
  71.   (or (= slot free-1)
  72.       (= slot free-2)
  73.       (= slot free-3)
  74.       (= slot free-4)
  75.       (= slot free-5)
  76.       (= slot free-6)
  77.       (= slot free-7)
  78.       (= slot free-8)))
  79.  
  80. ;; How to move cards
  81. (define (move-to-cell start-slot card-list end-slot)
  82.   (and (= (length card-list) 1)
  83.        (not (and (= start-slot plait)
  84.          (free? end-slot)))
  85.        (empty-slot? end-slot)
  86.        (add-cards! end-slot card-list)))
  87.  
  88. (define (get-valid-move slot home-list)
  89.   (and (not (null? home-list))
  90.        (if (and (not (empty-slot? slot))
  91.         (move-possible? (get-top-card slot) (car home-list)))
  92.        (if (not (empty-slot? (car home-list)))
  93.            (list 1 (get-name (get-top-card slot))
  94.              (get-name (get-top-card (car home-list))))
  95.            (list 0 (format (_"Move ~a to an empty field") (get-name (get-top-card slot)))))
  96.        (get-valid-move slot (cdr home-list)))))
  97.  
  98. (define (get-valid-moves slot-list home-list)
  99.  (and (not (null? slot-list))
  100.       (or (get-valid-move (car slot-list) home-list)
  101.       (get-valid-moves (cdr slot-list) home-list))))
  102.  
  103. (define (deal-possible?)
  104.   (if (not (empty-slot? deck))
  105.       (list 0 (_"Deal a new card from the deck"))
  106.       (if (and (< FLIP-COUNTER 2)
  107.            (not (empty-slot? stock)))
  108.       (list 0 (_"Move waste back to stock"))
  109.       #f)))
  110.  
  111. (define (move-upwards-possible? top-card-value new-card-value)
  112.   (and (not (eq? direc down))
  113.        (or (= top-card-value
  114.           (- new-card-value 1))
  115.        (and (= top-card-value king)
  116.         (= new-card-value ace)))))
  117.  
  118. (define (move-downwards-possible? top-card-value new-card-value)
  119.   (and (not (eq? direc up))
  120.        (or (= top-card-value
  121.           (+ new-card-value 1))
  122.        (and (= top-card-value ace)
  123.         (= new-card-value king)))))
  124.  
  125. (define (move-possible? card end-slot)
  126.   (and (< (length (get-cards end-slot)) 13)
  127.        (or (empty-slot? end-slot)
  128.        (and (= (get-suit (car (get-cards end-slot)))
  129.            (get-suit card))
  130.         (or (move-upwards-possible?
  131.              (get-value (car (get-cards end-slot)))
  132.              (get-value card))
  133.             (move-downwards-possible?
  134.              (get-value (car (get-cards end-slot)))
  135.              (get-value card)))))
  136.        (or (not (empty-slot? end-slot))
  137.        (= (get-value card) start-value))))
  138.  
  139. (define (move-to-home card-list end-slot)
  140.   (if (and (= (length card-list) 1)
  141.        (move-possible? (car card-list) end-slot))
  142.       (begin
  143.     (if (and (eq? direc 0)
  144.          (not (empty-slot? end-slot)))
  145.          (let ((es (get-value (car (get-cards end-slot))))
  146.            (cl (get-value (car card-list))))
  147.           (if (or (and (< es cl) (not (and (= es ace) (= cl king))))
  148.               (and (= es king) (= cl ace)))
  149.         (set! direc up)
  150.         (set! direc down))))
  151.     (add-cards! end-slot card-list))
  152.       #f))
  153.  
  154. ;; find the center between two slots horizontally
  155. (define (get-and-increment-position-half)
  156.   (let ((retval (list HORIZPOS VERTPOS)))
  157.     (set! HORIZPOS (+ HORIZPOS 0.5))
  158.     retval))
  159.  
  160. ;; Set up a new game.
  161. (define (new-game)
  162.   (initialize-playing-area)
  163.   (make-standard-double-deck)
  164.   (shuffle-deck)
  165.  
  166.   (get-and-increment-position-half)
  167.   (add-normal-slot '())
  168.   (add-blank-slot)
  169.   (add-extended-slot '() down)
  170.   (add-blank-slot)
  171.   (add-normal-slot '())
  172.   (get-and-increment-position-half)
  173.   (add-blank-slot)
  174.   (add-blank-slot)
  175.   (add-normal-slot '())
  176.   (add-normal-slot '())
  177.   (add-carriage-return-slot)
  178.  
  179.   (add-normal-slot '())
  180.   (add-normal-slot '())
  181.   (add-blank-slot)
  182.   (add-blank-slot)
  183.   (add-normal-slot '())
  184.   (add-normal-slot '())
  185.   (set! VERTPOS (+ VERTPOS 0.5))
  186.   (add-normal-slot '())
  187.   (add-normal-slot DECK)
  188.   (set! VERTPOS (- VERTPOS 0.5))
  189.   (add-normal-slot '())
  190.   (add-normal-slot '())
  191.   (add-carriage-return-slot)
  192.  
  193.   (add-normal-slot '())
  194.   (add-normal-slot '())
  195.   (add-blank-slot)
  196.   (add-blank-slot)
  197.   (add-normal-slot '())
  198.   (add-normal-slot '())
  199.   (add-blank-slot)
  200.   (add-blank-slot)
  201.   (add-normal-slot '())
  202.   (add-normal-slot '())
  203.   (add-carriage-return-slot)
  204.  
  205.   (get-and-increment-position-half)
  206.   (add-normal-slot '())
  207.   (add-blank-slot)
  208.   (add-blank-slot)
  209.   (add-blank-slot)
  210.   (add-normal-slot '())
  211.   (get-and-increment-position-half)
  212.   (add-blank-slot)
  213.   (add-blank-slot)
  214.   (add-normal-slot '())
  215.   (add-normal-slot '())
  216.   (add-carriage-return-slot)
  217.  
  218.   (deal-cards-face-up deck '(0
  219.                  1 1 1 1 1 1 1 1 1 1
  220.                  1 1 1 1 1 1 1 1 1 1
  221.                  2 3 5 6 7 8 13 14 15 16 19 20))
  222.   (set! direc 0)
  223.   (set! start-value (get-value (get-top-card home-1)))
  224.  
  225.   (list 10 4))
  226.  
  227.  
  228. (define (give-status-message)
  229.   (set-statusbar-message (string-append (get-stock-no-string)
  230.                     "   "
  231.                     (get-base-string)
  232.                     "   "
  233.                     (get-redeals-string))))
  234.  
  235. (define (get-stock-no-string)
  236.   (string-append (_"Stock left:") " "
  237.          (number->string (length (get-cards deck)))))
  238.  
  239. (define (get-base-string)
  240.   (cond ((and (> start-value 1)
  241.           (< start-value 11))
  242.      (string-append (_"Base Card: ") (number->string start-value)))
  243.     ((= start-value 1)
  244.      (_"Base Card: Ace"))
  245.     ((= start-value 11)
  246.      (_"Base Card: Jack"))
  247.     ((= start-value 12)
  248.      (_"Base Card: Queen"))
  249.     ((= start-value 13)
  250.      (_"Base Card: King"))
  251.     (#t "")))
  252.  
  253. (define (get-redeals-string)
  254.   (string-append (_"Redeals left:") " "
  255.          (number->string (- 2 FLIP-COUNTER))))
  256.  
  257. ;; Move cards automatically from the plait to one of the edge slots
  258. (define (plait-to-edge start-slot)
  259.   (if (and (edge? start-slot)
  260.        (not (empty-slot? plait)))
  261.       (let ((top-card (remove-card plait)))
  262.     (add-card! start-slot top-card))
  263.   #t))
  264.  
  265.  
  266. (define (button-pressed slot card-list)
  267.   (if (or (free? slot)
  268.       (edge? slot)
  269.       (= stock slot)
  270.       (= plait slot))
  271.       #t
  272.       #f))
  273.  
  274. (define (droppable? start-slot card-list end-slot)
  275.   (cond ((or (free? end-slot) (edge? end-slot)) (and
  276.                          (= (length card-list) 1)
  277.                          (not (and (= start-slot plait)
  278.                                (free? end-slot)))
  279.                          (empty-slot? end-slot)))
  280.     ((home? end-slot) (move-possible? (car card-list) end-slot))
  281.     (else #f)))
  282.  
  283. (define (button-released start-slot card-list end-slot)
  284.   (cond ((free? end-slot) (move-to-cell start-slot card-list end-slot))
  285.     ((home? end-slot) (and
  286.                (move-to-home card-list end-slot)
  287.                (plait-to-edge start-slot)))
  288.     ((edge? end-slot) (move-to-cell start-slot card-list end-slot))
  289.     (else #f)))
  290.  
  291. (define (button-clicked slot)
  292.   (if (= slot deck)
  293.       (flip-stock deck stock 2)
  294.       #f))
  295.  
  296. ;; On double-click, move a card (other than the deck) to a home slot, or
  297. ;; else move a ``stock'' (waste-slot) card to a tableau (edge or
  298. ;; ``free'') slot
  299. (define (button-double-clicked source) 
  300.   (let ((dc-slots (list home-1 home-3 home-5 home-7 home-2 home-4 home-6 home-8
  301.                free-4 free-8 free-3 free-7 free-2 free-6 free-1 free-5 
  302.                edge-2 edge-4 edge-1 edge-3)))
  303.     (if (not (home? source)) 
  304.     (let ((valid-slot (find-valid-move source dc-slots))) 
  305.       (if valid-slot
  306.           (if (home? valid-slot)
  307.           (begin
  308.             (move-to-home (list (remove-card source)) valid-slot)
  309.             (plait-to-edge source)
  310.             #t)
  311.           (begin
  312.             (add-cards! valid-slot (list (remove-card source)))
  313.             #t)) 
  314.           #f)) 
  315.     #f)))
  316.  
  317. ;; Helper for double-click: find the first valid move to a slot in slot-list.
  318. ;; Any slot except deck can be moved to home.  Waste-pile cards can be moved 
  319. ;; to the tableau (edge or free slots).  
  320. ;; TODO: This should really be two separate functions, since the result is
  321. ;;     used differently, depending on whether it's a home slot or not.
  322. (define (find-valid-move source slot-list)
  323.   (and (not (null? slot-list))
  324.        (let ((target (car slot-list)))
  325.             (cond ((and (home? target)
  326.                         (not (empty-slot? source))
  327.                         (move-possible? (get-top-card source) target))
  328.                      target)
  329.                   ((and  (or (free? target) (edge? target))
  330.                         (= source stock)
  331.                         (empty-slot? target))
  332.                      target)
  333.                   (else 
  334.                         (find-valid-move source (cdr slot-list)))))))
  335.  
  336. ;; Condition for win -- all the cards in homecells
  337. (define (game-won)
  338.   (and (= 13 (length (get-cards home-1)))
  339.        (= 13 (length (get-cards home-2)))
  340.        (= 13 (length (get-cards home-3)))
  341.        (= 13 (length (get-cards home-4)))
  342.        (= 13 (length (get-cards home-5)))
  343.        (= 13 (length (get-cards home-6)))
  344.        (= 13 (length (get-cards home-7)))
  345.        (= 13 (length (get-cards home-8)))))
  346.  
  347. ;; Check for, in order:
  348. ;; 1) A move to the fields.
  349. ;; 2) A card can be dealt from the deck
  350. ;; 3) A card can be moved from the stock to the edges ot tableau.
  351. (define (get-hint)
  352.   (or (get-valid-moves '(1 0 2 19 20 9 5 6 7 8 13 14 15 16)
  353.                '(3 4 11 12 17 18 21 22))
  354.       (deal-possible?)
  355.       (if (find-valid-move stock '(0 2 5 6 7 8 13 14 15 16 19 20))
  356.       (list 0 (format (_"Move ~a from the stock to an empty edge or tableau slot") 
  357.           (get-name (get-top-card stock))))
  358.       #f)))
  359.  
  360. (define (game-cont)
  361.   (and (not (game-won))
  362.        (give-status-message)
  363.        (get-hint)))
  364.        
  365. (define (get-options) #f)
  366.  
  367. (define (apply-options options) #f)
  368.  
  369. (define (timeout) #f)
  370.  
  371. (set-features droppable-feature scores-disabled)
  372.  
  373. (set-lambda new-game button-pressed button-released button-clicked
  374.         button-double-clicked game-cont game-won get-hint
  375.         get-options apply-options timeout droppable?)
  376.  
  377. ;;; plait.scm ends here
  378.