[ create a new paste ] login | about

Link: http://codepad.org/HjimquyE    [ raw code | output | fork ]

Scheme, pasted on Aug 15:
; cracker barrel

(define (identity x) x)

(define (mappend f . xss) (apply append (apply map f xss)))

(define (filter pred? xs)
  (let loop ((xs xs) (ys '()))
    (cond ((null? xs) (reverse ys))
          ((pred? (car xs))
            (loop (cdr xs) (cons (car xs) ys)))
          (else (loop (cdr xs) ys)))))

(define (remove x xs)
  (let loop ((xs xs) (zs '()))
    (cond ((null? xs) (reverse zs))
          ((equal? (car xs) x) (loop (cdr xs) zs))
          (else (loop (cdr xs) (cons (car xs) zs))))))

(define (insert x xs)
  (if (null? xs) (list x)
    (if (< x (car xs)) (cons x xs)
      (cons (car xs) (insert x (cdr xs))))))

(define possibles '((1 2 4) (1 3 6) (2 4 7) (2 5 9) (3 5 8)
  (3 6 10) (4 2 1) (4 5 6) (4 7 11) (4 8 13) (5 8 12) (5 9 14)
  (6 3 1) (6 5 4) (6 9 13) (6 10 15) (7 4 2) (7 8 9) (8 5 3)
  (8 9 10) (9 5 2) (9 8 7) (10 6 3) (10 9 8) (11 7 4)
  (11 12 13) (12 8 5) (12 13 14) (13 8 4) (13 9 6) (13 12 11)
  (13 14 15) (14 9 5) (14 13 12) (15 10 6) (15 14 13)))

(define init '((2 3 4 5 6 7 8 9 10 11 12 13 14 15)))

(define (feasible? board move)
  (and (member (car move) (car board))
       (member (cadr move) (car board))
       (not (member (caddr move) (car board)))))

(define (jump board move)
  (and (feasible? board move)
       (cons (insert (caddr move)
               (remove (car move)
                 (remove (cadr move) (car board))))
             (cons move (cdr board)))))

(define (all-jumps board)
  (filter identity
          (map (lambda (move) (jump board move))
               possibles)))

(define (solve init)
  (let loop ((k (- (length (car init)) 1))
             (boards (list init)))
    (if (zero? k) boards
      (loop (- k 1) (mappend all-jumps boards)))))

(let ((solutions (solve init)))
  (display (length solution)) (newline)
  (display (length (filter (lambda (x) (equal? (car x) '(1))) solutions))) (newline)
  (display (list-ref solutions 17493)) (newline))


Output:
1
Timeout


Create a new paste based on this one


Comments: