Topic: -={ Challenge }=- 24 point games or Math24

[qjchen]

https://en.wikipedia.org/wiki/Maths24#Combinations

I often play this game by cards game. That means use + - * / and  ( ) to calculate four card's number into 24. Just like

For 2,5,5,7=>((2x7)+5)+5

For 5,5,6,6=>((5+5)-6)x6

The rules is Given four number (In a poker game, it can be four cards, A stand for one, 2,3,4,5,6,7,8,9,10 for each number, and J for 11, Q for 12, K for 13), and then Cards are solved by using the numbers, applying only the addition, subtraction, multiplication and division operations to achieve a final mathematical solution of 24.

All four numbers must be included. The numbers can only be used once. No other mathematical operations are allowed.

Yesterday, I wrote some codes to finish it. But I think there are so many clever Lispers in theswamp, so now I post it here and I hope there are many better codes appear.

The challenge:
------------------------------------------------------
(defun c:test (/ lst)
  (setq   lst  (list a b c d))
.......
(princ the solution)
)
--------------------------------------------------------

where a b c d can be any int number or they can be limited to cards game (from 1 to 13).

The results can be duplicate. just like this:
Command: test
a:2
b:3
c:4
d:5
((* (- 5.0 (- 2.0 3.0)) 4.0) . 24.0)
((* (+ (- 3.0 2.0) 5.0) 4.0) . 24.0)
........

[new_mem]

Maybe

(setq a (getreal "\n Select a: "))
  (setq b (getreal "\n Select b: "))
  (setq c (getreal "\n Select c: "))
  (setq d (getreal "\n Select d: "))
  (setq   lst  (list a b c d))

......
^_^

[snownut2]

Maybe

(setq a (getreal "\n Select a: "))
  (setq b (getreal "\n Select b: "))
  (setq c (getreal "\n Select c: "))
  (setq d (getreal "\n Select d: "))
  (setq   lst  (list a b c d))

......
^_^

I'm thinking it needs to be 4 randomly choosen (by computer) cards out of a deck of playing cards, whose options are constantly changing to cards already delt...

[qjchen]

Maybe

(setq a (getreal "\n Select a: "))
  (setq b (getreal "\n Select b: "))
  (setq c (getreal "\n Select c: "))
  (setq d (getreal "\n Select d: "))
  (setq   lst  (list a b c d))

......
^_^

I'm thinking it needs to be 4 randomly choosen (by computer) cards out of a deck of playing cards, whose options are constantly changing to cards already delt...

Thank you new_mem and snownut2 for reply. Your suggestions is very good. It is better to use user input or computer random input.

But maybe at the first step, just now only solution is need, and I think it is not too hard to improve it to a good Lisp game

[new_mem]

Sorry i don't understand the rule  math24 .

Can u tell me ?

[qjchen]

Sorry i don't understand the rule  math24 .

Can u tell me ?

The rules is like so: Given four number (In a poker game, it can be four cards, A stand for one, 2,3,4,5,6,7,8,9,10 for each number, and J for 11, Q for 12, K for 13), and then Cards are solved by using the numbers, applying only the addition, subtraction, multiplication and division operations to achieve a final mathematical solution of 24.

All four numbers must be included. The numbers can only be used once. No other mathematical operations are allowed.

It is illustrated more carefully in https://en.wikipedia.org/wiki/Maths24#Rules.

Thank you for your participation.

[Lee Mac]

A basic brute-force method:

Code - Auto/Visual Lisp: [Select]

