Author Topic: SUDOKU Challenge  (Read 11895 times)

0 Members and 1 Guest are viewing this topic.

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
SUDOKU Challenge
« on: October 20, 2017, 11:29:06 AM »
I am lost somewhere... John's one works : link here : http://www.ic.unicamp.br/~meidanis/courses/mc336/2006s2/funcional/L-99_Ninety-Nine_Lisp_Problems.html

But the other one from newspaper should be solvable, but I am lost in the woods...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:sudoku-mr ( / rcs solve solve-adv check v r i j f fl fll flll fllll mm fffl fff ff fi fj x z loop )
  2.  
  3.   (defun rcs ( m i j / r c s )
  4.     (setq r (nth (1- i) m))
  5.     (setq c (nth (1- j) (apply 'mapcar (cons 'list m))))
  6.     (setq s
  7.       (cond
  8.         ( (and (<= 1 i 3) (<= 1 j 3))
  9.           (list (nth 0 (nth 0 m)) (nth 1 (nth 0 m)) (nth 2 (nth 0 m)) (nth 0 (nth 1 m)) (nth 1 (nth 1 m)) (nth 2 (nth 1 m)) (nth 0 (nth 2 m)) (nth 1 (nth 2 m)) (nth 2 (nth 2 m)))
  10.         )
  11.         ( (and (<= 1 i 3) (<= 4 j 6))
  12.           (list (nth 3 (nth 0 m)) (nth 4 (nth 0 m)) (nth 5 (nth 0 m)) (nth 3 (nth 1 m)) (nth 4 (nth 1 m)) (nth 5 (nth 1 m)) (nth 3 (nth 2 m)) (nth 4 (nth 2 m)) (nth 5 (nth 2 m)))
  13.         )
  14.         ( (and (<= 1 i 3) (<= 7 j 9))
  15.           (list (nth 6 (nth 0 m)) (nth 7 (nth 0 m)) (nth 8 (nth 0 m)) (nth 6 (nth 1 m)) (nth 7 (nth 1 m)) (nth 8 (nth 1 m)) (nth 6 (nth 2 m)) (nth 7 (nth 2 m)) (nth 8 (nth 2 m)))
  16.         )
  17.  
  18.         ( (and (<= 4 i 6) (<= 1 j 3))
  19.           (list (nth 0 (nth 3 m)) (nth 1 (nth 3 m)) (nth 2 (nth 3 m)) (nth 0 (nth 4 m)) (nth 1 (nth 4 m)) (nth 2 (nth 4 m)) (nth 0 (nth 5 m)) (nth 1 (nth 5 m)) (nth 2 (nth 5 m)))
  20.         )
  21.         ( (and (<= 4 i 6) (<= 4 j 6))
  22.           (list (nth 3 (nth 3 m)) (nth 4 (nth 3 m)) (nth 5 (nth 3 m)) (nth 3 (nth 4 m)) (nth 4 (nth 4 m)) (nth 5 (nth 4 m)) (nth 3 (nth 5 m)) (nth 4 (nth 5 m)) (nth 5 (nth 5 m)))
  23.         )
  24.         ( (and (<= 4 i 6) (<= 7 j 9))
  25.           (list (nth 6 (nth 3 m)) (nth 7 (nth 3 m)) (nth 8 (nth 3 m)) (nth 6 (nth 4 m)) (nth 7 (nth 4 m)) (nth 8 (nth 4 m)) (nth 6 (nth 5 m)) (nth 7 (nth 5 m)) (nth 8 (nth 5 m)))
  26.         )
  27.  
  28.         ( (and (<= 7 i 9) (<= 1 j 3))
  29.           (list (nth 0 (nth 6 m)) (nth 1 (nth 6 m)) (nth 2 (nth 6 m)) (nth 0 (nth 7 m)) (nth 1 (nth 7 m)) (nth 2 (nth 7 m)) (nth 0 (nth 8 m)) (nth 1 (nth 8 m)) (nth 2 (nth 8 m)))
  30.         )
  31.         ( (and (<= 7 i 9) (<= 4 j 6))
  32.           (list (nth 3 (nth 6 m)) (nth 4 (nth 6 m)) (nth 5 (nth 6 m)) (nth 3 (nth 7 m)) (nth 4 (nth 7 m)) (nth 5 (nth 7 m)) (nth 3 (nth 8 m)) (nth 4 (nth 8 m)) (nth 5 (nth 8 m)))
  33.         )
  34.         ( (and (<= 7 i 9) (<= 7 j 9))
  35.           (list (nth 6 (nth 6 m)) (nth 7 (nth 6 m)) (nth 8 (nth 6 m)) (nth 6 (nth 7 m)) (nth 7 (nth 7 m)) (nth 8 (nth 7 m)) (nth 6 (nth 8 m)) (nth 7 (nth 8 m)) (nth 8 (nth 8 m)))
  36.         )
  37.       )
  38.     )
  39.     (list r c s)
  40.   )
  41.  
  42.   (defun solve ( m i j / v r c s rn cn sn nn )
  43.     (setq v '(1 2 3 4 5 6 7 8 9))
  44.     (mapcar 'set '(r c s) (rcs m i j))
  45.     (setq nn (vl-remove-if '(lambda ( x ) (vl-position x s)) v))
  46.     (setq nn (vl-remove-if '(lambda ( x ) (vl-position x r)) nn))
  47.     (setq nn (vl-remove-if '(lambda ( x ) (vl-position x c)) nn))
  48.     (vl-sort nn '<)
  49.   )
  50.  
  51.   (defun solve-adv ( m i j / nn ii jj x gx rfs cfs sfs rfsg cfsg sfsg )
  52.     (setq nn (solve m i j))
  53.     (setq jj 0)
  54.     (setq rfs (vl-remove nil (mapcar '(lambda ( x ) (setq jj (1+ jj)) (if (null x) (read (strcat "f" (itoa i) (itoa jj))))) r)))
  55.     (setq ii 0)
  56.     (setq cfs (vl-remove nil (mapcar '(lambda ( x ) (setq ii (1+ ii)) (if (null x) (read (strcat "f" (itoa ii) (itoa j))))) c)))
  57.     (setq sfs (vl-remove nil
  58.       (cond
  59.         ( (and (<= 1 i 3) (<= 1 j 3))
  60.           (list (if (numberp (nth 0 (nth 0 m))) nil (read "f11")) (if (numberp (nth 1 (nth 0 m))) nil (read "f12")) (if (numberp (nth 2 (nth 0 m))) nil (read "f13")) (if (numberp (nth 0 (nth 1 m))) nil (read "f21")) (if (numberp (nth 1 (nth 1 m))) nil (read "f22")) (if (numberp (nth 2 (nth 1 m))) nil (read "f23")) (if (numberp (nth 0 (nth 2 m))) nil (read "f31")) (if (numberp (nth 1 (nth 2 m))) nil (read "f32")) (if (numberp (nth 2 (nth 2 m))) nil (read "f33")))
  61.         )
  62.         ( (and (<= 1 i 3) (<= 4 j 6))
  63.           (list (if (numberp (nth 3 (nth 0 m))) nil (read "f14")) (if (numberp (nth 4 (nth 0 m))) nil (read "f15")) (if (numberp (nth 5 (nth 0 m))) nil (read "f16")) (if (numberp (nth 3 (nth 1 m))) nil (read "f24")) (if (numberp (nth 4 (nth 1 m))) nil (read "f25")) (if (numberp (nth 5 (nth 1 m))) nil (read "f26")) (if (numberp (nth 3 (nth 2 m))) nil (read "f34")) (if (numberp (nth 4 (nth 2 m))) nil (read "f35")) (if (numberp (nth 5 (nth 2 m))) nil (read "f36")))
  64.         )
  65.         ( (and (<= 1 i 3) (<= 7 j 9))
  66.           (list (if (numberp (nth 6 (nth 0 m))) nil (read "f17")) (if (numberp (nth 7 (nth 0 m))) nil (read "f18")) (if (numberp (nth 8 (nth 0 m))) nil (read "f19")) (if (numberp (nth 6 (nth 1 m))) nil (read "f27")) (if (numberp (nth 7 (nth 1 m))) nil (read "f28")) (if (numberp (nth 8 (nth 1 m))) nil (read "f29")) (if (numberp (nth 6 (nth 2 m))) nil (read "f37")) (if (numberp (nth 7 (nth 2 m))) nil (read "f38")) (if (numberp (nth 8 (nth 2 m))) nil (read "f39")))
  67.         )
  68.  
  69.         ( (and (<= 4 i 6) (<= 1 j 3))
  70.           (list (if (numberp (nth 0 (nth 3 m))) nil (read "f41")) (if (numberp (nth 1 (nth 3 m))) nil (read "f42")) (if (numberp (nth 2 (nth 3 m))) nil (read "f43")) (if (numberp (nth 0 (nth 4 m))) nil (read "f51")) (if (numberp (nth 1 (nth 4 m))) nil (read "f52")) (if (numberp (nth 2 (nth 4 m))) nil (read "f53")) (if (numberp (nth 0 (nth 5 m))) nil (read "f61")) (if (numberp (nth 1 (nth 5 m))) nil (read "f62")) (if (numberp (nth 2 (nth 5 m))) nil (read "f63")))
  71.         )
  72.         ( (and (<= 4 i 6) (<= 4 j 6))
  73.           (list (if (numberp (nth 3 (nth 3 m))) nil (read "f44")) (if (numberp (nth 4 (nth 3 m))) nil (read "f45")) (if (numberp (nth 5 (nth 3 m))) nil (read "f46")) (if (numberp (nth 3 (nth 4 m))) nil (read "f54")) (if (numberp (nth 4 (nth 4 m))) nil (read "f55")) (if (numberp (nth 5 (nth 4 m))) nil (read "f56")) (if (numberp (nth 3 (nth 5 m))) nil (read "f64")) (if (numberp (nth 4 (nth 5 m))) nil (read "f65")) (if (numberp (nth 5 (nth 5 m))) nil (read "f66")))
  74.         )
  75.         ( (and (<= 4 i 6) (<= 7 j 9))
  76.           (list (if (numberp (nth 6 (nth 3 m))) nil (read "f47")) (if (numberp (nth 7 (nth 3 m))) nil (read "f48")) (if (numberp (nth 8 (nth 3 m))) nil (read "f49")) (if (numberp (nth 6 (nth 4 m))) nil (read "f57")) (if (numberp (nth 7 (nth 4 m))) nil (read "f58")) (if (numberp (nth 8 (nth 4 m))) nil (read "f59")) (if (numberp (nth 6 (nth 5 m))) nil (read "f67")) (if (numberp (nth 7 (nth 5 m))) nil (read "f68")) (if (numberp (nth 8 (nth 5 m))) nil (read "f69")))
  77.         )
  78.  
  79.         ( (and (<= 7 i 9) (<= 1 j 3))
  80.           (list (if (numberp (nth 0 (nth 6 m))) nil (read "f71")) (if (numberp (nth 1 (nth 6 m))) nil (read "f72")) (if (numberp (nth 2 (nth 6 m))) nil (read "f73")) (if (numberp (nth 0 (nth 7 m))) nil (read "f81")) (if (numberp (nth 1 (nth 7 m))) nil (read "f82")) (if (numberp (nth 2 (nth 7 m))) nil (read "f83")) (if (numberp (nth 0 (nth 8 m))) nil (read "f91")) (if (numberp (nth 1 (nth 8 m))) nil (read "f92")) (if (numberp (nth 2 (nth 8 m))) nil (read "f93")))
  81.         )
  82.         ( (and (<= 7 i 9) (<= 4 j 6))
  83.           (list (if (numberp (nth 3 (nth 6 m))) nil (read "f74")) (if (numberp (nth 4 (nth 6 m))) nil (read "f75")) (if (numberp (nth 5 (nth 6 m))) nil (read "f76")) (if (numberp (nth 3 (nth 7 m))) nil (read "f84")) (if (numberp (nth 4 (nth 7 m))) nil (read "f85")) (if (numberp (nth 5 (nth 7 m))) nil (read "f86")) (if (numberp (nth 3 (nth 8 m))) nil (read "f94")) (if (numberp (nth 4 (nth 8 m))) nil (read "f95")) (if (numberp (nth 5 (nth 8 m))) nil (read "f96")))
  84.         )
  85.         ( (and (<= 7 i 9) (<= 7 j 9))
  86.           (list (if (numberp (nth 6 (nth 6 m))) nil (read "f77")) (if (numberp (nth 7 (nth 6 m))) nil (read "f78")) (if (numberp (nth 8 (nth 6 m))) nil (read "f79")) (if (numberp (nth 6 (nth 7 m))) nil (read "f87")) (if (numberp (nth 7 (nth 7 m))) nil (read "f88")) (if (numberp (nth 8 (nth 7 m))) nil (read "f89")) (if (numberp (nth 6 (nth 8 m))) nil (read "f97")) (if (numberp (nth 7 (nth 8 m))) nil (read "f98")) (if (numberp (nth 8 (nth 8 m))) nil (read "f99")))
  87.         )
  88.       )
  89.     ))
  90.     (setq rfs (vl-remove (read (strcat "f" (itoa i) (itoa j))) rfs))
  91.     (setq cfs (vl-remove (read (strcat "f" (itoa i) (itoa j))) cfs))
  92.     (setq sfs (vl-remove (read (strcat "f" (itoa i) (itoa j))) sfs))
  93.     (setq rfs (mapcar '(lambda ( x ) (eval x)) rfs))
  94.     (setq cfs (mapcar '(lambda ( x ) (eval x)) cfs))
  95.     (setq sfs (mapcar '(lambda ( x ) (eval x)) sfs))
  96.     (while (setq x (car rfs))
  97.       (setq gx (vl-remove-if-not '(lambda ( a ) (equal x a)) rfs))
  98.       (setq rfs (vl-remove-if '(lambda ( a ) (vl-position a gx)) rfs))
  99.       (setq rfsg (cons gx rfsg))
  100.     )
  101.     (while (setq x (car cfs))
  102.       (setq gx (vl-remove-if-not '(lambda ( a ) (equal x a)) cfs))
  103.       (setq cfs (vl-remove-if '(lambda ( a ) (vl-position a gx)) cfs))
  104.       (setq cfsg (cons gx cfsg))
  105.     )
  106.     (while (setq x (car sfs))
  107.       (setq gx (vl-remove-if-not '(lambda ( a ) (equal x a)) sfs))
  108.       (setq sfs (vl-remove-if '(lambda ( a ) (vl-position a gx)) sfs))
  109.       (setq sfsg (cons gx sfsg))
  110.     )
  111.     (foreach g rfsg
  112.       (if (and (> (length g) 1) (= (length g) (length (car g))))
  113.         (setq nn (vl-remove-if '(lambda ( x ) (vl-position x (car g))) nn))
  114.       )
  115.     )
  116.     (foreach g cfsg
  117.       (if (and (> (length g) 1) (= (length g) (length (car g))))
  118.         (setq nn (vl-remove-if '(lambda ( x ) (vl-position x (car g))) nn))
  119.       )
  120.     )
  121.     (foreach g sfsg
  122.       (if (and (> (length g) 1) (= (length g) (length (car g))))
  123.         (setq nn (vl-remove-if '(lambda ( x ) (vl-position x (car g))) nn))
  124.       )
  125.     )
  126.     (vl-sort nn '<)
  127.   )
  128.  
  129.   (defun check ( m / v i j r c s rtn )
  130.     (setq v '(1 2 3 4 5 6 7 8 9))
  131.     (setq i 0)
  132.     (repeat 9
  133.       (setq i (1+ i) j 0)
  134.       (repeat 9
  135.         (setq j (1+ j))
  136.         (mapcar 'set '(r c s) (rcs m i j))
  137.         (if
  138.           (and
  139.             (null (vl-remove-if '(lambda ( x ) (vl-position x s)) v))
  140.             (null (vl-remove-if '(lambda ( x ) (vl-position x r)) v))
  141.             (null (vl-remove-if '(lambda ( x ) (vl-position x c)) v))
  142.           )
  143.           (setq rtn (cons t rtn))
  144.           (setq rtn (cons nil rtn))
  145.         )
  146.       )
  147.     )
  148.     (apply 'and rtn)
  149.   )
  150.  
  151.   (setq m '((nil nil 4 8 nil nil nil 1 7)
  152.             (6 7 nil 9 nil nil nil nil nil)
  153.             (5 nil 8 nil 3 nil nil nil 4)
  154.             (3 nil nil 7 4 nil 1 nil nil)
  155.             (nil 6 9 nil nil nil 7 8 nil)
  156.             (nil nil 1 nil 6 9 nil nil 5)
  157.             (1 nil nil nil 8 nil 3 nil 6)
  158.             (nil nil nil nil nil 6 nil 9 1)
  159.             (2 4 nil nil nil 1 5 nil nil))) ;;; Remove initial matrix if you want to specify new SUDOKU puzzle
  160.   ;;; This one works - John's link example
  161.   ;|
  162.   (setq m '((6 nil nil nil 8 5 1 nil nil)
  163.             (nil nil nil nil nil nil nil 5 3)
  164.             (4 nil nil nil nil 9 8 nil nil)
  165.             (nil nil nil nil nil nil nil 1 nil)
  166.             (nil 8 nil 3 2 6 nil 7 nil)
  167.             (nil 3 nil 1 nil nil nil nil nil)
  168.             (nil nil 7 nil nil nil nil nil 4)
  169.             (nil 5 nil nil nil nil nil nil nil)
  170.             (nil nil nil 9 4 nil nil nil 2))) ;;; Remove initial matrix if you want to specify new SUDOKU puzzle
  171.   ;;; This one won't work ;;;
  172.   ;;; Solution ->
  173.   '((6 7 3 2 8 5 1 4 9)
  174.     (2 9 8 4 7 1 6 5 3)
  175.     (4 1 5 6 3 9 8 2 7)
  176.     (5 4 2 7 9 8 3 1 6)
  177.     (1 8 9 3 2 6 4 7 5)
  178.     (7 3 6 1 5 4 2 9 8)
  179.     (8 2 7 5 1 3 9 6 4)
  180.     (9 5 4 8 6 2 7 3 1)
  181.     (3 6 1 9 4 7 5 8 2))
  182.   |;
  183.   (if (null m)
  184.     (progn
  185.       (prompt "\nSpecify values of SUDOKU 9x9 matrix - PRESS ENTER for empty field...")
  186.       (setq i 0)
  187.       (repeat 9
  188.         (setq i (1+ i) j 0)
  189.         (repeat 9
  190.           (setq j (1+ j))
  191.           (setq v (getint (strcat "\nRow : " (itoa i) " Column : " (itoa j) " = ")))
  192.           (setq r (cons v r))
  193.         )
  194.         (setq r (reverse r))
  195.         (setq m (cons r m))
  196.         (setq r nil)
  197.       )
  198.       (setq m (reverse m))
  199.     )
  200.   )
  201.   (setq i 0)
  202.   (repeat 9
  203.     (setq i (1+ i) j 0 r (nth (1- i) m))
  204.     (repeat 9
  205.       (setq j (1+ j))
  206.       (set (read (strcat "f" (itoa i) (itoa j))) (nth (1- j) r))
  207.     )
  208.   )
  209.   (setq i 0)
  210.   (repeat 9
  211.     (setq i (1+ i) j 0)
  212.     (repeat 9
  213.       (setq j (1+ j))
  214.       (if (null (eval (read (strcat "f" (itoa i) (itoa j)))))
  215.         (setq fl (cons (list (read (strcat "f" (itoa i) (itoa j))) i j) fl))
  216.       )
  217.     )
  218.   )
  219.   (setq fl (reverse fl) flll fl mm m z 0 loop t)
  220.   (while (and loop (or fl flll) (not (check mm)) (< z 81))
  221.     (setq fll fl fllll flll)
  222.     (if (equal m mm)
  223.       (progn
  224.         (foreach f fl
  225.           (set (car f) (solve-adv m (cadr f) (caddr f)))
  226.           (set (read (strcat "ff" (itoa (cadr f)) (itoa (caddr f)))) (eval (car f)))
  227.           (if (= (length (eval (car f))) 1)
  228.             (progn
  229.               (setq i nil j nil)
  230.               (setq m (mapcar '(lambda ( r ) (if (null i) (setq i 1 j 0) (setq i (1+ i) j 0)) (mapcar '(lambda ( c ) (setq j (1+ j)) (if (and (= i (cadr f)) (= j (caddr f))) (car (eval (car f))) c)) r)) m))
  231.               (setq fl (vl-remove f fl))
  232.             )
  233.           )
  234.         )
  235.         (setq mm m)
  236.       )
  237.     )
  238.     (if (or (null fl) (null flll))
  239.       (setq mm m)
  240.     )
  241.     (if (equal fll fl)
  242.       (progn
  243.         (if (null fff)
  244.           (setq fff (car (vl-remove-if '(lambda ( x ) (vl-position x fffl)) flll)))
  245.         )
  246.         (if (null ff)
  247.           (setq ff (eval (car fff)))
  248.         )
  249.         (setq fi (cadr fff) fj (caddr fff))
  250.         (setq x (car ff))
  251.         (setq i nil j nil)
  252.         (setq mm (mapcar '(lambda ( r ) (if (null i) (setq i 1 j 0) (setq i (1+ i) j 0)) (mapcar '(lambda ( c ) (setq j (1+ j)) (if (and (= i fi) (= j fj)) x c)) r)) mm))
  253.         (setq ff (cdr ff))
  254.         (if (equal flll fl)
  255.           (progn
  256.             (setq fffl (cons fff fffl))
  257.             (setq fff nil)
  258.           )
  259.         )
  260.         (foreach f (vl-remove fff flll)
  261.           (set (car f) (solve-adv mm (cadr f) (caddr f)))
  262.           (if (= (length (eval (car f))) 1)
  263.             (progn
  264.               (setq i nil j nil)
  265.               (setq mm (mapcar '(lambda ( r ) (if (null i) (setq i 1 j 0) (setq i (1+ i) j 0)) (mapcar '(lambda ( c ) (setq j (1+ j)) (if (and (= i (cadr f)) (= j (caddr f))) (car (eval (car f))) c)) r)) mm))
  266.             )
  267.           )
  268.         )
  269.       )
  270.     )
  271.     (setq flll nil)
  272.     (setq i 0)
  273.     (repeat 9
  274.       (setq i (1+ i) j 0)
  275.       (repeat 9
  276.         (setq j (1+ j))
  277.         (if (null (nth (1- j) (nth (1- i) mm)))
  278.           (setq flll (cons (list (read (strcat "f" (itoa i) (itoa j))) i j) flll))
  279.         )
  280.       )
  281.     )
  282.     (setq flll (reverse flll))
  283.     (cond
  284.       ( (and (null flll) (check mm))
  285.         (setq loop nil)
  286.       )
  287.       ( (or (equal fllll flll) (null flll))
  288.         (setq z (1+ z))
  289.         (setq flll fl mm m)
  290.         (foreach f fl
  291.           (set (car f) (eval (read (strcat "ff" (itoa (cadr f)) (itoa (caddr f))))))
  292.         )
  293.       )
  294.     )
  295.   )
  296.   (setq i 0)
  297.   (repeat 9
  298.     (setq i (1+ i) j 0)
  299.     (repeat 9
  300.       (setq j (1+ j))
  301.       (set (read (strcat "f" (itoa i) (itoa j))) nil)
  302.       (set (read (strcat "ff" (itoa i) (itoa j))) nil)
  303.     )
  304.   )
  305.   (if (check mm)
  306.     (setq m mm)
  307.   )
  308.   (if (= z 81)
  309.     (progn
  310.       (prompt "\nSolution can't be found... Quitting...")
  311.       (exit)
  312.     )
  313.   )
  314.   (prompt "\n Matrix is stored in variable \"m\" - you can call it with !m")
  315.   (prompt "\n")
  316.   (prompt "\n ") (princ (nth 0 (nth 0 m))) (prompt " ") (princ (nth 1 (nth 0 m))) (prompt " ") (princ (nth 2 (nth 0 m))) (prompt " | ") (princ (nth 3 (nth 0 m))) (prompt " ") (princ (nth 4 (nth 0 m))) (prompt " ") (princ (nth 5 (nth 0 m))) (prompt " | ") (princ (nth 6 (nth 0 m))) (prompt " ") (princ (nth 7 (nth 0 m))) (prompt " ") (princ (nth 8 (nth 0 m)))
  317.   (prompt "\n ") (princ (nth 0 (nth 1 m))) (prompt " ") (princ (nth 1 (nth 1 m))) (prompt " ") (princ (nth 2 (nth 1 m))) (prompt " | ") (princ (nth 3 (nth 1 m))) (prompt " ") (princ (nth 4 (nth 1 m))) (prompt " ") (princ (nth 5 (nth 1 m))) (prompt " | ") (princ (nth 6 (nth 1 m))) (prompt " ") (princ (nth 7 (nth 1 m))) (prompt " ") (princ (nth 8 (nth 1 m)))
  318.   (prompt "\n ") (princ (nth 0 (nth 2 m))) (prompt " ") (princ (nth 1 (nth 2 m))) (prompt " ") (princ (nth 2 (nth 2 m))) (prompt " | ") (princ (nth 3 (nth 2 m))) (prompt " ") (princ (nth 4 (nth 2 m))) (prompt " ") (princ (nth 5 (nth 2 m))) (prompt " | ") (princ (nth 6 (nth 2 m))) (prompt " ") (princ (nth 7 (nth 2 m))) (prompt " ") (princ (nth 8 (nth 2 m)))
  319.   (prompt "\n ---------------------")
  320.   (prompt "\n ") (princ (nth 0 (nth 3 m))) (prompt " ") (princ (nth 1 (nth 3 m))) (prompt " ") (princ (nth 2 (nth 3 m))) (prompt " | ") (princ (nth 3 (nth 3 m))) (prompt " ") (princ (nth 4 (nth 3 m))) (prompt " ") (princ (nth 5 (nth 3 m))) (prompt " | ") (princ (nth 6 (nth 3 m))) (prompt " ") (princ (nth 7 (nth 3 m))) (prompt " ") (princ (nth 8 (nth 3 m)))
  321.   (prompt "\n ") (princ (nth 0 (nth 4 m))) (prompt " ") (princ (nth 1 (nth 4 m))) (prompt " ") (princ (nth 2 (nth 4 m))) (prompt " | ") (princ (nth 3 (nth 4 m))) (prompt " ") (princ (nth 4 (nth 4 m))) (prompt " ") (princ (nth 5 (nth 4 m))) (prompt " | ") (princ (nth 6 (nth 4 m))) (prompt " ") (princ (nth 7 (nth 4 m))) (prompt " ") (princ (nth 8 (nth 4 m)))
  322.   (prompt "\n ") (princ (nth 0 (nth 5 m))) (prompt " ") (princ (nth 1 (nth 5 m))) (prompt " ") (princ (nth 2 (nth 5 m))) (prompt " | ") (princ (nth 3 (nth 5 m))) (prompt " ") (princ (nth 4 (nth 5 m))) (prompt " ") (princ (nth 5 (nth 5 m))) (prompt " | ") (princ (nth 6 (nth 5 m))) (prompt " ") (princ (nth 7 (nth 5 m))) (prompt " ") (princ (nth 8 (nth 5 m)))
  323.   (prompt "\n ---------------------")
  324.   (prompt "\n ") (princ (nth 0 (nth 6 m))) (prompt " ") (princ (nth 1 (nth 6 m))) (prompt " ") (princ (nth 2 (nth 6 m))) (prompt " | ") (princ (nth 3 (nth 6 m))) (prompt " ") (princ (nth 4 (nth 6 m))) (prompt " ") (princ (nth 5 (nth 6 m))) (prompt " | ") (princ (nth 6 (nth 6 m))) (prompt " ") (princ (nth 7 (nth 6 m))) (prompt " ") (princ (nth 8 (nth 6 m)))
  325.   (prompt "\n ") (princ (nth 0 (nth 7 m))) (prompt " ") (princ (nth 1 (nth 7 m))) (prompt " ") (princ (nth 2 (nth 7 m))) (prompt " | ") (princ (nth 3 (nth 7 m))) (prompt " ") (princ (nth 4 (nth 7 m))) (prompt " ") (princ (nth 5 (nth 7 m))) (prompt " | ") (princ (nth 6 (nth 7 m))) (prompt " ") (princ (nth 7 (nth 7 m))) (prompt " ") (princ (nth 8 (nth 7 m)))
  326.   (prompt "\n ") (princ (nth 0 (nth 8 m))) (prompt " ") (princ (nth 1 (nth 8 m))) (prompt " ") (princ (nth 2 (nth 8 m))) (prompt " | ") (princ (nth 3 (nth 8 m))) (prompt " ") (princ (nth 4 (nth 8 m))) (prompt " ") (princ (nth 5 (nth 8 m))) (prompt " | ") (princ (nth 6 (nth 8 m))) (prompt " ") (princ (nth 7 (nth 8 m))) (prompt " ") (princ (nth 8 (nth 8 m)))
  327.   (textscr)
  328.   (princ)
  329. )
  330.  

So if someone wants to play, he/she is welcome...
Regards...
« Last Edit: October 28, 2017, 09:04:49 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: SUDOKU Challenge
« Reply #1 on: October 23, 2017, 12:17:00 PM »
I've updated and improved above posted code with (solution-adv) advanced logic computation... To see that it really steps into it and that it can solve it, try test with this matrix...

Code - Auto/Visual Lisp: [Select]
  1.   (setq m '((6 nil nil nil 8 5 1 4 nil)
  2.             (nil nil nil nil nil nil nil 5 3)
  3.             (4 nil nil nil nil 9 8 nil nil)
  4.             (nil nil nil nil nil nil nil 1 nil)
  5.             (nil 8 nil 3 2 6 nil 7 nil)
  6.             (nil 3 nil 1 nil nil nil nil nil)
  7.             (nil nil 7 nil nil nil nil nil 4)
  8.             (9 5 nil nil nil nil nil nil nil)
  9.             (3 6 1 9 4 nil 5 8 2))) ;;; Remove initial matrix if you want to specify new SUDOKU puzzle
  10.   ;|
  11.   ;;; Solution ->
  12.   '((6 7 3 2 8 5 1 4 9)
  13.     (2 9 8 4 7 1 6 5 3)
  14.     (4 1 5 6 3 9 8 2 7)
  15.     (5 4 2 7 9 8 3 1 6)
  16.     (1 8 9 3 2 6 4 7 5)
  17.     (7 3 6 1 5 4 2 9 8)
  18.     (8 2 7 5 1 3 9 6 4)
  19.     (9 5 4 8 6 2 7 3 1)
  20.     (3 6 1 9 4 7 5 8 2))
  21.   |;
  22.  

Still if there are even less numbers specified, it will search and if it doesn't find it, it should exit-quit with message that solution isn't possible (at least with my logic so far...)...

M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

Grrr1337

  • Swamp Rat
  • Posts: 812
Re: SUDOKU Challenge
« Reply #2 on: October 23, 2017, 01:19:26 PM »
Hey Marko,
I saw your thread when you first started it and thought that subfunction like this would be handy:

Code - Auto/Visual Lisp: [Select]
  1. (defun IsSudokuSolutionValid ( aL / GroupByN ValidRowColp cols tmpL )
  2.  
  3.   (defun GroupByN ( n L / r )
  4.     (repeat n (and L (setq r (cons (car L) r))) (setq L (cdr L)) r)
  5.     (if L (cons (reverse r) (GroupByN n L)) (list (reverse r)))
  6.   ); defun GroupByN
  7.  
  8.  
  9.   ; _$ (ValidRowColp '(1 2 3 6 5 4 7 8 9)) -> T
  10.   ; _$ (ValidRowColp '(1 2 3 6 9 4 7 8 9)) -> nil
  11.   (defun ValidRowColp ( L / nL )
  12.     (setq nL '(1 2 3 4 5 6 7 8 9))
  13.     (vl-every (function (lambda (x) (if (member x nL) (progn (setq nL (vl-remove x nL)) T)))) L)
  14.   ); defun ValidRowColp
  15.  
  16.   (and
  17.     (vl-consp aL) (= 9 (length aL)) (vl-every (function (lambda (x) (and (vl-consp x) (= 9 (length x))))) aL) ; Basic checking
  18.     (vl-every (function (lambda (x) (and (eq 'INT (type x)) (<= 1 x 9)))) (apply 'append aL)) ; atom checking
  19.     (setq cols (apply 'mapcar (cons 'list aL)))
  20.     (vl-every 'ValidRowColp aL) ; Check Rows
  21.     (vl-every 'ValidRowColp cols) ; Check Columns
  22.     (setq tmpL (mapcar (function (lambda (x) (GroupByN 3 x))) aL))
  23.     (vl-every (function (lambda (x) (ValidRowColp (apply 'append x)))) ; Use: (mapcar '(lambda (x) (apply 'append x)) ..) to visualise this
  24.       (append ; Check 3x3 Matrix Sublists
  25.         (GroupByN 3 (mapcar 'car tmpL))
  26.         (GroupByN 3 (mapcar 'cadr tmpL))
  27.         (GroupByN 3 (mapcar 'caddr tmpL))
  28.       ); append
  29.     ); vl-every
  30.   ); and
  31.  
  32. ); defun IsSudokuSolutionValid

Code - Auto/Visual Lisp: [Select]
  1. _$ (IsSudokuSolutionValid
  2.   '(
  3.     (6 7 3 2 8 5 1 4 9)
  4.     (2 9 8 4 7 1 6 5 3)
  5.     (4 1 5 6 3 9 8 2 7)
  6.     (5 4 2 7 9 8 3 1 6)
  7.     (1 8 9 3 2 6 4 7 5)
  8.     (7 3 6 1 5 4 2 9 8)
  9.     (8 2 7 5 1 3 9 6 4)
  10.     (9 5 4 8 6 2 7 3 1)
  11.     (3 6 1 9 4 7 5 8 2)
  12.   )
  13. )
  14. T
  15. _$ (IsSudokuSolutionValid
  16.   '(
  17.     (7 6 3 2 8 5 1 4 9)
  18.     (2 9 8 4 7 1 6 5 3)
  19.     (4 1 5 6 3 9 8 2 7)
  20.     (5 4 2 7 9 8 3 1 6)
  21.     (1 8 9 3 2 6 4 7 5)
  22.     (7 3 6 1 5 4 2 9 8)
  23.     (8 2 7 5 1 3 9 6 4)
  24.     (9 5 4 8 6 2 7 3 1)
  25.     (3 6 1 9 4 7 5 8 2)
  26.   )
  27. )
  28. nil

Didn't post earlier because I just wrote that.
But a solver/generator routine is a bit over my head - I hope this one will help you in someway.  :thinking:
(apply ''((a b c)(a b c))
  '(
    (( f L ) (apply 'strcat (f L)))
    (( L ) (if L (cons (chr (car L)) (f (cdr L)))))
    (72 101 108 108 111 32 87 111 114 108 100)
  )
)
vevo.bg

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: SUDOKU Challenge
« Reply #3 on: October 23, 2017, 05:47:28 PM »
The following should calculate the possible candidate entries for each space in the sudoku -

Code - Auto/Visual Lisp: [Select]
  1. (defun sudoku ( l / r )
  2.     (cond
  3.         (   (vl-some
  4.                 (function
  5.                     (lambda ( r )
  6.                         (vl-some 'null r)
  7.                     )
  8.                 )
  9.                 l
  10.             )
  11.             (sudoku
  12.                 (mapcar
  13.                     (function
  14.                         (lambda ( r )
  15.                             (mapcar
  16.                                 (function
  17.                                     (lambda ( c )
  18.                                         (if c (lsh 1 c) 1023)
  19.                                     )
  20.                                 )
  21.                                 r
  22.                             )
  23.                         )
  24.                     )
  25.                     l
  26.                 )
  27.             )
  28.         )
  29.         (   (vl-some
  30.                 (function
  31.                     (lambda ( r )
  32.                         (vl-some 'zerop r)
  33.                     )
  34.                 )
  35.                 (setq r
  36.                     (mapcar
  37.                         (function
  38.                             (lambda ( r )
  39.                                 (mapcar
  40.                                     (function
  41.                                         (lambda ( c )
  42.                                             (if (pow2 c) c 0)
  43.                                         )
  44.                                     )
  45.                                     r
  46.                                 )
  47.                             )
  48.                         )
  49.                         l
  50.                     )
  51.                 )
  52.             )
  53.             (setq l
  54.                 (mapcar
  55.                     (function
  56.                         (lambda ( r )
  57.                             (apply 'append r)
  58.                         )
  59.                     )
  60.                     (grd->mat
  61.                         (mapcar
  62.                             (function
  63.                                 (lambda ( a b )
  64.                                     (mapcar
  65.                                         (function
  66.                                             (lambda ( c )
  67.                                                 (mapcar
  68.                                                     (function
  69.                                                         (lambda ( d )
  70.                                                             (if (pow2 d) d (logand d (~ b)))
  71.                                                         )
  72.                                                     )
  73.                                                     c
  74.                                                 )
  75.                                             )
  76.                                         )
  77.                                         a
  78.                                     )
  79.                                 )
  80.                             )
  81.                             (apply 'append
  82.                                 (mat->grd
  83.                                     (mat->grd
  84.                                         (apply 'mapcar
  85.                                             (cons 'list
  86.                                                 (mapcar
  87.                                                     (function
  88.                                                         (lambda ( a b )
  89.                                                             (mapcar
  90.                                                                 (function
  91.                                                                     (lambda ( c )
  92.                                                                         (if (pow2 c) c (logand c (~ b)))
  93.                                                                     )
  94.                                                                 )
  95.                                                                 a
  96.                                                             )
  97.                                                         )
  98.                                                     )
  99.                                                     (apply 'mapcar
  100.                                                         (cons 'list
  101.                                                             (mapcar
  102.                                                                 (function
  103.                                                                     (lambda ( a b )
  104.                                                                         (mapcar
  105.                                                                             (function
  106.                                                                                 (lambda ( c )
  107.                                                                                     (if (pow2 c) c (logand c (~ b)))
  108.                                                                                 )
  109.                                                                             )
  110.                                                                             a
  111.                                                                         )
  112.                                                                     )
  113.                                                                 )
  114.                                                                 l
  115.                                                                 (mapcar
  116.                                                                     (function
  117.                                                                         (lambda ( r )
  118.                                                                             (apply 'logior r)
  119.                                                                         )
  120.                                                                     )
  121.                                                                     r
  122.                                                                 )
  123.                                                             )
  124.                                                         )
  125.                                                     )
  126.                                                     (mapcar
  127.                                                         (function
  128.                                                             (lambda ( c )
  129.                                                                 (apply 'logior c)
  130.                                                             )
  131.                                                         )
  132.                                                         (apply 'mapcar (cons 'list r))
  133.                                                     )
  134.                                                 )
  135.                                             )
  136.                                         )
  137.                                     )
  138.                                 )
  139.                             )
  140.                             (mapcar
  141.                                 (function
  142.                                     (lambda ( m )
  143.                                         (apply 'logior (apply 'append m))
  144.                                     )
  145.                                 )
  146.                                 (apply 'append (mat->grd (mat->grd r)))
  147.                             )
  148.                         )
  149.                     )
  150.                 )
  151.             )
  152.  
  153.             ;; ( Recursive call goes here )
  154.  
  155.             (mapcar
  156.                 (function
  157.                     (lambda ( r )
  158.                         (mapcar
  159.                             (function
  160.                                 (lambda ( c )
  161.                                     (if (pow2 c)
  162.                                         (fixn (log2 c))
  163.                                         (mapcar
  164.                                             (function
  165.                                                 (lambda ( d )
  166.                                                     (fixn (log2 d))
  167.                                                 )
  168.                                             )
  169.                                             (bits c)
  170.                                         )
  171.                                     )
  172.                                 )
  173.                             )
  174.                             r
  175.                         )
  176.                     )
  177.                 )
  178.                 l
  179.             )
  180.         )
  181.         (   (mapcar
  182.                 (function
  183.                     (lambda ( r )
  184.                         (mapcar
  185.                             (function
  186.                                 (lambda ( c )
  187.                                     (fixn (log2 c))
  188.                                 )
  189.                             )
  190.                             r
  191.                         )
  192.                     )
  193.                 )
  194.                 l
  195.             )
  196.         )
  197.     )
  198. )
  199. (defun mat->grd ( m )
  200.     (if (car m)
  201.         (cons
  202.             (mapcar
  203.                 (function
  204.                     (lambda ( r )
  205.                         (mapcar
  206.                             (function
  207.                                 (lambda ( a b ) a)
  208.                             )
  209.                             r '(0 1 2)
  210.                         )
  211.                     )
  212.                 )
  213.                 m
  214.             )
  215.             (mat->grd (mapcar 'cdddr m))
  216.         )
  217.     )
  218. )
  219. (defun grd->mat ( g )
  220.     (if g
  221.         (append
  222.             (apply 'mapcar
  223.                 (cons 'list
  224.                     (mapcar
  225.                         (function
  226.                             (lambda ( a b ) a)
  227.                         )
  228.                         g '(0 1 2)
  229.                     )
  230.                 )
  231.             )
  232.             (grd->mat (cdddr g))
  233.         )
  234.     )
  235. )
  236. (defun log2 ( n ) (/ (log n) (log 2)))
  237. (defun fixn ( n ) (fix (+ 1e-8 n)))
  238. (defun pow2 ( n ) ((lambda ( r ) (equal r (fixn r) 1e-8)) (log2 n)))
  239. (defun bits ( n / b ) (if (< 0 n) (cons (setq b (lsh 1 (fixn (log2 n)))) (bits (- n b)))))

Example:
Code - Auto/Visual Lisp: [Select]
  1. (sudoku
  2.    '(
  3.         (nil nil  4   8  nil nil nil  1   7 )
  4.         ( 6   7  nil  9  nil nil nil nil nil)
  5.         ( 5  nil  8  nil  3  nil nil nil  4 )
  6.         ( 3  nil nil  7   4  nil  1  nil nil)
  7.         (nil  6   9  nil nil nil  7   8  nil)
  8.         (nil nil  1  nil  6   9  nil nil  5 )
  9.         ( 1  nil nil nil  8  nil  3  nil  6 )
  10.         (nil nil nil nil nil  6  nil  9   1 )
  11.         ( 2   4  nil nil nil  1   5  nil nil)
  12.     )
  13. )
  14.  
  15. -->
  16. (
  17.     (  (9 0)   (9 3 2 0)    4         8          (5 2 0)   (5 2 0)   (9 6 2 0)    1         7     )
  18.     (   6         7        (3 2 0)    9        (5 2 1 0)   (5 4 2 0)   (8 2 0) (5 3 2 0) (8 3 2 0))
  19.     (   5      (9 2 1 0)    8        (6 2 1 0)    3        (7 2 0)   (9 6 2 0)   (6 2 0)    4     )
  20.     (   3      (8 5 2 0)   (5 2 0)    7           4        (8 5 2 0)    1        (6 2 0)   (9 2 0))
  21.     (  (4 0)      6         9      (5 3 2 1 0) (5 2 1 0)   (5 3 2 0)    7         8        (3 2 0))
  22.     ((8 7 4 0)   (8 2 0)    1        (3 2 0)      6         9          (4 2 0) (4 3 2 0)    5     )
  23.     (   1        (9 5 0)   (7 5 0)   (5 4 2 0)    8      (7 5 4 2 0)    3      (7 4 2 0)    6     )
  24.     (  (8 7 0) (8 5 3 0) (7 5 3 0) (5 4 3 2 0) (7 5 2 0)    6        (8 4 2 0)    9         1     )
  25.     (   2         4      (7 6 3 0)   (3 0)       (9 7 0)    1           5        (7 0)     (8 0)  )
  26. )
  27.  

It just remains to implement the recursive call to test each candidate, backtracing if it leads to an invalid solution...
« Last Edit: October 23, 2017, 06:42:27 PM by Lee Mac »

Grrr1337

  • Swamp Rat
  • Posts: 812
Re: SUDOKU Challenge
« Reply #4 on: October 24, 2017, 04:50:28 AM »
The following should calculate the possible candidate entries for each space in the sudoku -

This has to be the one of the most complex functions I've seen from you, insane job!




How do you guys think a sudoku should be generated?
I thought maybe if shifting the items(atoms) in the sublists may work somewhat:

Code - Auto/Visual Lisp: [Select]
  1. '(
  2.   (1 2 3 4 5 6 7 8 9)
  3.   (1 2 3 4 5 6 7 8 9)
  4.   (1 2 3 4 5 6 7 8 9)
  5.   (1 2 3 4 5 6 7 8 9)
  6.   (1 2 3 4 5 6 7 8 9)
  7.   (1 2 3 4 5 6 7 8 9)
  8.   (1 2 3 4 5 6 7 8 9)
  9.   (1 2 3 4 5 6 7 8 9)
  10.   (1 2 3 4 5 6 7 8 9)
  11. )
  12. ->>
  13. '(
  14.   (1 2 3 4 5 6 7 8 9) ; no shift [straight list]
  15.   (9 8 7 1 2 3 4 5 6) ; shift 3 times to the right [straight list]
  16.   (6 5 4 9 8 7 1 2 3) ; shift 6 times to the right [straight list]
  17.   (7 6 5 4 3 2 1 9 8) ; shift 2 times to the left [reversed list: '(9 8 7 6 5 4 3 2 1)]
  18.   (x x x x x x x x x) ; ???
  19.   (x x x x x x x x x) ; ???
  20.   (x x x x x x x x x) ; ???
  21.   (x x x x x x x x x) ; ???
  22.   (x x x x x x x x x) ; ???
  23. )
  24.  



BTW Maybe use 'x' symbol instead of nil, so it would take up space for only 1 character for a better visual formatting:

Code - Auto/Visual Lisp: [Select]
  1. (sudoku
  2.   '(
  3.     (nil nil  4   8  nil nil nil  1   7 )
  4.     ( 6   7  nil  9  nil nil nil nil nil)
  5.     ( 5  nil  8  nil  3  nil nil nil  4 )
  6.     ( 3  nil nil  7   4  nil  1  nil nil)
  7.     (nil  6   9  nil nil nil  7   8  nil)
  8.     (nil nil  1  nil  6   9  nil nil  5 )
  9.     ( 1  nil nil nil  8  nil  3  nil  6 )
  10.     (nil nil nil nil nil  6  nil  9   1 )
  11.     ( 2   4  nil nil nil  1   5  nil nil)
  12.   )
  13. )
  14.  
  15. (sudoku
  16.   '(
  17.     (x x 4 8 x x x 1 7)
  18.     (6 7 x 9 x x x x x)
  19.     (5 x 8 x 3 x x x 4)
  20.     (3 x x 7 4 x 1 x x)
  21.     (x 6 9 x x x 7 8 x)
  22.     (x x 1 x 6 9 x x 5)
  23.     (1 x x x 8 x 3 x 6)
  24.     (x x x x x 6 x 9 1)
  25.     (2 4 x x x 1 5 x x)
  26.   )
  27. )
  28.  

'x' is not assigned and would mean that x = nil.
« Last Edit: October 24, 2017, 04:53:50 AM by Grrr1337 »
(apply ''((a b c)(a b c))
  '(
    (( f L ) (apply 'strcat (f L)))
    (( L ) (if L (cons (chr (car L)) (f (cdr L)))))
    (72 101 108 108 111 32 87 111 114 108 100)
  )
)
vevo.bg

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: SUDOKU Challenge
« Reply #5 on: October 24, 2017, 12:23:22 PM »
The following should calculate the possible candidate entries for each space in the sudoku -
This has to be the one of the most complex functions I've seen from you, insane job!

Thanks!  :-)

BTW Maybe use 'x' symbol instead of nil, so it would take up space for only 1 character for a better visual formatting:
Code - Auto/Visual Lisp: [Select]
  1. (sudoku
  2.   '(
  3.     (x x 4 8 x x x 1 7)
  4.     (6 7 x 9 x x x x x)
  5.     (5 x 8 x 3 x x x 4)
  6.     (3 x x 7 4 x 1 x x)
  7.     (x 6 9 x x x 7 8 x)
  8.     (x x 1 x 6 9 x x 5)
  9.     (1 x x x 8 x 3 x 6)
  10.     (x x x x x 6 x 9 1)
  11.     (2 4 x x x 1 5 x x)
  12.   )
  13. )

'x' is not assigned and would mean that x = nil.

Careful - the unevaluated symbol 'x' will not equal nil...
Code: [Select]
_$ (= nil 'x)
nil

Grrr1337

  • Swamp Rat
  • Posts: 812
Re: SUDOKU Challenge
« Reply #6 on: October 24, 2017, 02:38:07 PM »

Careful - the unevaluated symbol 'x' will not equal nil...
Code: [Select]
_$ (= nil 'x)
nil

Thanks - I've forgot that the symbol is left unevaluated (as the list is unevaluated aswell). <duh>

Then like this (as its not a question of speed-performance) :
Code - Auto/Visual Lisp: [Select]
  1. (sudoku
  2.     '(
  3.       (x x 4 8 x x x 1 7)
  4.       (6 7 x 9 x x x x x)
  5.       (5 x 8 x 3 x x x 4)
  6.       (3 x x 7 4 x 1 x x)
  7.       (x 6 9 x x x 7 8 x)
  8.       (x x 1 x 6 9 x x 5)
  9.       (1 x x x 8 x 3 x 6)
  10.       (x x x x x 6 x 9 1)
  11.       (2 4 x x x 1 5 x x)
  12.     )
  13.   )
  14. )
(apply ''((a b c)(a b c))
  '(
    (( f L ) (apply 'strcat (f L)))
    (( L ) (if L (cons (chr (car L)) (f (cdr L)))))
    (72 101 108 108 111 32 87 111 114 108 100)
  )
)
vevo.bg

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: SUDOKU Challenge
« Reply #7 on: October 25, 2017, 06:49:50 PM »
Somewhat closer...
Code - Auto/Visual Lisp: [Select]
  1. (defun sudoku ( l / r )
  2.     (cond
  3.         (   (vl-some
  4.                 (function
  5.                     (lambda ( r )
  6.                         (vl-some 'null r)
  7.                     )
  8.                 )
  9.                 l
  10.             )
  11.             (sudoku
  12.                 (mapcar
  13.                     (function
  14.                         (lambda ( r )
  15.                             (mapcar
  16.                                 (function
  17.                                     (lambda ( c )
  18.                                         (if c (lsh 1 c) 1022)
  19.                                     )
  20.                                 )
  21.                                 r
  22.                             )
  23.                         )
  24.                     )
  25.                     l
  26.                 )
  27.             )
  28.         )
  29.         (   (vl-some
  30.                 (function
  31.                     (lambda ( r )
  32.                         (vl-some 'zerop r)
  33.                     )
  34.                 )
  35.                 l
  36.             )
  37.             nil
  38.         )
  39.         (   (progn
  40.                 (setq r
  41.                     (mapcar
  42.                         (function
  43.                             (lambda ( r )
  44.                                 (mapcar
  45.                                     (function
  46.                                         (lambda ( c )
  47.                                             (if (pow2 c) c 0)
  48.                                         )
  49.                                     )
  50.                                     r
  51.                                 )
  52.                             )
  53.                         )
  54.                         l
  55.                     )
  56.                 )
  57.                 (not
  58.                     (equalm l
  59.                         (setq l
  60.                             (mapcar
  61.                                 (function
  62.                                     (lambda ( r )
  63.                                         (apply 'append r)
  64.                                     )
  65.                                 )
  66.                                 (grd->mat
  67.                                     (mapcar
  68.                                         (function
  69.                                             (lambda ( a b )
  70.                                                 (mapcar
  71.                                                     (function
  72.                                                         (lambda ( c )
  73.                                                             (mapcar
  74.                                                                 (function
  75.                                                                     (lambda ( d )
  76.                                                                         (if (pow2 d) d (logand d (~ b)))
  77.                                                                     )
  78.                                                                 )
  79.                                                                 c
  80.                                                             )
  81.                                                         )
  82.                                                     )
  83.                                                     a
  84.                                                 )
  85.                                             )
  86.                                         )
  87.                                         (apply 'append
  88.                                             (mat->grd
  89.                                                 (mat->grd
  90.                                                     (apply 'mapcar
  91.                                                         (cons 'list
  92.                                                             (mapcar
  93.                                                                 (function
  94.                                                                     (lambda ( a b )
  95.                                                                         (mapcar
  96.                                                                             (function
  97.                                                                                 (lambda ( c )
  98.                                                                                     (if (pow2 c) c (logand c (~ b)))
  99.                                                                                 )
  100.                                                                             )
  101.                                                                             a
  102.                                                                         )
  103.                                                                     )
  104.                                                                 )
  105.                                                                 (apply 'mapcar
  106.                                                                     (cons 'list
  107.                                                                         (mapcar
  108.                                                                             (function
  109.                                                                                 (lambda ( a b )
  110.                                                                                     (mapcar
  111.                                                                                         (function
  112.                                                                                             (lambda ( c )
  113.                                                                                                 (if (pow2 c) c (logand c (~ b)))
  114.                                                                                             )
  115.                                                                                         )
  116.                                                                                         a
  117.                                                                                     )
  118.                                                                                 )
  119.                                                                             )
  120.                                                                             l
  121.                                                                             (mapcar
  122.                                                                                 (function
  123.                                                                                     (lambda ( r )
  124.                                                                                         (apply 'logior r)
  125.                                                                                     )
  126.                                                                                 )
  127.                                                                                 r
  128.                                                                             )
  129.                                                                         )
  130.                                                                     )
  131.                                                                 )
  132.                                                                 (mapcar
  133.                                                                     (function
  134.                                                                         (lambda ( c )
  135.                                                                             (apply 'logior c)
  136.                                                                         )
  137.                                                                     )
  138.                                                                     (apply 'mapcar (cons 'list r))
  139.                                                                 )
  140.                                                             )
  141.                                                         )
  142.                                                     )
  143.                                                 )
  144.                                             )
  145.                                         )
  146.                                         (mapcar
  147.                                             (function
  148.                                                 (lambda ( m )
  149.                                                     (apply 'logior (apply 'append m))
  150.                                                 )
  151.                                             )
  152.                                             (apply 'append (mat->grd (mat->grd r)))
  153.                                         )
  154.                                     )
  155.                                 )
  156.                             )
  157.                         )
  158.                     )
  159.                 )
  160.             )
  161.             (sudoku l)
  162.         )
  163.         (
  164.             (
  165.                 (lambda ( / i j ) (setq i -1)
  166.                     (vl-some
  167.                         (function
  168.                             (lambda ( r ) (setq i (1+ i) j -1)
  169.                                 (vl-some
  170.                                     (function
  171.                                         (lambda ( c ) (setq j (1+ j))
  172.                                             (if (and (< 0 c) (not (pow2 c)))
  173.                                                 (vl-some
  174.                                                     (function
  175.                                                         (lambda ( d )
  176.                                                             (sudoku (substij i j d l))
  177.                                                         )
  178.                                                     )
  179.                                                     (bits c)
  180.                                                 )
  181.                                             )
  182.                                         )
  183.                                     )
  184.                                     r
  185.                                 )
  186.                             )
  187.                         )
  188.                         l
  189.                     )
  190.                 )
  191.             )
  192.         )
  193.         (   (mapcar
  194.                 (function
  195.                     (lambda ( r )
  196.                         (mapcar
  197.                             (function
  198.                                 (lambda ( c )
  199.                                     (fixn (log2 c))
  200.                                 )
  201.                             )
  202.                             r
  203.                         )
  204.                     )
  205.                 )
  206.                 l
  207.             )
  208.         )
  209.     )
  210. )
  211. (defun equalm ( a b )
  212.     (vl-every '(lambda ( x y ) (vl-every '= x y)) a b)
  213. )
  214. (defun substij ( i j n m / a )
  215.     (setq a -1)
  216.     (mapcar
  217.         (function
  218.             (lambda ( x / b )
  219.                 (if (= i (setq b -1 a (1+ a)))
  220.                     (mapcar
  221.                         (function
  222.                             (lambda ( y )
  223.                                 (if (= j (setq b (1+ b))) n y)
  224.                             )
  225.                         )
  226.                         x
  227.                     )
  228.                     x
  229.                 )
  230.             )
  231.         )
  232.         m
  233.     )
  234. )
  235. (defun mat->grd ( m )
  236.     (if (car m)
  237.         (cons
  238.             (mapcar
  239.                 (function
  240.                     (lambda ( r )
  241.                         (mapcar
  242.                             (function
  243.                                 (lambda ( a b ) a)
  244.                             )
  245.                             r '(0 1 2)
  246.                         )
  247.                     )
  248.                 )
  249.                 m
  250.             )
  251.             (mat->grd (mapcar 'cdddr m))
  252.         )
  253.     )
  254. )
  255. (defun grd->mat ( g )
  256.     (if g
  257.         (append
  258.             (apply 'mapcar
  259.                 (cons 'list
  260.                     (mapcar
  261.                         (function
  262.                             (lambda ( a b ) a)
  263.                         )
  264.                         g '(0 1 2)
  265.                     )
  266.                 )
  267.             )
  268.             (grd->mat (cdddr g))
  269.         )
  270.     )
  271. )
  272. (defun log2 ( n ) (/ (log n) (log 2)))
  273. (defun fixn ( n ) (fix (+ 1e-8 n)))
  274. (defun pow2 ( n ) (if (zerop n) 0 ((lambda ( r ) (equal r (fixn r) 1e-8)) (log2 n))))
  275. (defun bits ( n / b ) (if (< 0 n) (cons (setq b (lsh 1 (fixn (log2 n)))) (bits (- n b)))))

Now successfully solves this example:
Code - Auto/Visual Lisp: [Select]
  1. (sudoku
  2.    '(
  3.         (nil nil 4 8 nil nil nil 1 7)
  4.         (6 7 nil 9 nil nil nil nil nil)
  5.         (5 nil 8 nil 3 nil nil nil 4)
  6.         (3 nil nil 7 4 nil 1 nil nil)
  7.         (nil 6 9 nil nil nil 7 8 nil)
  8.         (nil nil 1 nil 6 9 nil nil 5)
  9.         (1 nil nil nil 8 nil 3 nil 6)
  10.         (nil nil nil nil nil 6 nil 9 1)
  11.         (2 4 nil nil nil 1 5 nil nil)
  12.     )
  13. )
  14. -->
  15. (
  16.     (9 3 4 8 2 5 6 1 7)
  17.     (6 7 2 9 1 4 8 5 3)
  18.     (5 1 8 6 3 7 9 2 4)
  19.     (3 2 5 7 4 8 1 6 9)
  20.     (4 6 9 1 5 3 7 8 2)
  21.     (7 8 1 2 6 9 4 3 5)
  22.     (1 9 7 5 8 2 3 4 6)
  23.     (8 5 3 4 7 6 2 9 1)
  24.     (2 4 6 3 9 1 5 7 8)
  25. )

...But not this example:
Code - Auto/Visual Lisp: [Select]
  1. (sudoku
  2.    '(
  3.         (6 nil nil nil 8 5 1 nil nil)
  4.         (nil nil nil nil nil nil nil 5 3)
  5.         (4 nil nil nil nil 9 8 nil nil)
  6.         (nil nil nil nil nil nil nil 1 nil)
  7.         (nil 8 nil 3 2 6 nil 7 nil)
  8.         (nil 3 nil 1 nil nil nil nil nil)
  9.         (nil nil 7 nil nil nil nil nil 4)
  10.         (nil 5 nil nil nil nil nil nil nil)
  11.         (nil nil nil 9 4 nil nil nil 2)
  12.     )
  13. )
  14. -->
  15. (
  16.     (6 9 3 2 8 5 1 4 7)
  17.     (8 7 2 4 6 1 9 5 3)
  18.     (4 1 5 7 3 9 8 2 6)
  19.     (7 4 6 5 9 8 3 1 9)
  20.     (1 8 1 3 2 6 4 7 5)
  21.     (5 3 9 1 7 4 2 6 8)
  22.     (9 2 7 8 5 3 6 9 4)
  23.     (3 5 4 6 1 2 7 9 8)
  24.     (1 6 8 9 4 7 5 3 2)
  25. )

 :-(

Grrr1337

  • Swamp Rat
  • Posts: 812
Re: SUDOKU Challenge
« Reply #8 on: October 26, 2017, 04:16:50 AM »
Atleast its good to see some progress, Lee!  :rolleyes2:

A small thing I could help at is to prompt where the sudoku errors:
Code - Auto/Visual Lisp: [Select]
  1. (defun IsSudokuValid ( aL / InvalidAt GroupByN ValidRowColp cols tmpL r )
  2.  
  3.   ; _$ (InvalidAt '(lambda (a) (= a 5)) '(lambda (a b) (print (strcat "Error at item n."  b " :\n" (vl-prin1-to-string a)))) '(1 2 3 4 5 6 7 8 9)) -> "Error at item n.1 :\n1" T
  4.   ; _$ (InvalidAt '(lambda (a) (/= a 5)) '(lambda (a b) (print (strcat "Error at item n."  b " :\n" (vl-prin1-to-string a)))) '(1 2 3 4 5 6 7 8 9)) -> "Error at item n.5 :\n5" T
  5.   ; _$ (InvalidAt '(lambda (a) (/= a 15)) '(lambda (a b) (print (strcat "Error at item n."  b " :\n" (vl-prin1-to-string a)))) '(1 2 3 4 5 6 7 8 9)) -> nil
  6.   (setq InvalidAt
  7.     (lambda ( f mf L / i )
  8.       (setq i 0) (setq f (eval f)) (setq mf (eval mf))
  9.       (vl-some (function (lambda (x) (setq i (1+ i)) (if (not (f x)) (progn (mf x (itoa i)) T)))) L)
  10.     )
  11.   ); setq InvalidAt
  12.  
  13.   (defun GroupByN ( n L / r )
  14.     (repeat n (and L (setq r (cons (car L) r))) (setq L (cdr L)) r)
  15.     (if L (cons (reverse r) (GroupByN n L)) (list (reverse r)))
  16.   ); defun GroupByN
  17.  
  18.   ; _$ (ValidRowColp '(1 2 3 6 5 4 7 8 9)) -> T
  19.   ; _$ (ValidRowColp '(1 2 3 6 9 4 7 8 9)) -> nil
  20.   (defun ValidRowColp ( L / nL )
  21.     (setq nL '(1 2 3 4 5 6 7 8 9))
  22.     (vl-every (function (lambda (x) (if (member x nL) (progn (setq nL (vl-remove x nL)) T)))) L)
  23.   ); defun ValidRowColp
  24.  
  25.   (cond
  26.     ( (not (vl-consp aL)) (prompt "\n#1. Not vl-consp.") )
  27.     ( (/= 9 (length aL)) (prompt "\n#2. Invalid length.") )
  28.     ( (InvalidAt '(lambda (x) (and (vl-consp x) (= 9 (length x)))) '(lambda (a b) (print (strcat "\nError[basic] at row n." b " :\n" (vl-prin1-to-string a)))) aL) )
  29.     ( (InvalidAt '(lambda (x) (and (eq 'INT (type x)) (<= 1 x 9))) '(lambda (a b) (print (strcat "\nError at atom n." b " :\n" (vl-prin1-to-string a)))) (apply 'append aL)) )
  30.     ( (progn (setq cols (apply 'mapcar (cons 'list aL))) nil) )
  31.     ( (InvalidAt 'ValidRowColp '(lambda (a b) (print (strcat "\nError at row n." b " :\n" (vl-prin1-to-string a)))) aL) )
  32.     ( (InvalidAt 'ValidRowColp '(lambda (a b) (print (strcat "\nError at col n." b " :\n" (vl-prin1-to-string a)))) cols) )
  33.     (
  34.       (and (setq tmpL (mapcar (function (lambda (x) (GroupByN 3 x))) aL))
  35.         (not
  36.           (InvalidAt '(lambda (x) (ValidRowColp (apply 'append x))) '(lambda (a b) (print (strcat "\nError at sector n." b " :\n" (vl-prin1-to-string a))))
  37.             (append ; Check 3x3 Matrix Sublists
  38.               (GroupByN 3 (mapcar 'car tmpL))
  39.               (GroupByN 3 (mapcar 'cadr tmpL))
  40.               (GroupByN 3 (mapcar 'caddr tmpL))
  41.             ); append
  42.           )
  43.         )
  44.         (setq r T)
  45.       ); progn
  46.     )
  47.   ); cond
  48.   r
  49. ); defun IsSudokuValid

Example:
Code - Auto/Visual Lisp: [Select]
  1. _$ (IsSudokuValid
  2.   '((6 9 3 2 8 5 1 4 7)
  3.     (8 7 2 4 6 1 9 5 3)
  4.     (4 1 5 7 3 9 8 2 6)
  5.     (7 4 6 5 9 8 3 1 9)
  6.     (1 8 1 3 2 6 4 7 5)
  7.     (5 3 9 1 7 4 2 6 8)
  8.     (9 2 7 8 5 3 6 9 4)
  9.     (3 5 4 6 1 2 7 9 8)
  10.     (1 6 8 9 4 7 5 3 2)
  11.   )
  12. )
  13.  
  14. "\nError at row n.4 :\n(7 4 6 5 9 8 3 1 9)" nil
  15. _$ (IsSudokuValid
  16.   '((9 3 4 8 2 5 6 1 7)
  17.     (6 7 2 9 1 4 8 5 3)
  18.     (5 1 8 6 3 7 9 2 4)
  19.     (3 2 5 7 4 8 1 6 9)
  20.     (4 6 9 1 5 3 7 8 2)
  21.     (7 8 1 2 6 9 4 3 5)
  22.     (1 9 7 5 8 2 3 4 6)
  23.     (8 5 3 4 7 6 2 9 1)
  24.     (2 4 6 3 9 1 5 7 8)
  25.   )
  26. )
  27. T

Obviously can't help you with your code (sorry) since is out of my mind.
(apply ''((a b c)(a b c))
  '(
    (( f L ) (apply 'strcat (f L)))
    (( L ) (if L (cons (chr (car L)) (f (cdr L)))))
    (72 101 108 108 111 32 87 111 114 108 100)
  )
)
vevo.bg

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: SUDOKU Challenge
« Reply #9 on: October 26, 2017, 12:35:51 PM »
Nice one Grrr1337  :-)

FWIW, here's another way to write the 'ValidRowColp' function:
Code - Auto/Visual Lisp: [Select]
  1. (defun validrowcolp ( l )
  2.     (equal (mapcar '(lambda ( n ) (nth n l)) (vl-sort-i l '<)) '(1 2 3 4 5 6 7 8 9))
  3. )

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: SUDOKU Challenge
« Reply #10 on: October 26, 2017, 02:02:02 PM »
Just for fun, here are two more ways to group the matrix into the 3x3 submatrices, depending on the order desired:

Code - Auto/Visual Lisp: [Select]
  1. (defun bar ( m )
  2.     (mapcar '(lambda ( x ) (apply 'append x))
  3.         (apply 'append
  4.             (mapcar '(lambda ( x ) (apply 'mapcar (cons 'list (mapcar 'foo x)))) (foo m))
  5.         )
  6.     )
  7. )
  8. (defun baz ( m )
  9.     (mapcar '(lambda ( x ) (apply 'append x))
  10.         (apply 'append
  11.             (mapcar 'foo (apply 'mapcar (cons 'list (mapcar 'foo m))))
  12.         )
  13.     )
  14. )
  15. (defun foo ( m )
  16.     (if m (cons (mapcar '(lambda ( a b ) a) m '(0 1 2)) (foo (cdddr m))))
  17. )

Code - Auto/Visual Lisp: [Select]
  1. (setq m
  2.    '(
  3.         (A1 A2 A3 A4 A5 A6 A7 A8 A9)
  4.         (B1 B2 B3 B4 B5 B6 B7 B8 B9)
  5.         (C1 C2 C3 C4 C5 C6 C7 C8 C9)
  6.         (D1 D2 D3 D4 D5 D6 D7 D8 D9)
  7.         (E1 E2 E3 E4 E5 E6 E7 E8 E9)
  8.         (F1 F2 F3 F4 F5 F6 F7 F8 F9)
  9.         (G1 G2 G3 G4 G5 G6 G7 G8 G9)
  10.         (H1 H2 H3 H4 H5 H6 H7 H8 H9)
  11.         (I1 I2 I3 I4 I5 I6 I7 I8 I9)
  12.     )
  13. )
  14. _$ (bar m)
  15. (
  16.     (A1 A2 A3 B1 B2 B3 C1 C2 C3)
  17.     (A4 A5 A6 B4 B5 B6 C4 C5 C6)
  18.     (A7 A8 A9 B7 B8 B9 C7 C8 C9)
  19.     (D1 D2 D3 E1 E2 E3 F1 F2 F3)
  20.     (D4 D5 D6 E4 E5 E6 F4 F5 F6)
  21.     (D7 D8 D9 E7 E8 E9 F7 F8 F9)
  22.     (G1 G2 G3 H1 H2 H3 I1 I2 I3)
  23.     (G4 G5 G6 H4 H5 H6 I4 I5 I6)
  24.     (G7 G8 G9 H7 H8 H9 I7 I8 I9)
  25. )
  26. _$ (baz m)
  27. (
  28.     (A1 A2 A3 B1 B2 B3 C1 C2 C3)
  29.     (D1 D2 D3 E1 E2 E3 F1 F2 F3)
  30.     (G1 G2 G3 H1 H2 H3 I1 I2 I3)
  31.     (A4 A5 A6 B4 B5 B6 C4 C5 C6)
  32.     (D4 D5 D6 E4 E5 E6 F4 F5 F6)
  33.     (G4 G5 G6 H4 H5 H6 I4 I5 I6)
  34.     (A7 A8 A9 B7 B8 B9 C7 C8 C9)
  35.     (D7 D8 D9 E7 E8 E9 F7 F8 F9)
  36.     (G7 G8 G9 H7 H8 H9 I7 I8 I9)
  37. )


Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: SUDOKU Challenge
« Reply #11 on: October 26, 2017, 03:08:48 PM »
I think I'm there:
Code - Auto/Visual Lisp: [Select]
  1. (defun sudoku ( l / r )
  2.     (cond
  3.         (   (vl-some
  4.                 (function
  5.                     (lambda ( r )
  6.                         (vl-some 'null r)
  7.                     )
  8.                 )
  9.                 l
  10.             )
  11.             (sudoku
  12.                 (mapcar
  13.                     (function
  14.                         (lambda ( r )
  15.                             (mapcar
  16.                                 (function
  17.                                     (lambda ( c )
  18.                                         (if c (lsh 1 c) 1022)
  19.                                     )
  20.                                 )
  21.                                 r
  22.                             )
  23.                         )
  24.                     )
  25.                     l
  26.                 )
  27.             )
  28.         )
  29.         (   (vl-some
  30.                 (function
  31.                     (lambda ( r )
  32.                         (vl-some 'zerop r)
  33.                     )
  34.                 )
  35.                 l
  36.             )
  37.             nil
  38.         )
  39.         (   (progn
  40.                 (setq r
  41.                     (mapcar
  42.                         (function
  43.                             (lambda ( r )
  44.                                 (mapcar
  45.                                     (function
  46.                                         (lambda ( c )
  47.                                             (if (pow2 c) c 0)
  48.                                         )
  49.                                     )
  50.                                     r
  51.                                 )
  52.                             )
  53.                         )
  54.                         l
  55.                     )
  56.                 )
  57.                 (not
  58.                     (equalm l
  59.                         (setq l
  60.                             (mapcar
  61.                                 (function
  62.                                     (lambda ( r )
  63.                                         (apply 'append r)
  64.                                     )
  65.                                 )
  66.                                 (grd->mat
  67.                                     (mapcar
  68.                                         (function
  69.                                             (lambda ( a b )
  70.                                                 (mapcar
  71.                                                     (function
  72.                                                         (lambda ( c )
  73.                                                             (mapcar
  74.                                                                 (function
  75.                                                                     (lambda ( d )
  76.                                                                         (if (pow2 d) d (logand d (~ b)))
  77.                                                                     )
  78.                                                                 )
  79.                                                                 c
  80.                                                             )
  81.                                                         )
  82.                                                     )
  83.                                                     a
  84.                                                 )
  85.                                             )
  86.                                         )
  87.                                         (apply 'append
  88.                                             (mat->grd
  89.                                                 (mat->grd
  90.                                                     (apply 'mapcar
  91.                                                         (cons 'list
  92.                                                             (mapcar
  93.                                                                 (function
  94.                                                                     (lambda ( a b )
  95.                                                                         (mapcar
  96.                                                                             (function
  97.                                                                                 (lambda ( c )
  98.                                                                                     (if (pow2 c) c (logand c (~ b)))
  99.                                                                                 )
  100.                                                                             )
  101.                                                                             a
  102.                                                                         )
  103.                                                                     )
  104.                                                                 )
  105.                                                                 (apply 'mapcar
  106.                                                                     (cons 'list
  107.                                                                         (mapcar
  108.                                                                             (function
  109.                                                                                 (lambda ( a b )
  110.                                                                                     (mapcar
  111.                                                                                         (function
  112.                                                                                             (lambda ( c )
  113.                                                                                                 (if (pow2 c) c (logand c (~ b)))
  114.                                                                                             )
  115.                                                                                         )
  116.                                                                                         a
  117.                                                                                     )
  118.                                                                                 )
  119.                                                                             )
  120.                                                                             l
  121.                                                                             (mapcar
  122.                                                                                 (function
  123.                                                                                     (lambda ( r )
  124.                                                                                         (apply 'logior r)
  125.                                                                                     )
  126.                                                                                 )
  127.                                                                                 r
  128.                                                                             )
  129.                                                                         )
  130.                                                                     )
  131.                                                                 )
  132.                                                                 (mapcar
  133.                                                                     (function
  134.                                                                         (lambda ( c )
  135.                                                                             (apply 'logior c)
  136.                                                                         )
  137.                                                                     )
  138.                                                                     (apply 'mapcar (cons 'list r))
  139.                                                                 )
  140.                                                             )
  141.                                                         )
  142.                                                     )
  143.                                                 )
  144.                                             )
  145.                                         )
  146.                                         (mapcar
  147.                                             (function
  148.                                                 (lambda ( m )
  149.                                                     (apply 'logior (apply 'append m))
  150.                                                 )
  151.                                             )
  152.                                             (apply 'append (mat->grd (mat->grd r)))
  153.                                         )
  154.                                     )
  155.                                 )
  156.                             )
  157.                         )
  158.                     )
  159.                 )
  160.             )
  161.             (sudoku l)
  162.         )
  163.         (
  164.             (
  165.                 (lambda ( / i j ) (setq i -1)
  166.                     (vl-some
  167.                         (function
  168.                             (lambda ( r ) (setq i (1+ i) j -1)
  169.                                 (vl-some
  170.                                     (function
  171.                                         (lambda ( c ) (setq j (1+ j))
  172.                                             (if (and (< 0 c) (not (pow2 c)))
  173.                                                 (vl-some
  174.                                                     (function
  175.                                                         (lambda ( d )
  176.                                                             (sudoku (substij i j d l))
  177.                                                         )
  178.                                                     )
  179.                                                     (bits c)
  180.                                                 )
  181.                                             )
  182.                                         )
  183.                                     )
  184.                                     r
  185.                                 )
  186.                             )
  187.                         )
  188.                         l
  189.                     )
  190.                 )
  191.             )
  192.         )
  193.         (   (or
  194.                 (vl-some
  195.                     (function
  196.                         (lambda ( r )
  197.                             (/= 1022 (apply 'logior r))
  198.                         )
  199.                     )
  200.                     r
  201.                 )
  202.                 (vl-some
  203.                     (function
  204.                         (lambda ( c )
  205.                             (/= 1022 (apply 'logior c))
  206.                         )
  207.                     )
  208.                     (apply 'mapcar (cons 'list r))
  209.                 )
  210.                 (vl-some
  211.                     (function
  212.                         (lambda ( m )
  213.                             (/= 1022 (apply 'logior (apply 'append m)))
  214.                         )
  215.                     )
  216.                     (apply 'append (mat->grd (mat->grd r)))
  217.                 )
  218.             )
  219.             nil
  220.         )
  221.         (   (mapcar
  222.                 (function
  223.                     (lambda ( r )
  224.                         (mapcar
  225.                             (function
  226.                                 (lambda ( c )
  227.                                     (fixn (log2 c))
  228.                                 )
  229.                             )
  230.                             r
  231.                         )
  232.                     )
  233.                 )
  234.                 l
  235.             )
  236.         )
  237.     )
  238. )
  239. (defun equalm ( a b )
  240.     (vl-every '(lambda ( x y ) (vl-every '= x y)) a b)
  241. )
  242. (defun substij ( i j n m / a )
  243.     (setq a -1)
  244.     (mapcar
  245.         (function
  246.             (lambda ( x / b )
  247.                 (if (= i (setq b -1 a (1+ a)))
  248.                     (mapcar
  249.                         (function
  250.                             (lambda ( y )
  251.                                 (if (= j (setq b (1+ b))) n y)
  252.                             )
  253.                         )
  254.                         x
  255.                     )
  256.                     x
  257.                 )
  258.             )
  259.         )
  260.         m
  261.     )
  262. )
  263. (defun mat->grd ( m )
  264.     (if (car m)
  265.         (cons
  266.             (mapcar
  267.                 (function
  268.                     (lambda ( r )
  269.                         (mapcar
  270.                             (function
  271.                                 (lambda ( a b ) a)
  272.                             )
  273.                             r '(0 1 2)
  274.                         )
  275.                     )
  276.                 )
  277.                 m
  278.             )
  279.             (mat->grd (mapcar 'cdddr m))
  280.         )
  281.     )
  282. )
  283. (defun grd->mat ( g )
  284.     (if g
  285.         (append
  286.             (apply 'mapcar
  287.                 (cons 'list
  288.                     (mapcar
  289.                         (function
  290.                             (lambda ( a b ) a)
  291.                         )
  292.                         g '(0 1 2)
  293.                     )
  294.                 )
  295.             )
  296.             (grd->mat (cdddr g))
  297.         )
  298.     )
  299. )
  300. (defun log2 ( n ) (/ (log n) (log 2)))
  301. (defun fixn ( n ) (fix (+ 1e-8 n)))
  302. (defun pow2 ( n ) (if (zerop n) 0 ((lambda ( r ) (equal r (fixn r) 1e-8)) (log2 n))))
  303. (defun bits ( n / b ) (if (< 0 n) (cons (setq b (lsh 1 (fixn (log2 n)))) (bits (- n b)))))

Though, the algorithm is essentially brute-force, so for sparse inputs be prepared to wait...  :wink:

(Now that the code is an utter mess, time for some refactoring)

Grrr1337

  • Swamp Rat
  • Posts: 812
Re: SUDOKU Challenge
« Reply #12 on: October 26, 2017, 05:08:18 PM »
Nice one Grrr1337  :-)

Thanks! :)

FWIW, here's another way to write the 'ValidRowColp' function:
Code - Auto/Visual Lisp: [Select]
  1. (defun validrowcolp ( l )
  2.   (equal (mapcar '(lambda ( n ) (nth n l)) (vl-sort-i l '<)) '(1 2 3 4 5 6 7 8 9))
  3. )

Wow, cool - I didn't thought of this!

Lee, is there a reason to use:
Code: [Select]
(mapcar '(lambda ( n ) (nth n l)) (vl-sort-i l '<))rather than:
Code: [Select]
(vl-sort l '<)because now I think that the simpliest way to write it would be:
Code: [Select]
(defun validrowcolp ( l )
  (equal (vl-sort l '<) '(1 2 3 4 5 6 7 8 9))
)
wouldn't came up with this, without your suggestion :) [since I might overthinked my version of ValidRowColp].   


Just for fun, here are two more ways to group the matrix into the 3x3 submatrices, depending on the order desired:
...

Thats very cool! :lol:


I think I'm there:
...
Though, the algorithm is essentially brute-force, so for sparse inputs be prepared to wait...  :wink:

Lee, are you sure it doesn't get into endless loop? :
Code - Auto/Visual Lisp: [Select]
  1. (sudoku
  2.   '(
  3.     (6 nil nil nil 8 5 1 nil nil)
  4.     (nil nil nil nil nil nil nil 5 3)
  5.     (4 nil nil nil nil 9 8 nil nil)
  6.     (nil nil nil nil nil nil nil 1 nil)
  7.     (nil 8 nil 3 2 6 nil 7 nil)
  8.     (nil 3 nil 1 nil nil nil nil nil)
  9.     (nil nil 7 nil nil nil nil nil 4)
  10.     (nil 5 nil nil nil nil nil nil nil)
  11.     (nil nil nil 9 4 nil nil nil 2)
  12.   )
  13. )


BTW, I have an idea about the actual game (which includes DCL) but I must have more free time to write it. :idea:
Although it doesn't include sudoku solvers - just initial list of unsolved sudoku, like the above, along with user input and IsSudokuValid checking.
(apply ''((a b c)(a b c))
  '(
    (( f L ) (apply 'strcat (f L)))
    (( L ) (if L (cons (chr (car L)) (f (cdr L)))))
    (72 101 108 108 111 32 87 111 114 108 100)
  )
)
vevo.bg

Stefan

  • Bull Frog
  • Posts: 319
  • The most I miss IRL is the Undo button
Re: SUDOKU Challenge
« Reply #13 on: October 26, 2017, 07:21:44 PM »
Hello everyone

Here is my solution. It is very slow, but it can solve even the allegedly hardest sudoku in the world (btw, i couldn't solve it on paper...); the grid is supposed to be fair (no conflicts in the initial grid) and solvable.

Code - Auto/Visual Lisp: [Select]
  1. (defun sudoku (ini / *error* o rows cols sqrs l cluster replace solve j)
  2.  
  3.   (defun *error* (msg) (princ))
  4.  
  5.   (setq o    '(  0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26
  6.                 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53
  7.                 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80
  8.               )
  9.         rows '(( 0  1  2  3  4  5  6  7  8) ( 9 10 11 12 13 14 15 16 17) (18 19 20 21 22 23 24 25 26)
  10.                (27 28 29 30 31 32 33 34 35) (36 37 38 39 40 41 42 43 44) (45 46 47 48 49 50 51 52 53)
  11.                (54 55 56 57 58 59 60 61 62) (63 64 65 66 67 68 69 70 71) (72 73 74 75 76 77 78 79 80)
  12.               )
  13.         cols '(( 0  9 18 27 36 45 54 63 72) ( 1 10 19 28 37 46 55 64 73) ( 2 11 20 29 38 47 56 65 74)
  14.                ( 3 12 21 30 39 48 57 66 75) ( 4 13 22 31 40 49 58 67 76) ( 5 14 23 32 41 50 59 68 77)
  15.                ( 6 15 24 33 42 51 60 69 78) ( 7 16 25 34 43 52 61 70 79) ( 8 17 26 35 44 53 62 71 80)
  16.               )
  17.         sqrs '(( 0  1  2  9 10 11 18 19 20) ( 3  4  5 12 13 14 21 22 23) ( 6  7  8 15 16 17 24 25 26)
  18.                (27 28 29 36 37 38 45 46 47) (30 31 32 39 40 41 48 49 50) (33 34 35 42 43 44 51 52 53)
  19.                (54 55 56 63 64 65 72 73 74) (57 58 59 66 67 68 75 76 77) (60 61 62 69 70 71 78 79 80)
  20.               )
  21.         l     '(1 2 3 4 5 6 7 8 9)
  22.         j     0
  23.   )
  24.  
  25.   (defun cluster (m i a)
  26.     (mapcar
  27.      '(lambda (x) (nth x m))
  28.       (vl-some '(lambda (x) (if (vl-position i x) x)) a)
  29.     )
  30.   )
  31.  
  32.   (defun replace (q m)
  33.     (mapcar
  34.       '(lambda (i n)
  35.          (cond ((cadr (assoc i q))) (n))
  36.        )
  37.       o m
  38.     )
  39.   )
  40.  
  41.   (defun solve (m f / i x c r u cd1 n q)
  42. ;;;    (print m)
  43.     (if
  44.       (vl-every 'numberp m)
  45.       (progn
  46.         (princ "\n")
  47.         (mapcar
  48.          '(lambda (a b)
  49.             (princ (if (zerop (rem a 9)) "\n " " ")) (princ b)
  50.             (if
  51.               (vl-position (rem a 9) '(2 5))
  52.               (princ " |")
  53.             )
  54.             (if
  55.               (vl-position a '(26 53))
  56.               (princ "\n ---------------------")
  57.             )      
  58.           )
  59.           o m
  60.         )
  61.         (princ "\n") ;(princ j)
  62.         (textscr)
  63.         (quit)
  64.       )
  65.     )
  66.  
  67.     (setq i 80 j (1+ j))
  68.     (while (>= i 0)
  69.       (setq x (nth i m))
  70.       (if
  71.         (not x)
  72.         (progn
  73.           (setq u (append (cluster m i rows) (cluster m i cols) (cluster m i sqrs)))
  74.           (if
  75.             (setq c (vl-remove-if '(lambda (n) (member n u)) l))
  76.             (setq r (cons (cons i c) r))
  77.             (setq r nil i -1)
  78.           )
  79.         )
  80.       )
  81.       (setq i (1- i))
  82.     )
  83.    
  84.     (setq q (vl-remove-if '(lambda (a) (cddr a)) r))
  85.    
  86.     (foreach sect '(rows cols sqrs)
  87.       (foreach group (eval sect)
  88.         (setq cd1 (vl-remove-if-not '(lambda (a) (vl-position (car a) group)) r))
  89.         (foreach a cd1
  90.           (setq n (car a))
  91.           (foreach e (cdr a)
  92.             (or
  93.               (vl-some '(lambda (b) (vl-position e (cdr b))) (vl-remove a cd1))
  94.               (assoc n q)
  95.               (setq q (cons (list n e) q))
  96.             )
  97.           )
  98.         )
  99.       )
  100.     )
  101.    
  102.     (cond
  103.       (q ;(print q)
  104.         (if f
  105.           (solve (replace (list (car q)) m) f)
  106.           (solve (replace            q   m) f)
  107.         )
  108.       )
  109.       (r
  110.         (foreach a (cdar r)
  111.           (solve (replace (list (list (caar r) a)) m) t)
  112.         )
  113.       )
  114.     )
  115.   )
  116.   (solve (cond ((= (length ini) 9) (apply 'append ini)) (ini))  nil)
  117. )

Code - Auto/Visual Lisp: [Select]
  1. ;hardest sudoku
  2. (sudoku '(
  3.            (  8 nil nil nil nil nil nil nil nil)
  4.            (nil nil   3   6 nil nil nil nil nil)
  5.            (nil   7 nil nil   9 nil   2 nil nil)
  6.            (nil   5 nil nil nil   7 nil nil nil)
  7.            (nil nil nil nil   4   5   7 nil nil)
  8.            (nil nil nil   1 nil nil nil   3 nil)
  9.            (nil nil   1 nil nil nil nil   6   8)
  10.            (nil nil   8   5 nil nil nil   1 nil)
  11.            (nil   9 nil nil nil nil   4 nil nil)
  12.          )
  13. )
  14. ;test grid 1
  15. (sudoku '(
  16.            (  6 nil nil nil   8   5   1 nil nil)
  17.            (nil nil nil nil nil nil nil   5   3)
  18.            (  4 nil nil nil nil   9   8 nil nil)
  19.            (nil nil nil nil nil nil nil   1 nil)
  20.            (nil   8 nil   3   2   6 nil   7 nil)
  21.            (nil   3 nil   1 nil nil nil nil nil)
  22.            (nil nil   7 nil nil nil nil nil   4)
  23.            (nil   5 nil nil nil nil nil nil nil)
  24.            (nil nil nil   9   4 nil nil nil   2)
  25.          )
  26. )
  27. ;test grid 2
  28. (sudoku '(
  29.            (nil nil   4   8 nil nil nil  1    7)
  30.            (  6   7 nil   9 nil nil nil nil nil)
  31.            (  5 nil   8 nil   3 nil nil nil   4)
  32.            (  3 nil nil   7   4 nil   1 nil nil)
  33.            (nil   6   9 nil nil nil   7   8 nil)
  34.            (nil nil   1 nil   6   9 nil nil   5)
  35.            (  1 nil nil nil   8 nil   3 nil   6)
  36.            (nil nil nil nil nil   6 nil   9   1)
  37.            (  2   4 nil nil nil   1   5 nil nil)
  38.          )
  39. )
  40. ;some grid
  41. (sudoku '(
  42.            (  1 nil nil nil nil   7 nil   9 nil)
  43.            (nil   3 nil nil   2 nil nil nil   8)
  44.            (nil nil   9   6 nil nil   5 nil nil)
  45.            (nil nil   5   3 nil nil   9 nil nil)
  46.            (nil   1 nil nil   8 nil nil nil   2)
  47.            (  6 nil nil nil nil   4 nil nil nil)
  48.            (  3 nil nil nil nil nil nil   1 nil)
  49.            (nil   4 nil nil nil nil nil nil   7)
  50.            (nil nil   7 nil nil nil   3 nil nil)
  51.         )
  52. )
« Last Edit: October 26, 2017, 07:51:19 PM by Stefan »

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: SUDOKU Challenge
« Reply #14 on: October 27, 2017, 12:36:44 PM »
I shall certainly be studying your solution Stefan! :-)

On first glance, I really like your much simpler method of selecting the row/column/square entries, rather than the intricate list manipulation involved in my code...