(i just wrote (non-elegant) Python code.)

Could you share a short, VERY Readable Pythonic (or Common Lisp, Scheme)
code that solves this?

Thank you!

https://i.imgur.com/72LGJjj.jpeg

3 digit lock
[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

HINT -- A mark of a great puzzle, this one contains a surprise or two.

On 2024-02-26, HenHanna <HenHanna@gmail.com> wrote:
> 3 digit lock
> [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

$ txr lock.tl
(0 4 2)

Code in lock.tl:

(defmacro amb-scope (. forms)
^(block amb-scope ,*forms))

(defun amb (. args)
(suspend amb-scope cont
(each ((a args))
(whenlet ((res (and a (call cont a))))
(return-from amb-scope res)))))

(defsymacro all-ix #(0 1 2))

(defun well-placed (nc v1 v2 v3 n1 n2 n3)
(let ((ixs (perm all-ix 3))
(vv (vec v1 v2 v3))
(vn (vec n1 n2 n3)))
(some-true ((ix ixs))
(and (each-true ((i 0..nc))
(eql [vv [ix i]] [vn [ix i]]))
(each-false ((i nc..3))
(posql [vv [ix i]] vn))))))

(defun have-common (a b)
(some-true ((x a) (y b)) (eq x y)))

(defun badly-placed (nc v1 v2 v3 n1 n2 n3)
(let ((cixs (comb all-ix nc))
(pixs (perm all-ix nc))
(vv (vec v1 v2 v3))
(vn (vec n1 n2 n3)))
(some-true ((ix cixs))
(let ((oixs (remove-if (op have-common ix) pixs))
(nix (diff all-ix ix)))
(some-true ((oix oixs))
(and
(each-true ((i ix)
(j oix))
(eql [vv i] [vn j]))
(each-false ((i nix))
(posql [vv i] vn))))))))

(amb-scope
(let ((n1 (amb 0 1 2 3 4 5 6 7 8 9))
(n2 (amb 0 1 2 3 4 5 6 7 8 9))
(n3 (amb 0 1 2 3 4 5 6 7 8 9)))
(amb (well-placed 1 6 8 2 n1 n2 n3))
(amb (badly-placed 1 6 1 4 n1 n2 n3))
(amb (badly-placed 2 2 0 6 n1 n2 n3))
(amb (well-placed 0 7 3 8 n1 n2 n3))
(amb (badly-placed 1 7 8 0 n1 n2 n3))
(prinl ^(,n1 ,n2 ,n3))
nil))

> HINT -- A mark of a great puzzle, this one contains a surprise or two.

Indeed; since it contains no surprise, it must contain two,
which it does.

--
TXR Programming Language: http://nongnu.org/txr
Cygnal: Cygwin Native Application Library: http://kylheku.com/cygnal
Mastodon: @Kazinator@mstdn.ca

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.

* 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.

On 2024-02-26, HenHanna <HenHanna@gmail.com> wrote:
>
> (i just wrote (non-elegant) Python code.)
>
>
> Could you share a short, VERY Readable Pythonic (or Common Lisp, Scheme)
> code that solves this?

TXR Lisp, using scoring method:

(defun score (pat can)
(vec (sum-each ((p pat) (c can))
(if (eql p c) 1 0))
(len (isec pat can))))

(defun filt-score (pat ngoodpl nbadpl list)
(keep-if (op equal (score pat @1) (vec ngoodpl nbadpl)) list))

(flow "000".."999"
list-seq
(filt-score "682" 1 1)
(filt-score "614" 0 1)
(filt-score "206" 0 2)
;; surprises: these two not required
(filt-score "738" 0 0)
(filt-score "780" 0 1)
prinl)

$ txr lock2.tl
("042")

--
TXR Programming Language: http://nongnu.org/txr
Cygnal: Cygwin Native Application Library: http://kylheku.com/cygnal
Mastodon: @Kazinator@mstdn.ca

HenHanna <HenHanna@gmail.com> writes:

< (i just wrote (non-elegant) Python code.)
>
>
< Could you share a short, VERY Readable Pythonic (or Common Lisp, Scheme) code
< that solves this?
>
>
< Thank you!
>
< https://i.imgur.com/72LGJjj.jpeg
>
>
< 3 digit lock
< [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
>
>
< HINT -- A mark of a great puzzle, this one contains a surprise or two.

(in-tre "Table Example")
(rule-file "ex1")

(assert! '(on d table))
(assert! '(on e d))
(assert! '(on f e))
(rule ((on ?x table) (on ?y ?x) (on ?z ?y))
(rassert! (3-tower ?x ?y ?z))
(show-data))

* hint the rest of the code is more verbose *

=>

(PROGN
(DEFUN EX1-ON-?X-TABLE-BODY/2 (?X)
"Body procedure when pattern: |(ON ?X TABLE)| matches."
(INSERT-RULE *TRE* (GET-DBCLASS *TRE* 'ON)
#'(LAMBDA (P) (EX1-ON-?Y-?X-MATCHER/2 P ?X))
#'(LAMBDA (?Y) (EX1-ON-?Y-?X-BODY/2 ?Y ?X)) NIL))
(DEFUN EX1-ON-?X-TABLE-MATCHER/2 (P)
"Match procedure for pattern: |(ON ?X TABLE)|."
(WHEN
(AND (CONSP P) (EQ 'ON (CAR P)) (CONSP (CDR P)) (CONSP (CDR (CDR P)))
(EQ 'TABLE (CAR (CDR (CDR P)))) (NULL (CDR (CDR (CDR P)))))
(VALUES T (LIST (CAR (CDR P))))))
(DEFUN EX1-ON-?Y-?X-BODY/2 (?Y ?X)
"Body procedure when pattern: |(ON ?Y ?X)| matches."
(INSERT-RULE *TRE* (GET-DBCLASS *TRE* 'ON)
#'(LAMBDA (P) (EX1-ON-?Z-?Y-MATCHER/2 P ?Y ?X))
#'(LAMBDA (?Z) (EX1-ON-?Z-?Y-BODY/2 ?Z ?Y ?X)) NIL))
(DEFUN EX1-ON-?Y-?X-MATCHER/2 (P ?X)
"Match procedure for pattern: |(ON ?Y ?X)|."
(WHEN
(AND (CONSP P) (EQ 'ON (CAR P)) (CONSP (CDR P)) (CONSP (CDR (CDR P)))
(EQL ?X (CAR (CDR (CDR P)))) (NULL (CDR (CDR (CDR P)))))
(VALUES T (LIST (CAR (CDR P))))))
(DEFUN EX1-ON-?Z-?Y-BODY/2 (?Z ?Y ?X)
"Body procedure when pattern: |(ON ?Z ?Y)| matches."
(ASSERT! (CONS '3-TOWER (CONS ?X (CONS ?Y (CONS ?Z NIL)))))
(SHOW-DATA))
(DEFUN EX1-ON-?Z-?Y-MATCHER/2 (P ?Y ?X)
"Match procedure for pattern: |(ON ?Z ?Y)|."
(WHEN
(AND (CONSP P) (EQ 'ON (CAR P)) (CONSP (CDR P)) (CONSP (CDR (CDR P)))
(EQL ?Y (CAR (CDR (CDR P)))) (NULL (CDR (CDR (CDR P)))))
(VALUES T (LIST (CAR (CDR P))))))
(INSERT-RULE *TRE* (GET-DBCLASS *TRE* 'ON) #'EX1-ON-?X-TABLE-MATCHER/2
#'EX1-ON-?X-TABLE-BODY/2 NIL))

(show) =>

TRE> (show)
;; In global context:
;; Facts: (ON F E)
;; Facts: (ON E D)
;; Facts: (ON D TABLE)
;; 3 assertions in global context.
;; In global context:
;; Rule 1 (N): ON
;; Matcher: EX1-ON-?X-TABLE-MATCHER/2
;; (LAMBDA (P)
;; "Match procedure for pattern: |(ON ?X TABLE)|."
;; (BLOCK EX1-ON-?X-TABLE-MATCHER/2
;; (WHEN
;; (AND (CONSP P) (EQ 'ON (CAR P)) (CONSP (CDR P)) (CONSP (CDR (CDR P)))
;; (EQ 'TABLE (CAR (CDR (CDR P)))) (NULL (CDR (CDR (CDR P)))))
;; (VALUES T (LIST (CAR (CDR P)))))))
;;
;; Body: EX1-ON-?X-TABLE-BODY/2
;; (LAMBDA (?X)
;; "Body procedure when pattern: |(ON ?X TABLE)| matches."
;; (BLOCK EX1-ON-?X-TABLE-BODY/2
;; (INSERT-RULE *TRE* (GET-DBCLASS *TRE* 'ON) #'(LAMBDA (P) (EX1-ON-?Y-?X-MATCHER/2 P ?X))
;; #'(LAMBDA (?Y) (EX1-ON-?Y-?X-BODY/2 ?Y ?X)) NIL)))
;;
;; 1 global rule.

TRE> (run-rules *tre*)

;; insert-new fact: (3-TOWER D E F)
;; In global context:
;; Facts: (ON F E)
;; Facts: (ON E D)
;; Facts: (ON D TABLE)
;; Facts: (3-TOWER D E F)
;; 4 assertions in global context.
;; Table Example(0): 3 rules run.
NIL
TRE>

TRE> (show)
;; In global context:
;; Facts: (ON F E)
;; Facts: (ON E D)
;; Facts: (ON D TABLE)
;; Facts: (3-TOWER D E F)
;; 4 assertions in global context.
;; In global context:
;; Rule 1 (N): ON
;; Matcher: EX1-ON-?X-TABLE-MATCHER/2
;; (LAMBDA (P)
;; "Match procedure for pattern: |(ON ?X TABLE)|."
;; (BLOCK EX1-ON-?X-TABLE-MATCHER/2
;; (WHEN
;; (AND (CONSP P) (EQ 'ON (CAR P)) (CONSP (CDR P)) (CONSP (CDR (CDR P)))
;; (EQ 'TABLE (CAR (CDR (CDR P)))) (NULL (CDR (CDR (CDR P)))))
;; (VALUES T (LIST (CAR (CDR P)))))))
;;
;; Body: EX1-ON-?X-TABLE-BODY/2
;; (LAMBDA (?X)
;; "Body procedure when pattern: |(ON ?X TABLE)| matches."
;; (BLOCK EX1-ON-?X-TABLE-BODY/2
;; (INSERT-RULE *TRE* (GET-DBCLASS *TRE* 'ON) #'(LAMBDA (P) (EX1-ON-?Y-?X-MATCHER/2 P ?X))
;; #'(LAMBDA (?Y) (EX1-ON-?Y-?X-BODY/2 ?Y ?X)) NIL)))
;;
;; Rule 2 (N): ON
;; Matcher: (LAMBDA (P) IN EX1-ON-?X-TABLE-BODY/2)
;; (LAMBDA (P) (EX1-ON-?Y-?X-MATCHER/2 P ?X))
;;
;; Body: (LAMBDA (?Y) IN EX1-ON-?X-TABLE-BODY/2)
;; (LAMBDA (?Y) (EX1-ON-?Y-?X-BODY/2 ?Y ?X))
;;
;; Rule 3 (N): ON
;; Matcher: (LAMBDA (P) IN EX1-ON-?Y-?X-BODY/2)
;; (LAMBDA (P) (EX1-ON-?Z-?Y-MATCHER/2 P ?Y ?X))
;;
;; Body: (LAMBDA (?Z) IN EX1-ON-?Y-?X-BODY/2)
;; (LAMBDA (?Z) (EX1-ON-?Z-?Y-BODY/2 ?Z ?Y ?X))
;;
;; 3 global rules.
3 TRE>

? close? old rule system from xerox called tre. see building problem
solvers.