anchor.diff:                    (order (make-array (list (length stock)))))
                    ((null stock) order)
                  (setf (aref order i) (cons (random 1000000) (car stock))))
  -             (lambda (a b) (< (car a) (car b)))))
  -  );;shuffle-stock
  +             (lambda (a b) (< (car a) (car b))))))
   
   
   (defclass solitaire ()
  
positive.code:     (setf (stock    self) (nreverse (discard self))
            (discard self) nil))
    (if (null (stock self))
      nil
      (push (pop (stock self)) (dealt self)))
    self);;deal
  
  
  (defclass solitaire-3x3 (solitaire)
  
negative.code:        (pop command)
         (let (from to)
           (cond
             ((eq (car command) :dealt)
              (setf from :dealt)
              (pop command))
             ((and (numberp (first command)) (numberp (second command)))
              (setf from (list :column (pop command) (pop command))))
             (t (return-from parse-move ())))
           (cond
             ((eq (car command) :foundation)
              (setf to :foundation)
              (pop command))
             ((numberp (first command))
              (setf to (list :column  (pop command))))
             (t (return-from parse-move ())))
           (when command (warn "Superfluous arguments ~S." command))
           (list from to)))
        (otherwise '()))))
  
  
  (defmethod play ((self solitaire))
    (let ((nfmd 0))
      (loop
        (tagbody
         :loop
           ;; (format t "~%~A~%" (state self))
           (format t "~A" self)
           (let ((moves (get-valid-moves self)))
             (format t "Valid moves: ~%~{    ~{~A~^ ~}~%~}"
                     (mapcar (function unparse-move) (cons '(:quit) moves)))
             (let ((forced-move (select-forced-move moves)))
               (if forced-move
                   (progn
                     (format t "Forced move: ~S~%" forced-move)
                     (if (eq :deal (car forced-move))
                         (if (<= (incf nfmd)
                                 (+ (length (stock self)) (length (discard self))))
                             (deal self)
                             (progn (format t "Draw~%") (return-from play)))
                         (progn
                           (setf nfmd 0)
                           (move self (first forced-move) (second forced-move)))))
                   (progn
                     (setf nfmd 0)
                     (format t "Your move: ")
                     (let* ((input (read-move))
                            (move (parse-move input)))
                       (cond
                         ((null move))
                         ((eq (car move) :quit)
                          (return-from play))
                         ((member move moves :test (function equalp))
                          (play-move self move) (go :loop)))
                       (format t "~&Invalid move: ~S~%" input))))))))))
  
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  