generate-and-test.lisp

;;; === Funkcia na generovaie n-tic ====

(defun gen2 (L &optional i)
  (if (null L)
      (list (reverse i))
    (mapcan
        (lambda (x) (gen2 (rest L) (cons x i)))
      (first L))))

;;; ==== Verzia 6 =====
(defun generuj-citac (&key ((:pocet-miest pm) 8) (start 0))
  (let ((citac (- start 1)) 
	(maximum (- (expt 10 pm) 1)) ;; napr. 999 zmenim na 1000 a - 1
	(zoznam-radov (mapcar #'(lambda (x) (expt 10 (- x 1))) ;; vytvara zoznam napr. list o velkosti 4: (1000 100 10 1)
			      (maplist #'length 
				       (make-list pm :initial-element 1)))))
    #'(lambda ()
	(incf citac)
	(if (> citac maximum)
	    nil
	    (mapcar #'(lambda (x) (mod (floor (/ citac x)) 10))
       zoznam-radov)))))

(defun testuj (kandidat &optional (poziadavka-roznosti t))
  (let ((y (first kandidat))
	(s (second kandidat))
	(e (third kandidat))
	(n (fourth kandidat))
	(d (fifth kandidat))
	(r (sixth kandidat))
	(o (seventh kandidat))
	(m 1))
    (and
     (or (not poziadavka-roznosti) (/= s e n d m o r y))     
     ;;(not (= m 0))
     (not (= s 0))
     (flet ((sucet-v-stlpci (prenos s1 s2)
	      (let ((x (+ prenos s1 s2)))
		(values (mod x 10) (floor (/ x 10))))))
       (multiple-value-bind (v1 p1) (sucet-v-stlpci 0 d e)
	 (multiple-value-bind (v2 p2) (sucet-v-stlpci p1 n r)
	   (multiple-value-bind (v3 p3) (sucet-v-stlpci p2 e o)
	     (multiple-value-bind (v4 p4) (sucet-v-stlpci p3 s m)
	       (and(= v1 y) (= v2 e) (= v3 n) (= v4 o) (= p4 m)))))))
     (list 's s 'e e 'n n 'd d 'm m 'o o 'r r 'y y))))

(defun ries ()
  (let ((generuj (generuj-citac :pocet-miest 7)))
    (labels ((hladaj ()
	       (do ((kandidat (funcall generuj) (funcall generuj)))
		   ((not kandidat) '(:riesenie :nema))
		 (let ((riesenie (testuj kandidat)))
		   (when riesenie (return-from hladaj riesenie))))))
      (format t "~{~a:  ~a~%~}" (hladaj)))))