1. (defun LM:math24 ( a b c d )
2.     (vl-remove-if-not '(lambda ( x ) (equal 24.0 (eval x) 1e-8))
3.         (apply 'append
4.             (mapcar
5.                '(lambda ( a )
6.                     (mapcar '(lambda ( b ) (-formulate- b (car a) (cdr a))) (-operators-))
7.                 )
8.                 (   (lambda ( npr ) (npr (mapcar 'float (list a b c d)) 4))
9.                     (lambda ( l r )
10.                         (if (< r 2)
11.                             (mapcar 'list l)
12.                             (apply 'append (mapcar '(lambda ( a ) (mapcar '(lambda ( b ) (cons a b)) (npr (-remove1st- a l) (1- r)))) l))
13.                         )
14.                     )
15.                 )
16.             )
17.         )
18.     )
19. )
20.  
21. (defun -formulate- ( o x l )
22.     (if (and o l) (-formulate- (cdr o) (list (car o) x (car l)) (cdr l)) x)
23. )
24.  
25. (defun -remove1st- ( x l )
26.     (cond
27.         (   (not l) nil)
28.         (   (equal x (car l)) (cdr l))
29.         (   (cons (car l) (-remove1st- x (cdr l))))
30.     )
31. )
32.    
33. (defun -operators- nil
34.     (eval
35.         (list 'defun '-operators- 'nil
36.             (list 'quote
37.                 (   (lambda ( npr ) (npr '(+ - * /) 3))
38.                     (lambda ( l r )
39.                         (if (< r 2)
40.                             (mapcar 'list l)
41.                             (apply 'append (mapcar '(lambda ( a ) (mapcar '(lambda ( b ) (cons a b)) (npr l (1- r)))) l))
42.                         )
43.                     )
44.                 )
45.             )
46.         )
47.     )
48.     (-operators-)
49. )

Example:

Code - Auto/Visual Lisp: [Select]

1. _$ (LM:math24 2 3 4 5)
2. (
3.     (* (+ (- 3.0 2.0) 5.0) 4.0)
4.     (* (+ (+ 3.0 4.0) 5.0) 2.0)
5.     (* (- (+ 3.0 5.0) 2.0) 4.0)
6.     (* (+ (+ 3.0 5.0) 4.0) 2.0)
7.     (* (+ (+ 4.0 3.0) 5.0) 2.0)
8.     (* (+ (+ 4.0 5.0) 3.0) 2.0)
9.     (* (+ (- 5.0 2.0) 3.0) 4.0)
10.     (* (- (+ 5.0 3.0) 2.0) 4.0)
11.     (* (+ (+ 5.0 3.0) 4.0) 2.0)
12.     (* (+ (+ 5.0 4.0) 3.0) 2.0)
13. )

[qjchen]

Hi, Lee Mac, thank you very much for your participation. Sorry for my late reply, I just see your code after one day of tired working.

It is a great code, but I found that in some case it can not get a result.

Just like,  for (1 1 5 7) we can do it as (* (+ 1 1) (+ 5 7)) but your code get a nil result.

Furthermore,  just for some special case, just like (4 4 7 7) it can has such answer (* (- 4 (/ 4 7)) 7) and your code get a nil results too.  [Because in some 24 point games, no fraction result or expression is allowed, but I hope that it can be also allowed in this code]

Your code is very beautiful and I am sure it is easy for you to make it works under these two cases also.

Thanks again.

[Lee Mac]

Thank you qjchen for your feedback, I appreciate your compliments for my code and thank you for pointing out its deficiencies.

The following should address your second point (though the code is becoming increasingly inefficient):

Code - Auto/Visual Lisp: [Select]

1. (defun LM:math24 ( a b c d )
2.     (-unique-
3.         (vl-remove-if
4.            '(lambda ( x / r )
5.                 (or (vl-catch-all-error-p (setq r (vl-catch-all-apply 'eval (list x))))
6.                     (not (equal 24.0 r 1e-8))
7.                 )
8.             )
9.             (apply 'append
10.                 (mapcar
11.                    '(lambda ( a )
12.                         (apply 'append
13.                             (mapcar '(lambda ( b ) (-formulate- b (car a) (cdr a))) (-operators-))
14.                         )
15.                     )
16.                     (   (lambda ( npr ) (-unique- (npr (mapcar 'float (list a b c d)) 4)))
17.                         (lambda ( l r )
18.                             (if (< r 2)
19.                                 (mapcar 'list l)
20.                                 (apply 'append (mapcar '(lambda ( a ) (mapcar '(lambda ( b ) (cons a b)) (npr (-remove1st- a l) (1- r)))) l))
21.                             )
22.                         )
23.                     )
24.                 )
25.             )
26.         )
27.     )
28. )
29.  
30. (defun -formulate- ( o x l )
31.     (if (and o l)
32.         (if (member (car o) '(- /))
33.             (append
34.                 (-formulate- (cdr o) (list (car o) x (car l)) (cdr l))
35.                 (-formulate- (cdr o) (list (car o) (car l) x) (cdr l))
36.             )
37.             (-formulate- (cdr o) (list (car o) x (car l)) (cdr l))
38.         )
39.         (list x)
40.     )
41. )
42.  
43. (defun -remove1st- ( x l )
44.     (cond
45.         (   (not l) nil)
46.         (   (equal x (car l)) (cdr l))
47.         (   (cons (car l) (-remove1st- x (cdr l))))
48.     )
49. )
50.  
51. (defun -unique- ( l )
52.     (if l (cons (car l) (-unique- (vl-remove-if '(lambda ( x ) (equal x (car l))) (cdr l)))))
53. )        
54.  
55. (defun -operators- nil
56.     (eval
57.         (list 'defun '-operators- 'nil
58.             (list 'quote
59.                 (   (lambda ( npr ) (npr '(+ - * /) 3))
60.                     (lambda ( l r )
61.                         (if (< r 2)
62.                             (mapcar 'list l)
63.                             (apply 'append (mapcar '(lambda ( a ) (mapcar '(lambda ( b ) (cons a b)) (npr l (1- r)))) l))
64.                         )
65.                     )
66.                 )
67.             )
68.         )
69.     )
70.     (-operators-)
71. )

[Lee Mac]

The following should address the case of 1,1,5,7:

Code - Auto/Visual Lisp: [Select]

1. (defun LM:math24 ( a b c d )
2.     (-unique-
3.         (vl-remove-if
4.            '(lambda ( x / r )
5.                 (or (vl-catch-all-error-p (setq r (vl-catch-all-apply 'eval (list x))))
6.                     (not (equal 24.0 r 1e-8))
7.                 )
8.             )
9.             (apply 'append
10.                 (mapcar
11.                    '(lambda ( a )
12.                         (apply 'append
13.                             (mapcar '(lambda ( b ) (-formulate- b (car a) (cdr a))) (-operators-))
14.                         )
15.                     )
16.                     (   (lambda ( npr ) (-unique- (npr (mapcar 'float (list a b c d)) 4)))
17.                         (lambda ( l r )
18.                             (if (< r 2)
19.                                 (mapcar 'list l)
20.                                 (apply 'append (mapcar '(lambda ( a ) (mapcar '(lambda ( b ) (cons a b)) (npr (-remove1st- a l) (1- r)))) l))
21.                             )
22.                         )
23.                     )
24.                 )
25.             )
26.         )
27.     )
28. )
29.  
30. (defun -formulate- ( o x l )
31.     (   (lambda ( foo ) (cons (list (car o) (list (cadr o) x (car l)) (list (caddr o) (cadr l) (caddr l))) (foo o x l)))
32.         (lambda ( o x l )
33.             (if (and o l)
34.                 (if (member (car o) '(- /))
35.                     (append
36.                         (foo (cdr o) (list (car o) x (car l)) (cdr l))
37.                         (foo (cdr o) (list (car o) (car l) x) (cdr l))
38.                     )
39.                     (foo (cdr o) (list (car o) x (car l)) (cdr l))
40.                 )
41.                 (list x)
42.             )
43.         )
44.     )
45. )
46.  
47. (defun -remove1st- ( x l )
48.     (cond
49.         (   (not l) nil)
50.         (   (equal x (car l)) (cdr l))
51.         (   (cons (car l) (-remove1st- x (cdr l))))
52.     )
53. )
54.  
55. (defun -unique- ( l )
56.     (if l (cons (car l) (-unique- (vl-remove-if '(lambda ( x ) (equal x (car l))) (cdr l)))))
57. )        
58.  
59. (defun -operators- nil
60.     (eval
61.         (list 'defun '-operators- 'nil
62.             (list 'quote
63.                 (   (lambda ( npr ) (npr '(+ - * /) 3))
64.                     (lambda ( l r )
65.                         (if (< r 2)
66.                             (mapcar 'list l)
67.                             (apply 'append (mapcar '(lambda ( a ) (mapcar '(lambda ( b ) (cons a b)) (npr l (1- r)))) l))
68.                         )
69.                     )
70.                 )
71.             )
72.         )
73.     )
74.     (-operators-)
75. )

[qjchen]

Thank you very much Lee Mac, your last code (#9) can solve all the question.  You are always a Lisp Master.

The following is my code now. But your code are much elegant than mine. I will also try my best to make some improvement. My code doesnt deal with the duplicate, I also need to improve.

I am also hoping other friend to take part in.

Code - Auto/Visual Lisp: [Select]

1. (defun x&y (x y x1 y1)
2.   (list (cons (cons '+ (list x1 y1)) (+ x y))(cons (cons '- (list x1 y1)) (- x y))(cons (cons '- (list y1 x1)) (- y x))
3.         (cons (cons '* (list x1 y1)) (* x y))(cons (cons '/ (list x1 y1)) (if (eq y 0) 1e10 (/ x y) ) )(cons (cons '/ (list y1 x1)) (if (eq x 0) 1e10 (/ y x) ) )
4.   )
5. )
6. (defun c:test (/ l1 l2  lst lst1 pub ress seq0 seq1 x x0 x2 xinl1 xinl2 xinseq1)
7.   (setq lst  (list (getreal "\na:")(getreal "\nb:")(getreal "\nc:")(getreal "\nd:")) ress nil)
8.   (setq seq0 (list (list '(0 1) 2 3) (list '(0 2) 1 3) (list '(0 3) 1 2) (list '(1 2) 0 3) (list '(1 3) 0 2) (list '(2 3) 0 1)))
9.   (foreach x0 seq0
10.    (setq l1 (x&y (nth (car (car x0)) lst) (nth (cadr (car x0)) lst) (nth (car (car x0)) lst) (nth (cadr (car x0)) lst) ) seq1 (list (list 1 2) (list 2 1)))
11.    (foreach xinseq1 seq1
12.       (foreach xinl1 l1
13.         (setq lst1 (x&y (cdr xinl1) (nth (nth (car xinseq1) x0) lst) (car xinl1) (nth (nth (car xinseq1) x0) lst)))
14.         (foreach x2 lst1
15.          (setq pub (x&y (cdr x2) (nth (nth (cadr xinseq1) x0) lst) (car x2) (nth (nth (cadr xinseq1) x0) lst)) ress (append ress pub))
16.         )
17.       )
18.    )
19.    (setq l2 (x&y (nth (cadr x0) lst) (nth (caddr x0) lst) (nth (cadr x0) lst) (nth (caddr x0) lst)))
20.    (foreach xinl1 l1
21.     (foreach xinl2 l2
22.       (setq pub (x&y (cdr xinl1) (cdr xinl2) (car xinl1) (car xinl2)) ress (append ress pub))
23.     )
24.    )
25.   )
26.   (foreach x ress
27.     (if (eq (cdr x) 24.0) (progn (princ x) (princ "\n")))
28.   )
29. )
30.  

[squirreldip]

Here's another using and evaluating strings:

Code: [Select]

(defun RFL:MATH24 (NUMLIST / A B C D FCTN FCTN1 FCTN2 FCTN3 FCTN4 RES STR)
 (defun FCTN (STR) (eval (read STR)))
 (foreach A '(0 1 2 3)
  (foreach B '(0 1 2 3)
   (if (/= A B)
    (foreach C '(0 1 2 3)
     (if (and (/= C B) (/= C A))
      (foreach D '(0 1 2 3)
       (if (and (/= D C) (/= D B) (/= D A))
        (foreach FCTN3 (list "+" "-" "*" "/")
         (foreach FCTN2 (list "+" "-" "*" "/")
          (foreach FCTN1 (list "+" "-" "*" "/")
           (setq STR (strcat "(" FCTN1 " " (rtos (nth A NUMLIST)) " (" FCTN2 " " (rtos (nth B NUMLIST)) " (" FCTN3 " " (rtos (nth C NUMLIST)) " " (rtos (nth D NUMLIST)) ")))"))
           (setq RES (vl-catch-all-apply 'FCTN (list STR)))
           (if (and (not (vl-catch-all-error-p RES)) (= RES 24)) (print STR))
          )
         )
        )
       )
      )
     )
    )
   )
  )
 )
 (print "Done!")
)
(rfl:math24 (list 2 3 4 5))

Code: [Select]

"(* 2.0 (+ 3.0 (+ 4.0 5.0)))"
"(* 2.0 (+ 3.0 (+ 5.0 4.0)))"
"(* 2.0 (+ 4.0 (+ 3.0 5.0)))"
"(* 2.0 (+ 4.0 (+ 5.0 3.0)))"
"(* 2.0 (+ 5.0 (+ 3.0 4.0)))"
"(* 2.0 (+ 5.0 (+ 4.0 3.0)))"
"(* 4.0 (- 3.0 (- 2.0 5.0)))"
"(* 4.0 (+ 3.0 (- 5.0 2.0)))"
"(* 4.0 (- 5.0 (- 2.0 3.0)))"
"(* 4.0 (+ 5.0 (- 3.0 2.0)))"
"Done!"

[qjchen]

Thank you squirreldip!

It is a very good way to get the result of  this type of solution: "(* 2.0 (+ 3.0 (+ 4.0 5.0)))"

However, for some case, just like  (1, 1, 5, 5), it can also be solved by

(* (+ 1.0 5.0) (- 5.0 1.0))    or

(- (* (* 1.0 5.0) 5.0) 1.0)

but your code show nil result.

Could you please add some codes to make all of them also be solved?

Thank you very much.