Groups | Search | Server Info | Login | Register

Groups > comp.lang.lisp > #59398

Re: Mastermind Puzzle (3-digit Combination Lock) -- Elegant (readable) code Sought

Show all headers | View raw

* Paul Rubin <87a5nn1w58.fsf @nightsong.com> :
Wrote on Mon, 26 Feb 2024 00:12:51 -0800:
> HenHanna <HenHanna@gmail.com> writes:
>> Could you share a short, VERY Readable Pythonic (or Common Lisp,
>> Scheme) code that solves this?
>
> This is getting spammy.  It would have been preferable to cross post if
> you were going to ask for different languages.  (I posted a solution in
> comp.lang.python).  It's a cute puzzle but the basic approach is the
> same in any traditional language, more or less.  It would be more
> interesting to try something like Prolog where you'd use a built in
> constraint solver.

I got started on that, but gave up and brute forced it

> https://i.imgur.com/72LGJjj.jpeg
[682]: One number is correct and well-placed
[614]: One number is correct but wrongly placed
[206]: Two numbers are correct but wrongly placed
[738]: Nothing is correct
[780]: One number is correct but wrongly placed

- First was to come up with a notation to express these constraints.
A 3-tuple which can contain a number, or a constraint or a wildcard.

so "(6[^4].)" would be all 3 digit numbers with 6 at the first position,
not having 4 at the second position and any number ("."  is a wildcard)
in the third position.

Then the rules would be assembled into graph which would constrain any
generated numbers that fell through it.  On the other hand a checker
could be generated and compiled, since the search space is small enough.

(defun make-num-clause (n index)
  `(eql ,(ecase index
	   (1 'n1)
	   (2 'n2)
	   (3 'n3))
	,n))

(defun make-or-clause (clauses)
  `(or ,@clauses))

(defun make-and-clause (clauses)
  `(and ,@clauses))

(defun make-not-clause (clause)
  `(not ,clause))

(defun spec-item-reader (stream &optional subchar arg)
  (declare (ignorable subchar arg))
  (let ((i 0) c ret n (index 1))
    (setq c (read-char stream))
    (assert (eql c  #\())
    (incf i)
    (loop
     (cond ((setq n (digit-char-p (setq c (read-char stream))))
	    (push (make-num-clause n index) ret))
	   ((eql c #\.) t)		;wildcard
	   ((eql c #\))
	    (return (make-and-clause (nreverse ret))))
	   ((eql c #\[)
	    (incf i)
	    (cond ((eql (read-char stream i) #\^)
		   (incf i)
		   (let (clauses)
		     (loop
		      (cond ((eql (setq c (read-char stream)) #\])
			     (push (make-not-clause (make-or-clause (nreverse clauses))) ret)
			     (return))
			    (t (assert (setq n (digit-char-p c)))
			       (push (make-num-clause n index) clauses)
			       (incf i))))))
		  (t (let (clauses)
		       (loop
			(cond ((eql (setq c (read-char stream)) #\])
			       (push (make-or-clause (nreverse clauses)) ret)
			       (return))
			      (t (assert (setq n (digit-char-p c)))
				 (push (make-num-clause n index) clauses)
				 (incf i)))))))))
     (incf i)
     (incf index)
     (assert (not (> index 4))))))

(require 'named-readtables)
(named-readtables:defreadtable :henna-lock-spec-syntax
   (:merge :standard)
   (:dispatch-macro-char #\# #\? #'spec-item-reader))

(named-readtables:in-readtable :henna-lock-spec-syntax)

(defun ONE-OF (&rest list)
  (make-or-clause list))

(defun ALL-OF (&rest list)
  (make-and-clause list))

;;; then translate the list of constraints

;; (682): One number is correct and well-placed
(defvar $c1
  (ONE-OF '#?(6..) '#?(.8.) '#?(..2)))

;; (614): One number is correct but wrongly placed
(defvar $c2
  (ONE-OF (ONE-OF (ALL-OF '#?(.6.) '#?(.[^14].)) ;6 is correct
		  (ALL-OF '#?(..6) '#?(..[^14])))
	  (ONE-OF (ALL-OF '#?(1..) '#?([^46]..)) ;1 is correct
		  (ALL-OF '#?(..1) '#?(..[^46])))
	  (ONE-OF (ALL-OF '#?(4..) '#?([^16]..)) ;4 is corrcet
		  (ALL-OF '#?(.4.) '#?(.[^16].)))))

;; (206): Two numbers are correct but wrongly placed
(defvar $c3
  (ONE-OF (ONE-OF '#?(.20) '#?(02.) '#?(0.2)) ;; 2 & 0 are correct
	  (ONE-OF '#?(62.) '#?(6.2) '#?(.26)) ;; 2 & 6 are correct
	  (ONE-OF '#?(06.) '#?(6.0) '#?(.60)) ;; 0 & 6 are correct
		  ))

;; (738): Nothing is correct
(defvar $c4
  '#?([^738][^738][^783]))

;; (780): One number is correct but wrongly placed
(defvar $c5
  (ONE-OF (ONE-OF '#?(.7.) '#?(..7))  ;; 7 is correct
	  (ONE-OF '#?(8..) '#?(..8))  ;; 8 is correct
	  (ONE-OF '#?(0..) '#?(.0.))  ;; 0 is correct
	  ))

(defmacro defchecker ()
  `(defun checker (n1 n2 n3)
     ,(all-of $c1 $c2 $c3 $c4 $c5)))

(defchecker)

(defun check()
  (let (results)
    (loop for n1 from 0 below 10
	  do (loop for n2 from 0 below 10
		   do (loop for n3 from 1 below 10
			    if (checker n1 n2 n3)
			    do (push (list n1 n2 n3) results))))
    results))

=> ((0 6 2) (0 4 2))

took 41 microseconds (0.000041 seconds) to run.
During that period, and with 8 available CPU cores,
     41 microseconds (0.000041 seconds) were spent in user mode
      9 microseconds (0.000009 seconds) were spent in system mode
 128 bytes of memory allocated.

Back to comp.lang.lisp | Previous | Next — Previous in thread | Next in thread | Find similar

Thread

Mastermind Puzzle (3-digit Combination Lock) -- Elegant (readable) code Sought HenHanna <HenHanna@gmail.com> - 2024-02-25 20:30 -0800
  Re: Mastermind Puzzle (3-digit Combination Lock) -- Elegant (readable) code Sought Kaz Kylheku <433-929-6894@kylheku.com> - 2024-02-26 07:34 +0000
  Re: Mastermind Puzzle (3-digit Combination Lock) -- Elegant (readable) code Sought Paul Rubin <no.email@nospam.invalid> - 2024-02-26 00:12 -0800
    Re: Mastermind Puzzle (3-digit Combination Lock) -- Elegant (readable) code Sought Madhu <enometh@meer.net> - 2024-02-26 14:56 +0530
  Re: Mastermind Puzzle (3-digit Combination Lock) -- Elegant (readable) code Sought Kaz Kylheku <433-929-6894@kylheku.com> - 2024-02-26 18:24 +0000
  Re: Mastermind Puzzle (3-digit Combination Lock) -- Elegant (readable) code Sought steve <sgonedes1977@gmail.com> - 2024-04-20 16:25 -0400

csiph-web