Solution to Drive Ya Nuts Puzzle

drive_ya_nuts.scm

#!/usr/bin/guile -s
!#
;solution to Drive Ya Nuts http://www.samstoybox.com/toys/DriveYaNuts.html

(use-modules (ice-9 format))

(define nut (lambda (numbers)
  (define center -1) 
  (define position 0)
  (define get-numbers (lambda () numbers))
  (define get-center (lambda () center))
  (define get-position (lambda () position))
  (define get-left (lambda () (if (= center -1) -1 (value-left-of-center center))))
  (define get-right (lambda () (if (= center -1) -1 (value-right-of-center center))))
  (define set-center (lambda (new-center) (set! center new-center)))
  (define set-position (lambda (new-position) (set! position new-position)))
  (define has-right? (lambda (test-right)
    (= (value-right-of-center center) test-right)
  ))
  (define has-right-and-left? (lambda (test-right test-left) 
    (and (= (value-left-of-center center) test-left) (= (value-right-of-center center) test-right))
  ))
  (define value-left-of-center (lambda (center-value)
    (define left-position (- (position-for-value center-value) 1))
    (set! left-position (if (< left-position 0) 5 left-position))
    (value-for-position left-position)
  ))
  (define value-right-of-center (lambda (center-value)
    (define right-position (+ (position-for-value center-value) 1))
    (set! right-position (if (> right-position 5) 0 right-position))
    (value-for-position right-position)
  ))
  (define position-for-value (lambda (value)
      (car (car (filter (lambda (number)
        (= (car (cdr number)) value)) (get-numbers))))
  ))
  (define value-for-position (lambda (position)
      (car (cdr (car (filter (lambda (number)
        (= (car number) position)) (get-numbers)))))
  ))
  (define eql? (lambda (test-nut)
    (equal? numbers (test-nut `(get-numbers))) 
  ))
  (define print (lambda ()
    (write (format "~d ~d ~d ~d ~a" position center (get-left) (get-right) numbers))(newline)
  ))
  (lambda (args)
    (apply
      (case (car args)
        ((get-numbers) get-numbers)
        ((get-center) get-center)
        ((get-position) get-position)
        ((set-center) set-center)
        ((set-position) set-position)
        ((get-left) get-left)
        ((get-right) get-right)
        ((has-right?) has-right?)
        ((has-right-and-left?) has-right-and-left?)
        ((value-left-of-center) value-left-of-center)
        ((value-right-of-center) value-right-of-center)
        ((position-for-value) position-for-value)
        ((value-for-position) value-for-position)
        ((print) print)
        ((eql?) eql?))
      (cdr args)))
))

(define nut-from-nut (lambda (nut-to-copy position center)
  (define new-nut (nut (nut-to-copy `(get-numbers))))
  (new-nut (list `set-position position))
  (new-nut (list `set-center center))
  new-nut
))

(define nut-list (list
  (nut (list (list 0 1) (list 1 4) (list 2 6) (list 3 2)  (list 4 3) (list 5 5)))
  (nut (list (list 0 1) (list 1 6) (list 2 2) (list 3 4)  (list 4 5) (list 5 3)))
  (nut (list (list 0 1) (list 1 2) (list 2 3) (list 3 4)  (list 4 5) (list 5 6)))
  (nut (list (list 0 1) (list 1 6) (list 2 4) (list 3 2)  (list 4 5) (list 5 3)))
  (nut (list (list 0 1) (list 1 4) (list 2 3) (list 3 6)  (list 4 5) (list 5 2)))
  (nut (list (list 0 1) (list 1 6) (list 2 5) (list 3 3)  (list 4 2) (list 5 4)))
  (nut (list (list 0 1) (list 1 6) (list 2 5) (list 3 4)  (list 4 3) (list 5 2)))))
    
(define place-nut (lambda (nut-to-place unused-nuts used-nuts)
  (cond 
    ((null? used-nuts) (place-first-nut nut-to-place unused-nuts used-nuts))
    ((= 1 (length used-nuts)) (place-second-nut nut-to-place unused-nuts used-nuts))
    (else (place-other-nuts nut-to-place unused-nuts used-nuts)))
))

(define place-first-nut (lambda (nut-to-place unused-nuts used-nuts)
  (puzzle unused-nuts (append used-nuts (list (nut-from-nut nut-to-place 0 -1))))
))

(define place-second-nut (lambda (nut-to-place unused-nuts used-nuts)
  (puzzle unused-nuts (append used-nuts (list (nut-from-nut nut-to-place 1 1))))
))

(define place-other-nuts (lambda (nut-to-place unused-nuts used-nuts)
  (cond
    ((= 0 (length unused-nuts)) (place-final-nut nut-to-place unused-nuts used-nuts))
  (else (try-to-place-nut-or-fail nut-to-place unused-nuts used-nuts)))
))

(define try-to-place-nut-or-fail (lambda (nut-to-place unused-nuts used-nuts)
  (define right (expected-nut-right used-nuts))
  (define test-nut (nut-from-nut nut-to-place (- (length used-nuts) 1) (expected-nut-center used-nuts)))
  (cond 
    ((test-nut (list `has-right? right)) (puzzle unused-nuts (append used-nuts (list test-nut))))
  (else (write "NO SOLUTION")(newline)))
))

(define place-final-nut (lambda (nut-to-place unused-nuts used-nuts)
  (define left (expected-nut-left used-nuts))
  (define right (expected-nut-right used-nuts))
  (define test-nut (nut-from-nut nut-to-place (- (length used-nuts) 1) (expected-nut-center used-nuts)))
  (if (test-nut (list `has-right-and-left? right left))
    (solution-found (append used-nuts (list test-nut))))
))

(define solution-found (lambda (used-nuts)
  (write "SOLUTION FOUND")(newline)
  (print-nut used-nuts)
))

(define print-nut (lambda (nut-list)
  (map (lambda (n) (n `(print))) nut-list)
))

(define expected-nut-center (lambda (used-nuts)
  (define current-position (- (length used-nuts) 1))
  ((car used-nuts) (list `value-for-position current-position))
))

(define expected-nut-right (lambda (used-nuts)
  (define current-position (- (length used-nuts) 1))
  ((list-ref used-nuts current-position) `(get-left))
))

(define expected-nut-left (lambda (used-nuts)
  ((list-ref used-nuts 1) `(get-right))
))

(define puzzle (lambda (unused-nuts used-nuts)
  (for-each (lambda (nut-to-place)
    (place-nut nut-to-place (delete nut-to-place unused-nuts) used-nuts)
  ) unused-nuts)
))

(puzzle nut-list (list))